Commit | Line | Data |
---|---|---|
136211a9 EZ |
1 | ;; Calculator for GNU Emacs, part I |
2 | ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. | |
3 | ;; Written by Dave Gillespie, daveg@synaptics.com. | |
4 | ||
5 | ;; This file is part of GNU Emacs. | |
6 | ||
7 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
8 | ;; but WITHOUT ANY WARRANTY. No author or distributor | |
9 | ;; accepts responsibility to anyone for the consequences of using it | |
10 | ;; or for whether it serves any particular purpose or works at all, | |
11 | ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
12 | ;; License for full details. | |
13 | ||
14 | ;; Everyone is granted permission to copy, modify and redistribute | |
15 | ;; GNU Emacs, but only under the conditions described in the | |
16 | ;; GNU Emacs General Public License. A copy of this license is | |
17 | ;; supposed to have been given to you along with GNU Emacs so you | |
18 | ;; can know your rights and responsibilities. It should be in a | |
19 | ;; file named COPYING. Among other things, the copyright notice | |
20 | ;; and this notice must be preserved on all copies. | |
21 | ||
22 | ||
23 | ||
24 | ;;; Calc is split into many files. This file is the main entry point. | |
25 | ;;; This file includes autoload commands for various other basic Calc | |
26 | ;;; facilities. The more advanced features are based in calc-ext, which | |
27 | ;;; in turn contains autoloads for the rest of the Calc files. This | |
28 | ;;; odd set of interactions is designed to make Calc's loading time | |
29 | ;;; be as short as possible when only simple calculations are needed. | |
30 | ||
31 | ;;; Suggested usage: | |
32 | ;;; | |
33 | ;;; (autoload 'calc-dispatch "calc" "Emacs Calculator" t nil) | |
34 | ;;; (global-set-key "\e#" 'calc-dispatch) | |
35 | ;;; Type `M-# M-#' to start. | |
36 | ;;; | |
37 | ;;; The Calc home directory must be added to the Emacs load-path: | |
38 | ;;; | |
39 | ;;; (setq load-path (cons "/x/y/z/calc" load-path)) | |
40 | ;;; | |
41 | ;;; where "/x/y/z/calc" represents the full name of the Calc home directory. | |
42 | ;;; | |
43 | ;;; See the file INSTALL for a complete list of recommeded autoload | |
44 | ;;; commands (though only calc-dispatch is absolutely necessary). | |
45 | ||
46 | ||
47 | ;;; Author's address: | |
48 | ;;; Dave Gillespie, daveg@synaptics.com, uunet!synaptx!daveg. | |
49 | ;;; Synaptics, Inc., 2698 Orchard Parkway, San Jose, CA 95134. | |
50 | ;;; | |
51 | ;;; The old address daveg@csvax.cs.caltech.edu will continue to | |
52 | ;;; work for the foreseeable future. | |
53 | ;;; | |
54 | ;;; The latest version of Calc is always available from anonymous FTP | |
55 | ;;; on csvax.cs.caltech.edu [131.215.131.131]; look in ~ftp/pub/calc*. | |
56 | ;;; It should also be available on prep.ai.mit.edu. | |
57 | ;;; | |
58 | ;;; Bug reports and suggestions are always welcome! | |
59 | ||
60 | ||
61 | ;;; All functions, macros, and Lisp variables defined here begin with one | |
62 | ;;; of the prefixes "math", "Math", or "calc", with the exceptions of | |
63 | ;;; "full-calc", "full-calc-keypad", "another-calc", "quick-calc", | |
64 | ;;; "report-calc-bug", and "defmath". User-accessible variables begin | |
65 | ;;; with "var-". | |
66 | ||
67 | ||
68 | ||
69 | (provide 'calc) | |
70 | ||
71 | ||
72 | (defun calc-record-compilation-date () | |
73 | (calc-record-compilation-date-macro) | |
74 | ) | |
75 | (calc-record-compilation-date) | |
76 | ||
77 | ||
78 | ;;; The "###autoload" comment will be used by Emacs version 19 for | |
79 | ;;; maintaining the loaddefs.el file automatically. | |
80 | ||
81 | ;;;###autoload | |
82 | (defvar calc-info-filename "calc.info" | |
83 | "*File name in which to look for the Calculator's Info documentation.") | |
84 | ||
85 | ;;;###autoload | |
86 | (defvar calc-settings-file "~/.emacs" | |
87 | "*File in which to record permanent settings; default is \"~/.emacs\".") | |
88 | ||
89 | ;;;###autoload | |
90 | (defvar calc-autoload-directory nil | |
91 | "Name of directory from which additional \".elc\" files for Calc should be | |
92 | loaded. Should include a trailing \"/\". | |
93 | If nil, use original installation directory. | |
94 | This can safely be nil as long as the Calc files are on the load-path.") | |
95 | ||
96 | ;;;###autoload | |
97 | (defvar calc-gnuplot-name "gnuplot" | |
98 | "*Name of GNUPLOT program, for calc-graph features.") | |
99 | ||
100 | ;;;###autoload | |
101 | (defvar calc-gnuplot-plot-command nil | |
102 | "*Name of command for displaying GNUPLOT output; %s = file name to print.") | |
103 | ||
104 | ;;;###autoload | |
105 | (defvar calc-gnuplot-print-command "lp %s" | |
106 | "*Name of command for printing GNUPLOT output; %s = file name to print.") | |
107 | ||
108 | ||
109 | ;; Address of the author of Calc, for use by report-calc-bug. | |
110 | (defvar calc-bug-address "daveg@synaptics.com") | |
111 | ||
112 | ||
113 | ;; If T, scan keymaps to find all DEL-like keys. | |
114 | ;; If NIL, only DEL itself is mapped to calc-pop. | |
115 | (defvar calc-scan-for-dels t) | |
116 | ||
117 | ||
118 | ||
119 | (defvar calc-extensions-loaded nil) | |
120 | ||
121 | ||
122 | ||
123 | ;;; IDEAS: | |
124 | ;;; | |
125 | ;;; Fix rewrite mechanism to do less gratuitous rearrangement of terms. | |
126 | ;;; Implement a pattern-based "refers" predicate. | |
127 | ;;; | |
128 | ;;; Make it possible to Undo a selection command. | |
129 | ;;; Figure out how to allow selecting rows of matrices. | |
130 | ;;; If cursor was in selection before, move it after j n, j p, j L, etc. | |
131 | ;;; Consider reimplementing calc-delete-selection using rewrites. | |
132 | ;;; | |
133 | ;;; Implement line-breaking in non-flat compositions (is this desirable?). | |
134 | ;;; Implement matrix formatting with multi-line components. | |
135 | ;;; | |
136 | ;;; Have "Z R" define a user command based on a set of rewrite rules. | |
137 | ;;; Support "incf" and "decf" in defmath definitions. | |
138 | ;;; Have defmath generate calls to calc-binary-op or calc-unary-op. | |
139 | ;;; Make some way to define algebraic functions using keyboard macros. | |
140 | ;;; | |
141 | ;;; Allow calc-word-size=0 => Common Lisp-style signed bitwise arithmetic. | |
142 | ;;; Consider digamma function (and thus arb. prec. Euler's gamma constant). | |
143 | ;;; May as well make continued-fractions stuff available to the user. | |
144 | ;;; | |
145 | ;;; How about matrix eigenvalues, SVD, pseudo-inverse, etc.? | |
146 | ;;; Should cache matrix inverses as well as decompositions. | |
147 | ;;; If dividing by a non-square matrix, use least-squares automatically. | |
148 | ;;; Consider supporting matrix exponentials. | |
149 | ;;; | |
150 | ;;; Have ninteg detect and work around singularities at the endpoints. | |
151 | ;;; Use an adaptive subdivision algorithm for ninteg. | |
152 | ;;; Provide nsum and nprod to go along with ninteg. | |
153 | ;;; | |
154 | ;;; Handle TeX-mode parsing of \matrix{ ... } where ... contains braces. | |
155 | ;;; Support AmS-TeX's \{d,t,}frac, \{d,t,}binom notations. | |
156 | ;;; Format and parse sums and products in Eqn and Math modes. | |
157 | ;;; | |
158 | ;;; Get math-read-big-expr to read sums, products, etc. | |
159 | ;;; Change calc-grab-region to use math-read-big-expr. | |
160 | ;;; Have a way to define functions using := in Embedded Mode. | |
161 | ;;; | |
162 | ;;; Support polar plotting with GNUPLOT. | |
163 | ;;; Make a calc-graph-histogram function. | |
164 | ;;; | |
165 | ;;; Replace hokey formulas for complex functions with formulas designed | |
166 | ;;; to minimize roundoff while maintaining the proper branch cuts. | |
167 | ;;; Test accuracy of advanced math functions over whole complex plane. | |
168 | ;;; Extend Bessel functions to provide arbitrary precision. | |
169 | ;;; Extend advanced math functions to handle error forms and intervals. | |
170 | ;;; Provide a better implementation for math-sin-cos-raw. | |
171 | ;;; Provide a better implementation for math-hypot. | |
172 | ;;; Provide a better implementation for math-make-frac. | |
173 | ;;; Provide a better implementation for calcFunc-prfac. | |
174 | ;;; Provide a better implementation for calcFunc-factor. | |
175 | ;;; | |
176 | ;;; Provide more examples in the tutorial section of the manual. | |
177 | ;;; Cover in the tutorial: simplification modes, declarations, | |
178 | ;;; bitwise stuff, selections, matrix mapping, financial functions. | |
179 | ;;; Provide more Lisp programming examples in the manual. | |
180 | ;;; Finish the Internals section of the manual (and bring it up to date). | |
181 | ;;; | |
182 | ;;; Tim suggests adding spreadsheet-like features. | |
183 | ;;; Implement language modes for Gnuplot, Lisp, Ada, APL, ...? | |
184 | ;;; | |
185 | ||
186 | ||
187 | ;;; For atan series, if x > tan(pi/12) (about 0.268) reduce using the identity | |
188 | ;;; atan(x) = atan((x * sqrt(3) - 1) / (sqrt(3) + x)) + pi/6. | |
189 | ||
190 | ||
191 | ;;; A better integration algorithm: | |
192 | ;;; Use breadth-first instead of depth-first search, as follows: | |
193 | ;;; The integral cache allows unfinished integrals in symbolic notation | |
194 | ;;; on the righthand side. An entry with no unfinished integrals on the | |
195 | ;;; RHS is "complete"; references to it elsewhere are replaced by the | |
196 | ;;; integrated value. More than one cache entry for the same integral | |
197 | ;;; may exist, though if one becomes complete, the others may be deleted. | |
198 | ;;; The integrator works by using every applicable rule (such as | |
199 | ;;; substitution, parts, linearity, etc.) to generate possible righthand | |
200 | ;;; sides, all of which are entered into the cache. Now, as long as the | |
201 | ;;; target integral is not complete (and the time limit has not run out) | |
202 | ;;; choose an incomplete integral from the cache and, for every integral | |
203 | ;;; appearing in its RHS's, add those integrals to the cache using the | |
204 | ;;; same substitition, parts, etc. rules. The cache should be organized | |
205 | ;;; as a priority queue, choosing the "simplest" incomplete integral at | |
206 | ;;; each step, or choosing randomly among equally simple integrals. | |
207 | ;;; Simplicity equals small size, and few steps removed from the original | |
208 | ;;; target integral. Note that when the integrator finishes, incomplete | |
209 | ;;; integrals can be left in the cache, so the algorithm can start where | |
210 | ;;; it left off if another similar integral is later requested. | |
211 | ;;; Breadth-first search would avoid the nagging problem of, e.g., whether | |
212 | ;;; to use parts or substitution first, and which decomposition is best. | |
213 | ;;; All are tried, and any path that diverges will quickly be put on the | |
214 | ;;; back burner by the priority queue. | |
215 | ;;; Note: Probably a good idea to call math-simplify-extended before | |
216 | ;;; measuring a formula's simplicity. | |
217 | ||
218 | ||
219 | ||
220 | ||
221 | ||
222 | ||
223 | ;; Calculator stack. | |
224 | ;; Entries are 3-lists: Formula, Height (in lines), Selection (or nil). | |
225 | (defvar calc-stack '((top-of-stack 1 nil))) | |
226 | ||
227 | ;; Index into calc-stack of "top" of stack. | |
228 | ;; This is 1 unless calc-truncate-stack has been used. | |
229 | ;;(defvar calc-stack-top 1) | |
230 | ||
231 | ;; If non-NIL, load the calc-ext module automatically when calc is loaded. | |
232 | ;;(defvar calc-always-load-extensions nil) | |
233 | ||
234 | ;; If non-NIL, display line numbers in Calculator stack. | |
235 | ;;(defvar calc-line-numbering t) | |
236 | ||
237 | ;; If non-NIL, break long values across multiple lines in Calculator stack. | |
238 | ;;(defvar calc-line-breaking t) | |
239 | ||
240 | ;; If NIL, stack display is left-justified. | |
241 | ;; If 'right, stack display is right-justified. | |
242 | ;; If 'center, stack display is centered." | |
243 | ;;(defvar calc-display-just nil) | |
244 | ||
245 | ;; Horizontal origin of displayed stack entries. | |
246 | ;; In left-justified mode, this is effectively indentation. (Default 0). | |
247 | ;; In right-justified mode, this is effectively window width. | |
248 | ;; In centered mode, center of stack entry is placed here. | |
249 | ;;(defvar calc-display-origin nil) | |
250 | ||
251 | ;; Radix for entry and display of numbers in calc-mode, 2-36. | |
252 | ;;(defvar calc-number-radix 10) | |
253 | ||
254 | ;; If non-NIL, leading zeros are provided to pad integers to calc-word-size. | |
255 | ;;(defvar calc-leading-zeros nil) | |
256 | ||
257 | ;; If non-NIL, group digits in large displayed integers by inserting spaces. | |
258 | ;; If an integer, group that many digits at a time. | |
259 | ;; If 't', use 4 for binary and hex, 3 otherwise. | |
260 | ;;(defvar calc-group-digits nil) | |
261 | ||
262 | ;; The character (in the form of a string) to be used for grouping digits. | |
263 | ;; This is used only when calc-group-digits mode is on. | |
264 | ;;(defvar calc-group-char ",") | |
265 | ||
266 | ;; The character (in the form of a string) to be used as a decimal point. | |
267 | ;;(defvar calc-point-char ".") | |
268 | ||
269 | ;; Format of displayed fractions; a string of one or two of ":" or "/". | |
270 | ;;(defvar calc-frac-format '(":" nil)) | |
271 | ||
272 | ;; If non-NIL, prefer fractional over floating-point results. | |
273 | ;;(defvar calc-prefer-frac nil) | |
274 | ||
275 | ;; Format of displayed hours-minutes-seconds angles, a format string. | |
276 | ;; String must contain three %s marks for hours, minutes, seconds respectively. | |
277 | ;;(defvar calc-hms-format "%s@ %s' %s\"") | |
278 | ||
279 | ;; Format of displayed date forms. | |
280 | ;;(defvar calc-date-format '((H ":" mm ":" SS pp " ") Www " " Mmm " " D ", " YYYY)) | |
281 | ||
282 | ;; Format to use for display of floating-point numbers in calc-mode. | |
283 | ;; Must be a list of one of the following forms: | |
284 | ;; (float 0) Floating point format, display full precision. | |
285 | ;; (float N) N > 0: Floating point format, at most N significant figures. | |
286 | ;; (float -N) -N < 0: Floating point format, calc-internal-prec - N figs. | |
287 | ;; (fix N) N >= 0: Fixed point format, N places after decimal point. | |
288 | ;; (sci 0) Scientific notation, full precision. | |
289 | ;; (sci N) N > 0: Scientific notation, N significant figures. | |
290 | ;; (sci -N) -N < 0: Scientific notation, calc-internal-prec - N figs. | |
291 | ;; (eng 0) Engineering notation, full precision. | |
292 | ;; (eng N) N > 0: Engineering notation, N significant figures. | |
293 | ;; (eng -N) -N < 0: Engineering notation, calc-internal-prec - N figs. | |
294 | ;;(defvar calc-float-format '(float 0)) | |
295 | ||
296 | ;; Format to use when full precision must be displayed. | |
297 | ;;(defvar calc-full-float-format '(float 0)) | |
298 | ||
299 | ;; Format to use for display of complex numbers in calc-mode. Must be one of: | |
300 | ;; nil Use (x, y) form. | |
301 | ;; i Use x + yi form. | |
302 | ;; j Use x + yj form. | |
303 | ;;(defvar calc-complex-format nil) | |
304 | ||
305 | ;; Preferred form, either 'cplx or 'polar, for complex numbers. | |
306 | ;;(defvar calc-complex-mode 'cplx) | |
307 | ||
308 | ;; If NIL, 1 / 0 is left unsimplified. | |
309 | ;; If 0, 1 / 0 is changed to inf (zeros are considered positive). | |
310 | ;; Otherwise, 1 / 0 is changed to uinf (undirected infinity). | |
311 | ;;(defvar calc-infinite-mode nil) | |
312 | ||
313 | ;; If non-NIL, display vectors of byte-sized integers as strings. | |
314 | ;;(defvar calc-display-strings nil) | |
315 | ||
316 | ;; If NIL, vector elements are left-justified. | |
317 | ;; If 'right, vector elements are right-justified. | |
318 | ;; If 'center, vector elements are centered." | |
319 | ;;(defvar calc-matrix-just 'center) | |
320 | ||
321 | ;; If non-NIL, display vectors one element per line. | |
322 | ;;(defvar calc-break-vectors nil) | |
323 | ||
324 | ;; If non-NIL, display long vectors in full. If NIL, use abbreviated form. | |
325 | ;;(defvar calc-full-vectors t) | |
326 | ||
327 | ;; If non-NIL, display long vectors in full in the trail. | |
328 | ;;(defvar calc-full-trail-vectors t) | |
329 | ||
330 | ;; If non-NIL, separate elements of displayed vectors with this string. | |
331 | ;;(defvar calc-vector-commas ",") | |
332 | ||
333 | ;; If non-NIL, surround displayed vectors with these characters. | |
334 | ;;(defvar calc-vector-brackets "[]") | |
335 | ||
336 | ;; A list of code-letter symbols that control "big" matrix display. | |
337 | ;; If 'R is present, display inner brackets for matrices. | |
338 | ;; If 'O is present, display outer brackets for matrices (above/below). | |
339 | ;; If 'C is present, display outer brackets for matrices (centered). | |
340 | ;;(defvar calc-matrix-brackets '(R O)) | |
341 | ||
342 | ;; Language or format for entry and display of stack values. Must be one of: | |
343 | ;; nil Use standard Calc notation. | |
344 | ;; flat Use standard Calc notation, one-line format. | |
345 | ;; big Display formulas in 2-d notation (enter w/std notation). | |
346 | ;; unform Use unformatted display: add(a, mul(b,c)). | |
347 | ;; c Use C language notation. | |
348 | ;; pascal Use Pascal language notation. | |
349 | ;; fortran Use Fortran language notation. | |
350 | ;; tex Use TeX notation. | |
351 | ;; eqn Use eqn notation. | |
352 | ;; math Use Mathematica(tm) notation. | |
353 | ;; maple Use Maple notation. | |
354 | ;;(defvar calc-language nil) | |
355 | ||
356 | ;; Numeric prefix argument for the command that set calc-language. | |
357 | ;;(defvar calc-language-option nil) | |
358 | ||
359 | ;; Open-parenthesis string for function call notation. | |
360 | ;;(defvar calc-function-open "(") | |
361 | ||
362 | ;; Close-parenthesis string for function call notation. | |
363 | ;;(defvar calc-function-close ")") | |
364 | ||
365 | ;; Function through which to pass strings after formatting. | |
366 | ;;(defvar calc-language-output-filter nil) | |
367 | ||
368 | ;; Function through which to pass strings before parsing. | |
369 | ;;(defvar calc-language-input-filter nil) | |
370 | ||
371 | ;; Formatting function used for non-decimal numbers. | |
372 | ;;(defvar calc-radix-formatter nil) | |
373 | ||
374 | ;; Label to display at left of formula. | |
375 | ;;(defvar calc-left-label "") | |
376 | ||
377 | ;; Label to display at right of formula. | |
378 | ;;(defvar calc-right-label "") | |
379 | ||
380 | ;; Minimum number of bits per word, if any, for binary operations in calc-mode. | |
381 | ;;(defvar calc-word-size 32) | |
382 | ||
383 | ;; Most recently used value of M in a modulo form. | |
384 | ;;(defvar calc-previous-modulo nil) | |
385 | ||
386 | ;; Type of simplification applied to results. | |
387 | ;; If 'none, results are not simplified when pushed on the stack. | |
388 | ;; If 'num, functions are simplified only when args are constant. | |
389 | ;; If NIL, only fast simplifications are applied. | |
390 | ;; If 'binary, math-clip is applied if appropriate. | |
391 | ;; If 'alg, math-simplify is applied. | |
392 | ;; If 'ext, math-simplify-extended is applied. | |
393 | ;; If 'units, math-simplify-units is applied. | |
394 | ;;(defvar calc-simplify-mode nil) | |
395 | ||
396 | ;; If non-NIL, recompute evalto's automatically when necessary. | |
397 | ;;(defvar calc-auto-recompute t) | |
398 | ||
399 | ;; If non-NIL, display shows unformatted Lisp exprs. (For debugging) | |
400 | ;;(defvar calc-display-raw nil) | |
401 | ||
402 | ;; Number of digits of internal precision for calc-mode calculations. | |
403 | ;;(defvar calc-internal-prec 12) | |
404 | ||
405 | ;; If non-NIL, next operation is Inverse. | |
406 | ;;(defvar calc-inverse-flag nil) | |
407 | ||
408 | ;; If non-NIL, next operation is Hyperbolic. | |
409 | ;;(defvar calc-hyperbolic-flag nil) | |
410 | ||
411 | ;; If non-NIL, next operation should not remove its arguments from stack. | |
412 | ;;(defvar calc-keep-args-flag nil) | |
413 | ||
414 | ;; If deg, angles are in degrees; if rad, angles are in radians. | |
415 | ;; If hms, angles are in degrees-minutes-seconds. | |
416 | ;;(defvar calc-angle-mode 'deg) | |
417 | ||
418 | ;; If non-NIL, numeric entry accepts whole algebraic expressions. | |
419 | ;; If NIL, algebraic expressions must be preceded by "'". | |
420 | ;;(defvar calc-algebraic-mode nil) | |
421 | ||
422 | ;; Like calc-algebraic-mode except only affects ( and [ keys. | |
423 | ;;(defvar calc-incomplete-algebraic-mode nil) | |
424 | ||
425 | ;; If non-NIL, inexact numeric computations like sqrt(2) are postponed. | |
426 | ;; If NIL, computations on numbers always yield numbers where possible. | |
427 | ;;(defvar calc-symbolic-mode nil) | |
428 | ||
429 | ;; If 'matrix, variables are assumed to be matrix-valued. | |
430 | ;; If a number, variables are assumed to be NxN matrices. | |
431 | ;; If 'scalar, variables are assumed to be scalar-valued. | |
432 | ;; If NIL, symbolic math routines make no assumptions about variables. | |
433 | ;;(defvar calc-matrix-mode nil) | |
434 | ||
435 | ;; If non-NIL, shifted letter keys are prefix keys rather than normal meanings. | |
436 | ;;(defvar calc-shift-prefix nil) | |
437 | ||
438 | ;; Initial height of Calculator window. | |
439 | ;;(defvar calc-window-height 7) | |
440 | ||
441 | ;; If non-NIL, M-x calc creates a window to display Calculator trail. | |
442 | ;;(defvar calc-display-trail t) | |
443 | ||
444 | ;; If non-NIL, selected sub-formulas are shown by obscuring rest of formula. | |
445 | ;; If NIL, selected sub-formulas are highlighted by obscuring the sub-formulas. | |
446 | ;;(defvar calc-show-selections t) | |
447 | ||
448 | ;; If non-NIL, commands operate only on selected portions of formulas. | |
449 | ;; If NIL, selections displayed but ignored. | |
450 | ;;(defvar calc-use-selections t) | |
451 | ||
452 | ;; If non-NIL, selection hides deep structure of associative formulas. | |
453 | ;;(defvar calc-assoc-selections t) | |
454 | ||
455 | ;; If non-NIL, display "Working..." for potentially slow Calculator commands. | |
456 | ;;(defvar calc-display-working-message 'lots) | |
457 | ||
458 | ;; If non-NIL, automatically execute a "why" command to explain odd results. | |
459 | ;;(defvar calc-auto-why nil) | |
460 | ||
461 | ;; If non-NIL, display timing information on each slow command. | |
462 | ;;(defvar calc-timing nil) | |
463 | ||
464 | ;; Floating-point numbers with this positive exponent or higher above the | |
465 | ;; current precision are displayed in scientific notation in calc-mode. | |
466 | (defvar calc-display-sci-high 0) | |
467 | ||
468 | ;; Floating-point numbers with this negative exponent or lower are displayed | |
469 | ;; scientific notation in calc-mode. | |
470 | (defvar calc-display-sci-low -3) | |
471 | ||
472 | ||
473 | ;; List of used-defined strings to append to Calculator mode line. | |
474 | (defvar calc-other-modes nil) | |
475 | ||
476 | ;; List of strings for Y prefix help. | |
477 | (defvar calc-Y-help-msgs nil) | |
478 | ||
479 | ;; T if calc-settings-file has been loaded yet. | |
480 | (defvar calc-loaded-settings-file nil) | |
481 | ||
482 | ||
483 | ||
484 | (defconst calc-mode-var-list '((calc-always-load-extensions nil) | |
485 | (calc-mode-save-mode local) | |
486 | (calc-line-numbering t) | |
487 | (calc-line-breaking t) | |
488 | (calc-display-just nil) | |
489 | (calc-display-origin nil) | |
490 | (calc-left-label "") | |
491 | (calc-right-label "") | |
492 | (calc-number-radix 10) | |
493 | (calc-leading-zeros nil) | |
494 | (calc-group-digits nil) | |
495 | (calc-group-char ",") | |
496 | (calc-point-char ".") | |
497 | (calc-frac-format (":" nil)) | |
498 | (calc-prefer-frac nil) | |
499 | (calc-hms-format "%s@ %s' %s\"") | |
500 | (calc-date-format ((H ":" mm C SS pp " ") | |
501 | Www " " Mmm " " D ", " YYYY)) | |
502 | (calc-standard-date-formats | |
503 | ("N" | |
504 | "<H:mm:SSpp >Www Mmm D, YYYY" | |
505 | "D Mmm YYYY<, h:mm:SS>" | |
506 | "Www Mmm BD< hh:mm:ss> YYYY" | |
507 | "M/D/Y< H:mm:SSpp>" | |
508 | "D.M.Y< h:mm:SS>" | |
509 | "M-D-Y< H:mm:SSpp>" | |
510 | "D-M-Y< h:mm:SS>" | |
511 | "j<, h:mm:SS>" | |
512 | "YYddd< hh:mm:ss>")) | |
513 | (calc-float-format (float 0)) | |
514 | (calc-full-float-format (float 0)) | |
515 | (calc-complex-format nil) | |
516 | (calc-matrix-just center) | |
517 | (calc-full-vectors t) | |
518 | (calc-full-trail-vectors t) | |
519 | (calc-break-vectors nil) | |
520 | (calc-vector-commas ",") | |
521 | (calc-vector-brackets "[]") | |
522 | (calc-matrix-brackets (R O)) | |
523 | (calc-complex-mode cplx) | |
524 | (calc-infinite-mode nil) | |
525 | (calc-display-strings nil) | |
526 | (calc-simplify-mode nil) | |
527 | (calc-auto-recompute t) | |
528 | (calc-word-size 32) | |
529 | (calc-previous-modulo nil) | |
530 | (calc-display-raw nil) | |
531 | (calc-internal-prec 12) | |
532 | (calc-angle-mode deg) | |
533 | (calc-algebraic-mode nil) | |
534 | (calc-incomplete-algebraic-mode nil) | |
535 | (calc-symbolic-mode nil) | |
536 | (calc-matrix-mode nil) | |
537 | (calc-autorange-units nil) | |
538 | (calc-shift-prefix nil) | |
539 | (calc-window-height 7) | |
540 | (calc-was-keypad-mode nil) | |
541 | (calc-full-mode nil) | |
542 | (calc-language nil) | |
543 | (calc-language-option nil) | |
544 | (calc-user-parse-tables nil) | |
545 | (calc-show-selections t) | |
546 | (calc-use-selections t) | |
547 | (calc-assoc-selections t) | |
548 | (calc-display-trail t) | |
549 | (calc-display-working-message lots) | |
550 | (calc-auto-why 'maybe) | |
551 | (calc-timing nil) | |
552 | (calc-gnuplot-default-device "default") | |
553 | (calc-gnuplot-default-output "STDOUT") | |
554 | (calc-gnuplot-print-device "postscript") | |
555 | (calc-gnuplot-print-output "auto") | |
556 | (calc-gnuplot-geometry nil) | |
557 | (calc-graph-default-resolution 15) | |
558 | (calc-graph-default-resolution-3d 5) | |
559 | (calc-invocation-macro nil))) | |
560 | ||
561 | (defconst calc-local-var-list '(calc-stack | |
562 | calc-stack-top | |
563 | calc-undo-list | |
564 | calc-redo-list | |
565 | calc-always-load-extensions | |
566 | calc-mode-save-mode | |
567 | calc-display-raw | |
568 | calc-line-numbering | |
569 | calc-line-breaking | |
570 | calc-display-just | |
571 | calc-display-origin | |
572 | calc-left-label | |
573 | calc-right-label | |
574 | calc-auto-why | |
575 | calc-algebraic-mode | |
576 | calc-incomplete-algebraic-mode | |
577 | calc-symbolic-mode | |
578 | calc-matrix-mode | |
579 | calc-inverse-flag | |
580 | calc-hyperbolic-flag | |
581 | calc-keep-args-flag | |
582 | calc-angle-mode | |
583 | calc-number-radix | |
584 | calc-leading-zeros | |
585 | calc-group-digits | |
586 | calc-group-char | |
587 | calc-point-char | |
588 | calc-frac-format | |
589 | calc-prefer-frac | |
590 | calc-hms-format | |
591 | calc-date-format | |
592 | calc-standard-date-formats | |
593 | calc-float-format | |
594 | calc-full-float-format | |
595 | calc-complex-format | |
596 | calc-matrix-just | |
597 | calc-full-vectors | |
598 | calc-full-trail-vectors | |
599 | calc-break-vectors | |
600 | calc-vector-commas | |
601 | calc-vector-brackets | |
602 | calc-matrix-brackets | |
603 | calc-complex-mode | |
604 | calc-infinite-mode | |
605 | calc-display-strings | |
606 | calc-simplify-mode | |
607 | calc-auto-recompute | |
608 | calc-autorange-units | |
609 | calc-show-plain | |
610 | calc-show-selections | |
611 | calc-use-selections | |
612 | calc-assoc-selections | |
613 | calc-word-size | |
614 | calc-internal-prec)) | |
615 | ||
616 | ||
617 | (defun calc-init-base () | |
618 | ||
619 | ;; Verify that Calc is running on the right kind of system. | |
620 | (setq calc-emacs-type-epoch (and (fboundp 'epoch::version) epoch::version) | |
621 | calc-emacs-type-19 (not (or calc-emacs-type-epoch | |
622 | (string-lessp emacs-version "19"))) | |
623 | calc-emacs-type-lucid (not (not (string-match "Lucid" emacs-version))) | |
624 | calc-emacs-type-gnu19 (and calc-emacs-type-19 | |
625 | (not calc-emacs-type-lucid))) | |
626 | ||
627 | ;; Set up the standard keystroke (M-#) to run the Calculator, if that key | |
628 | ;; has not yet been bound to anything. For best results, the user should | |
629 | ;; do this before Calc is even loaded, so that M-# can auto-load Calc. | |
630 | (or (global-key-binding "\e#") | |
631 | (global-set-key "\e#" 'calc-dispatch)) | |
632 | ||
633 | ;; Set up the autoloading linkage. | |
634 | (let ((name (and (fboundp 'calc-dispatch) | |
635 | (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) | |
636 | (nth 1 (symbol-function 'calc-dispatch)))) | |
637 | (p load-path)) | |
638 | ||
639 | ;; If Calc files exist on the load-path, we're all set. | |
640 | (while (and p (not (file-exists-p | |
641 | (expand-file-name "calc-misc.elc" (car p))))) | |
642 | (setq p (cdr p))) | |
643 | (or p | |
644 | ||
645 | ;; If Calc is autoloaded using a path name, look there for Calc files. | |
646 | ;; This works for both relative ("calc/calc.elc") and absolute paths. | |
647 | (and name (file-name-directory name) | |
648 | (let ((p2 load-path) | |
649 | (name2 (concat (file-name-directory name) | |
650 | "calc-misc.elc"))) | |
651 | (while (and p2 (not (file-exists-p | |
652 | (expand-file-name name2 (car p2))))) | |
653 | (setq p2 (cdr p2))) | |
654 | (if p2 | |
655 | (setq load-path (nconc load-path | |
656 | (list | |
657 | (directory-file-name | |
658 | (file-name-directory | |
659 | (expand-file-name | |
660 | name (car p2)))))))))) | |
661 | ||
662 | ;; If calc-autoload-directory is given, use that (and hope it works!). | |
663 | (and calc-autoload-directory | |
664 | (not (equal calc-autoload-directory "")) | |
665 | (setq load-path (nconc load-path | |
666 | (list (directory-file-name | |
667 | calc-autoload-directory))))))) | |
668 | ||
669 | ;; The following modes use specially-formatted data. | |
670 | (put 'calc-mode 'mode-class 'special) | |
671 | (put 'calc-trail-mode 'mode-class 'special) | |
672 | ||
673 | ;; Define "inexact-result" as an e-lisp error symbol. | |
674 | (put 'inexact-result 'error-conditions '(error inexact-result calc-error)) | |
675 | (put 'inexact-result 'error-message "Calc internal error (inexact-result)") | |
676 | ||
677 | ;; Define "math-overflow" and "math-underflow" as e-lisp error symbols. | |
678 | (put 'math-overflow 'error-conditions '(error math-overflow calc-error)) | |
679 | (put 'math-overflow 'error-message "Floating-point overflow occurred") | |
680 | (put 'math-underflow 'error-conditions '(error math-underflow calc-error)) | |
681 | (put 'math-underflow 'error-message "Floating-point underflow occurred") | |
682 | ||
683 | (setq calc-version "2.02f" | |
684 | calc-version-date "Sun Dec 15 1996" | |
685 | calc-trail-pointer nil ; "Current" entry in trail buffer. | |
686 | calc-trail-overlay nil ; Value of overlay-arrow-string. | |
687 | calc-was-split nil ; Had multiple windows before Calc. | |
688 | calc-undo-list nil ; List of previous operations for undo. | |
689 | calc-redo-list nil ; List of recent undo operations. | |
690 | calc-main-buffer nil ; Pointer to Calculator buffer. | |
691 | calc-trail-buffer nil ; Pointer to Calc Trail buffer. | |
692 | calc-why nil ; Explanations of most recent errors. | |
693 | calc-next-why nil | |
694 | calc-inverse-flag nil | |
695 | calc-hyperbolic-flag nil | |
696 | calc-keep-args-flag nil | |
697 | calc-function-open "(" | |
698 | calc-function-close ")" | |
699 | calc-language-output-filter nil | |
700 | calc-language-input-filter nil | |
701 | calc-radix-formatter nil | |
702 | calc-last-kill nil ; Last number killed in calc-mode. | |
703 | calc-previous-alg-entry nil ; Previous algebraic entry. | |
704 | calc-dollar-values nil ; Values to be used for '$'. | |
705 | calc-dollar-used nil ; Highest order of '$' that occurred. | |
706 | calc-hashes-used nil ; Highest order of '#' that occurred. | |
707 | calc-quick-prev-results nil ; Previous results from Quick Calc. | |
708 | calc-said-hello nil ; Has welcome message been said yet? | |
709 | calc-executing-macro nil ; Kbd macro executing from "K" key. | |
710 | calc-any-selections nil ; Nil means no selections present. | |
711 | calc-help-phase 0 ; Count of consecutive "?" keystrokes. | |
712 | calc-full-help-flag nil ; Executing calc-full-help? | |
713 | calc-refresh-count 0 ; Count of calc-refresh calls. | |
714 | calc-display-dirty nil | |
715 | calc-prepared-composition nil | |
716 | calc-selection-cache-default-entry nil | |
717 | calc-embedded-info nil | |
718 | calc-embedded-active nil | |
719 | calc-standalone-flag nil | |
720 | var-EvalRules nil | |
721 | math-eval-rules-cache-tag t | |
722 | math-radix-explicit-format t | |
723 | math-expr-function-mapping nil | |
724 | math-expr-variable-mapping nil | |
725 | math-read-expr-quotes nil | |
726 | math-working-step nil | |
727 | math-working-step-2 nil | |
728 | var-i '(special-const (math-imaginary 1)) | |
729 | var-pi '(special-const (math-pi)) | |
730 | var-e '(special-const (math-e)) | |
731 | var-phi '(special-const (math-phi)) | |
732 | var-gamma '(special-const (math-gamma-const)) | |
733 | var-Modes '(special-const (math-get-modes-vec))) | |
734 | ||
735 | (mapcar (function (lambda (v) (or (boundp (car v)) (set (car v) (nth 1 v))))) | |
736 | calc-mode-var-list) | |
737 | (mapcar (function (lambda (v) (or (boundp v) (set v nil)))) | |
738 | calc-local-var-list) | |
739 | ||
740 | (if (boundp 'calc-mode-map) | |
741 | nil | |
742 | (setq calc-mode-map (make-keymap)) | |
743 | (suppress-keymap calc-mode-map t) | |
744 | (define-key calc-mode-map "+" 'calc-plus) | |
745 | (define-key calc-mode-map "-" 'calc-minus) | |
746 | (define-key calc-mode-map "*" 'calc-times) | |
747 | (define-key calc-mode-map "/" 'calc-divide) | |
748 | (define-key calc-mode-map "%" 'calc-mod) | |
749 | (define-key calc-mode-map "&" 'calc-inv) | |
750 | (define-key calc-mode-map "^" 'calc-power) | |
751 | (define-key calc-mode-map "\M-%" 'calc-percent) | |
752 | (define-key calc-mode-map "e" 'calcDigit-start) | |
753 | (define-key calc-mode-map "i" 'calc-info) | |
754 | (define-key calc-mode-map "n" 'calc-change-sign) | |
755 | (define-key calc-mode-map "q" 'calc-quit) | |
756 | (define-key calc-mode-map "Y" 'nil) | |
757 | (define-key calc-mode-map "Y?" 'calc-shift-Y-prefix-help) | |
758 | (define-key calc-mode-map "?" 'calc-help) | |
759 | (define-key calc-mode-map " " 'calc-enter) | |
760 | (define-key calc-mode-map "'" 'calc-algebraic-entry) | |
761 | (define-key calc-mode-map "$" 'calc-auto-algebraic-entry) | |
762 | (define-key calc-mode-map "\"" 'calc-auto-algebraic-entry) | |
763 | (define-key calc-mode-map "\t" 'calc-roll-down) | |
764 | (define-key calc-mode-map "\M-\t" 'calc-roll-up) | |
765 | (define-key calc-mode-map "\C-m" 'calc-enter) | |
766 | (define-key calc-mode-map "\M-\C-m" 'calc-last-args-stub) | |
767 | (define-key calc-mode-map "\C-j" 'calc-over) | |
768 | ||
769 | (mapcar (function | |
770 | (lambda (x) | |
771 | (define-key calc-mode-map (char-to-string x) 'undefined))) | |
772 | "lOW") | |
773 | (mapcar (function | |
774 | (lambda (x) | |
775 | (define-key calc-mode-map (char-to-string x) | |
776 | 'calc-missing-key))) | |
777 | (concat "ABCDEFGHIJKLMNPQRSTUVXZabcdfghjkmoprstuvwxyz" | |
778 | ":\\|!()[]<>{},;=~`\C-k\M-k\C-w\M-w\C-y\C-_")) | |
779 | (mapcar (function | |
780 | (lambda (x) | |
781 | (define-key calc-mode-map (char-to-string x) 'calcDigit-start))) | |
782 | "_0123456789.#@") | |
783 | ||
784 | (setq calc-digit-map (make-keymap)) | |
785 | (if calc-emacs-type-lucid | |
786 | (map-keymap (function | |
787 | (lambda (keys bind) | |
788 | (define-key calc-digit-map keys | |
789 | (if (eq bind 'undefined) | |
790 | 'undefined 'calcDigit-nondigit)))) | |
791 | calc-mode-map) | |
792 | (let ((cmap (if calc-emacs-type-19 (nth 1 calc-mode-map) calc-mode-map)) | |
793 | (dmap (if calc-emacs-type-19 (nth 1 calc-digit-map) | |
794 | calc-digit-map)) | |
795 | (i 0)) | |
796 | (while (< i 128) | |
797 | (aset dmap i | |
798 | (if (eq (aref cmap i) 'undefined) | |
799 | 'undefined 'calcDigit-nondigit)) | |
800 | (setq i (1+ i))))) | |
801 | (mapcar (function | |
802 | (lambda (x) | |
803 | (define-key calc-digit-map (char-to-string x) | |
804 | 'calcDigit-key))) | |
805 | "_0123456789.e+-:n#@oh'\"mspM") | |
806 | (mapcar (function | |
807 | (lambda (x) | |
808 | (define-key calc-digit-map (char-to-string x) | |
809 | 'calcDigit-letter))) | |
810 | "abcdfgijklqrtuvwxyzABCDEFGHIJKLNOPQRSTUVWXYZ") | |
811 | (define-key calc-digit-map "'" 'calcDigit-algebraic) | |
812 | (define-key calc-digit-map "`" 'calcDigit-edit) | |
813 | (define-key calc-digit-map "\C-g" 'abort-recursive-edit) | |
814 | ||
815 | (mapcar (function | |
816 | (lambda (x) | |
817 | (condition-case err | |
818 | (progn | |
819 | (define-key calc-digit-map x 'calcDigit-backspace) | |
820 | (define-key calc-mode-map x 'calc-pop) | |
821 | (define-key calc-mode-map | |
822 | (if (vectorp x) | |
823 | (if calc-emacs-type-lucid | |
824 | (if (= (length x) 1) | |
825 | (vector (if (consp (aref x 0)) | |
826 | (cons 'meta (aref x 0)) | |
827 | (list 'meta (aref x 0)))) | |
828 | "\e\C-d") | |
829 | (vconcat "\e" x)) | |
830 | (concat "\e" x)) | |
831 | 'calc-pop-above)) | |
832 | (error nil)))) | |
833 | (if calc-scan-for-dels | |
834 | (append (where-is-internal 'delete-backward-char global-map) | |
835 | (where-is-internal 'backward-delete-char global-map) | |
836 | '("\C-d")) | |
837 | '("\177" "\C-d"))) | |
838 | ||
839 | (setq calc-dispatch-map (make-keymap)) | |
840 | (mapcar (function | |
841 | (lambda (x) | |
842 | (define-key calc-dispatch-map (char-to-string (car x)) (cdr x)) | |
843 | (if (string-match "abcdefhijklnopqrstuwxyz" | |
844 | (char-to-string (car x))) | |
845 | (define-key calc-dispatch-map | |
846 | (char-to-string (- (car x) ?a -1)) (cdr x))) | |
847 | (define-key calc-dispatch-map (format "\e%c" (car x)) (cdr x)))) | |
848 | '( ( ?a . calc-embedded-activate ) | |
849 | ( ?b . calc-big-or-small ) | |
850 | ( ?c . calc ) | |
851 | ( ?d . calc-embedded-duplicate ) | |
852 | ( ?e . calc-embedded ) | |
853 | ( ?f . calc-embedded-new-formula ) | |
854 | ( ?g . calc-grab-region ) | |
855 | ( ?h . calc-dispatch-help ) | |
856 | ( ?i . calc-info ) | |
857 | ( ?j . calc-embedded-select ) | |
858 | ( ?k . calc-keypad ) | |
859 | ( ?l . calc-load-everything ) | |
860 | ( ?m . read-kbd-macro ) | |
861 | ( ?n . calc-embedded-next ) | |
862 | ( ?o . calc-other-window ) | |
863 | ( ?p . calc-embedded-previous ) | |
864 | ( ?q . quick-calc ) | |
865 | ( ?r . calc-grab-rectangle ) | |
866 | ( ?s . calc-info-summary ) | |
867 | ( ?t . calc-tutorial ) | |
868 | ( ?u . calc-embedded-update-formula ) | |
869 | ( ?w . calc-embedded-word ) | |
870 | ( ?x . calc-quit ) | |
871 | ( ?y . calc-copy-to-buffer ) | |
872 | ( ?z . calc-user-invocation ) | |
873 | ( ?= . calc-embedded-update-formula ) | |
874 | ( ?\' . calc-embedded-new-formula ) | |
875 | ( ?\` . calc-embedded-edit ) | |
876 | ( ?: . calc-grab-sum-down ) | |
877 | ( ?_ . calc-grab-sum-across ) | |
878 | ( ?0 . calc-reset ) | |
879 | ( ?# . calc-same-interface ) | |
880 | ( ?? . calc-dispatch-help ) )) | |
881 | ) | |
882 | ||
883 | (autoload 'calc-extensions "calc-ext") | |
884 | (autoload 'calc-need-macros "calc-macs") | |
885 | ||
886 | ;;;; (Autoloads here) | |
887 | (mapcar (function (lambda (x) | |
888 | (mapcar (function (lambda (func) | |
889 | (autoload func (car x)))) (cdr x)))) | |
890 | '( | |
891 | ||
892 | ("calc-aent" calc-Need-calc-aent calc-alg-digit-entry calc-alg-entry | |
893 | calc-check-user-syntax calc-do-alg-entry calc-do-calc-eval | |
894 | calc-do-quick-calc calc-match-user-syntax math-build-parse-table | |
895 | math-find-user-tokens math-read-expr-list math-read-exprs math-read-if | |
896 | math-read-token math-remove-dashes) | |
897 | ||
898 | ("calc-misc" calc-Need-calc-misc calc-delete-windows-keep | |
899 | calc-do-handle-whys calc-do-refresh calc-num-prefix-name | |
900 | calc-record-list calc-record-why calc-report-bug calc-roll-down-stack | |
901 | calc-roll-up-stack calc-temp-minibuffer-message calcFunc-floor | |
902 | calcFunc-inv calcFunc-trunc math-concat math-constp math-div2 | |
903 | math-div2-bignum math-do-working math-evenp math-fixnatnump | |
904 | math-fixnump math-floor math-imod math-ipow math-looks-negp math-mod | |
905 | math-negp math-posp math-pow math-read-radix-digit math-reject-arg | |
906 | math-trunc math-zerop) | |
907 | ||
908 | )) | |
909 | ||
910 | (mapcar (function (lambda (x) | |
911 | (mapcar (function (lambda (cmd) | |
912 | (autoload cmd (car x) nil t))) (cdr x)))) | |
913 | '( | |
914 | ||
915 | ("calc-aent" calc-algebraic-entry calc-auto-algebraic-entry | |
916 | calcDigit-algebraic calcDigit-edit) | |
917 | ||
918 | ("calc-misc" another-calc calc-big-or-small calc-dispatch-help | |
919 | calc-help calc-info calc-info-summary calc-inv calc-last-args-stub | |
920 | calc-missing-key calc-mod calc-other-window calc-over calc-percent | |
921 | calc-pop-above calc-power calc-roll-down calc-roll-up | |
922 | calc-shift-Y-prefix-help calc-tutorial calcDigit-letter | |
923 | report-calc-bug) | |
924 | ||
925 | )) | |
926 | ||
927 | ) | |
928 | ||
929 | (calc-init-base) | |
930 | ||
931 | ||
932 | ;;;###autoload (global-set-key "\e#" 'calc-dispatch) | |
933 | ||
934 | ;;;###autoload | |
935 | (defun calc-dispatch (&optional arg) | |
936 | "Invoke the GNU Emacs Calculator. See calc-dispatch-help for details." | |
937 | (interactive "P") | |
938 | (sit-for echo-keystrokes) | |
939 | (condition-case err ; look for other keys bound to calc-dispatch | |
940 | (let ((keys (this-command-keys))) | |
941 | (or (not (stringp keys)) | |
942 | (string-match "\\`\C-u\\|\\`\e[-0-9#]\\|`[\M--\M-0-\M-9]" keys) | |
943 | (eq (lookup-key calc-dispatch-map keys) 'calc-same-interface) | |
944 | (progn | |
945 | (and (string-match "\\`[\C-@-\C-_]" keys) | |
946 | (symbolp | |
947 | (lookup-key calc-dispatch-map (substring keys 0 1))) | |
948 | (define-key calc-dispatch-map (substring keys 0 1) nil)) | |
949 | (define-key calc-dispatch-map keys 'calc-same-interface)))) | |
950 | (error nil)) | |
951 | (calc-do-dispatch arg) | |
952 | ) | |
953 | ||
954 | (defun calc-do-dispatch (arg) | |
955 | (let ((key (calc-read-key-sequence | |
956 | (if calc-dispatch-help | |
957 | "Calc options: Calc, Keypad, Quick, Embed; eXit; Info, Tutorial; Grab; ?=more" | |
958 | (format "%s (Type ? for a list of Calc options)" | |
959 | (key-description (this-command-keys)))) | |
960 | calc-dispatch-map))) | |
961 | (setq key (lookup-key calc-dispatch-map key)) | |
962 | (message "") | |
963 | (if key | |
964 | (progn | |
965 | (or (commandp key) (calc-extensions)) | |
966 | (call-interactively key)) | |
967 | (beep))) | |
968 | ) | |
969 | (setq calc-dispatch-help nil) | |
970 | ||
971 | (defun calc-read-key-sequence (prompt map) | |
972 | (let ((prompt2 (format "%s " (key-description (this-command-keys)))) | |
973 | (glob (current-global-map)) | |
974 | (loc (current-local-map))) | |
975 | (or (input-pending-p) (message prompt)) | |
976 | (let ((key (calc-read-key t))) | |
977 | (calc-unread-command (cdr key)) | |
978 | (unwind-protect | |
979 | (progn | |
980 | (use-global-map map) | |
981 | (use-local-map nil) | |
982 | (read-key-sequence | |
983 | (if (commandp (key-binding (if calc-emacs-type-19 | |
984 | (vector (cdr key)) | |
985 | (char-to-string (cdr key))))) | |
986 | "" prompt2))) | |
987 | (use-global-map glob) | |
988 | (use-local-map loc)))) | |
989 | ) | |
990 | ||
991 | ||
992 | ||
993 | (defun calc-mode () | |
994 | "Calculator major mode. | |
995 | ||
996 | This is an RPN calculator featuring arbitrary-precision integer, rational, | |
997 | floating-point, complex, matrix, and symbolic arithmetic. | |
998 | ||
999 | RPN calculation: 2 RET 3 + produces 5. | |
1000 | Algebraic style: ' 2+3 RET produces 5. | |
1001 | ||
1002 | Basic operators are +, -, *, /, ^, & (reciprocal), % (modulo), n (change-sign). | |
1003 | ||
1004 | Press ? repeatedly for more complete help. Press `h i' to read the | |
1005 | Calc manual on-line, `h s' to read the summary, or `h t' for the tutorial. | |
1006 | ||
1007 | Notations: 3.14e6 3.14 * 10^6 | |
1008 | _23 negative number -23 (or type `23 n') | |
1009 | 17:3 the fraction 17/3 | |
1010 | 5:2:3 the fraction 5 and 2/3 | |
1011 | 16#12C the integer 12C base 16 = 300 base 10 | |
1012 | 8#177:100 the fraction 177:100 base 8 = 127:64 base 10 | |
1013 | (2, 4) complex number 2 + 4i | |
1014 | (2; 4) polar complex number (r; theta) | |
1015 | [1, 2, 3] vector ([[1, 2], [3, 4]] is a matrix) | |
1016 | [1 .. 4) semi-open interval, 1 <= x < 4 | |
1017 | 2 +/- 3 (p key) number with mean 2, standard deviation 3 | |
1018 | 2 mod 3 (M key) number 2 computed modulo 3 | |
1019 | <1 jan 91> Date form (enter using ' key) | |
1020 | ||
1021 | ||
1022 | \\{calc-mode-map} | |
1023 | " | |
1024 | (interactive) | |
1025 | (mapcar (function | |
1026 | (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) | |
1027 | (kill-all-local-variables) | |
1028 | (use-local-map (if (eq calc-algebraic-mode 'total) | |
1029 | (progn (calc-extensions) calc-alg-map) calc-mode-map)) | |
1030 | (mapcar (function (lambda (v) (make-local-variable v))) calc-local-var-list) | |
1031 | (make-local-variable 'overlay-arrow-position) | |
1032 | (make-local-variable 'overlay-arrow-string) | |
1033 | (setq truncate-lines t) | |
1034 | (setq buffer-read-only t) | |
1035 | (setq major-mode 'calc-mode) | |
1036 | (setq mode-name "Calculator") | |
1037 | (setq calc-stack-top (length (or (memq (assq 'top-of-stack calc-stack) | |
1038 | calc-stack) | |
1039 | (setq calc-stack (list (list 'top-of-stack | |
1040 | 1 nil)))))) | |
1041 | (setq calc-stack-top (- (length calc-stack) calc-stack-top -1)) | |
1042 | (or calc-loaded-settings-file | |
1043 | (string-match "\\.emacs" calc-settings-file) | |
1044 | (progn | |
1045 | (setq calc-loaded-settings-file t) | |
1046 | (load calc-settings-file t))) ; t = missing-ok | |
1047 | (if (and (eq window-system 'x) (boundp 'mouse-map)) | |
1048 | (substitute-key-definition 'x-paste-text 'calc-x-paste-text | |
1049 | mouse-map)) | |
1050 | (let ((p command-line-args)) | |
1051 | (while p | |
1052 | (and (equal (car p) "-f") | |
1053 | (string-match "calc" (nth 1 p)) | |
1054 | (string-match "full" (nth 1 p)) | |
1055 | (setq calc-standalone-flag t)) | |
1056 | (setq p (cdr p)))) | |
1057 | (run-hooks 'calc-mode-hook) | |
1058 | (calc-refresh t) | |
1059 | (calc-set-mode-line) | |
1060 | ;; The calc-defs variable is a relic. Use calc-define properties instead. | |
1061 | (if (and (boundp 'calc-defs) | |
1062 | calc-defs) | |
1063 | (progn | |
1064 | (message "Evaluating calc-defs...") | |
1065 | (calc-need-macros) | |
1066 | (eval (cons 'progn calc-defs)) | |
1067 | (setq calc-defs nil) | |
1068 | (calc-set-mode-line))) | |
1069 | (calc-check-defines) | |
1070 | ) | |
1071 | ||
1072 | (defun calc-check-defines () | |
1073 | (if (symbol-plist 'calc-define) | |
1074 | (let ((plist (copy-sequence (symbol-plist 'calc-define)))) | |
1075 | (while (and plist (null (nth 1 plist))) | |
1076 | (setq plist (cdr (cdr plist)))) | |
1077 | (if plist | |
1078 | (save-excursion | |
1079 | (calc-extensions) | |
1080 | (calc-need-macros) | |
1081 | (set-buffer "*Calculator*") | |
1082 | (while plist | |
1083 | (put 'calc-define (car plist) nil) | |
1084 | (eval (nth 1 plist)) | |
1085 | (setq plist (cdr (cdr plist)))) | |
1086 | ;; See if this has added any more calc-define properties. | |
1087 | (calc-check-defines)) | |
1088 | (setplist 'calc-define nil)))) | |
1089 | ) | |
1090 | (setq calc-check-defines 'calc-check-defines) ; suitable for run-hooks | |
1091 | ||
1092 | (defun calc-trail-mode (&optional buf) | |
1093 | "Calc Trail mode. | |
1094 | This mode is used by the *Calc Trail* buffer, which records all results | |
1095 | obtained by the GNU Emacs Calculator. | |
1096 | ||
1097 | Calculator commands beginning with the `t' key are used to manipulate | |
1098 | the Trail. | |
1099 | ||
1100 | This buffer uses the same key map as the *Calculator* buffer; calculator | |
1101 | commands given here will actually operate on the *Calculator* stack." | |
1102 | (interactive) | |
1103 | (fundamental-mode) | |
1104 | (use-local-map calc-mode-map) | |
1105 | (setq major-mode 'calc-trail-mode) | |
1106 | (setq mode-name "Calc Trail") | |
1107 | (setq truncate-lines t) | |
1108 | (setq buffer-read-only t) | |
1109 | (make-local-variable 'overlay-arrow-position) | |
1110 | (make-local-variable 'overlay-arrow-string) | |
1111 | (if buf | |
1112 | (progn | |
1113 | (make-local-variable 'calc-main-buffer) | |
1114 | (setq calc-main-buffer buf))) | |
1115 | (if (= (buffer-size) 0) | |
1116 | (let ((buffer-read-only nil)) | |
1117 | (insert "Emacs Calculator v" calc-version " by Dave Gillespie, " | |
1118 | "installed " calc-installed-date "\n"))) | |
1119 | (run-hooks 'calc-trail-mode-hook) | |
1120 | ) | |
1121 | ||
1122 | (defun calc-create-buffer () | |
1123 | (set-buffer (get-buffer-create "*Calculator*")) | |
1124 | (or (eq major-mode 'calc-mode) | |
1125 | (calc-mode)) | |
1126 | (setq max-lisp-eval-depth (max max-lisp-eval-depth 1000)) | |
1127 | (if calc-always-load-extensions | |
1128 | (calc-extensions)) | |
1129 | (if calc-language | |
1130 | (progn | |
1131 | (calc-extensions) | |
1132 | (calc-set-language calc-language calc-language-option t))) | |
1133 | ) | |
1134 | ||
1135 | ;;;###autoload | |
1136 | (defun calc (&optional arg full-display interactive) | |
1137 | "The Emacs Calculator. Full documentation is listed under \"calc-mode\"." | |
1138 | (interactive "P") | |
1139 | (if arg | |
1140 | (or (eq arg 0) | |
1141 | (progn | |
1142 | (calc-extensions) | |
1143 | (if (= (prefix-numeric-value arg) -1) | |
1144 | (calc-grab-region (region-beginning) (region-end) nil) | |
1145 | (if (= (prefix-numeric-value arg) -2) | |
1146 | (calc-keypad))))) | |
1147 | (if (get-buffer-window "*Calc Keypad*") | |
1148 | (progn | |
1149 | (calc-keypad) | |
1150 | (set-buffer (window-buffer (selected-window))))) | |
1151 | (if (eq major-mode 'calc-mode) | |
1152 | (calc-quit) | |
1153 | (let ((oldbuf (current-buffer))) | |
1154 | (calc-create-buffer) | |
1155 | (setq calc-was-keypad-mode nil) | |
1156 | (if (or (eq full-display t) | |
1157 | (and (null full-display) calc-full-mode)) | |
1158 | (switch-to-buffer (current-buffer) t) | |
1159 | (if (get-buffer-window (current-buffer)) | |
1160 | (select-window (get-buffer-window (current-buffer))) | |
1161 | (setq calc-was-split nil) | |
1162 | (if (and (boundp 'calc-window-hook) calc-window-hook) | |
1163 | (run-hooks 'calc-window-hook) | |
1164 | (let ((w (get-largest-window))) | |
1165 | (if (and pop-up-windows | |
1166 | (> (window-height w) | |
1167 | (+ window-min-height calc-window-height 2))) | |
1168 | (progn | |
1169 | (or (one-window-p) | |
1170 | (setq calc-was-split (list w (window-height w) | |
1171 | (selected-window)))) | |
1172 | (setq w (split-window w | |
1173 | (- (window-height w) | |
1174 | calc-window-height 2) | |
1175 | nil)) | |
1176 | (set-window-buffer w (current-buffer)) | |
1177 | (select-window w)) | |
1178 | (pop-to-buffer (current-buffer))))))) | |
1179 | (save-excursion | |
1180 | (set-buffer (calc-trail-buffer)) | |
1181 | (and calc-display-trail | |
1182 | (= (window-width) (screen-width)) | |
1183 | (calc-trail-display 1 t))) | |
1184 | (message "Welcome to the GNU Emacs Calculator! Press `?' or `h' for help, `q' to quit.") | |
1185 | (run-hooks 'calc-start-hook) | |
1186 | (and (windowp full-display) | |
1187 | (window-point full-display) | |
1188 | (select-window full-display)) | |
1189 | (calc-check-defines) | |
1190 | (and calc-said-hello | |
1191 | (or (interactive-p) interactive) | |
1192 | (progn | |
1193 | (sit-for 2) | |
1194 | (message ""))) | |
1195 | (setq calc-said-hello t)))) | |
1196 | ) | |
1197 | ||
1198 | ;;;###autoload | |
1199 | (defun full-calc () | |
1200 | "Invoke the Calculator and give it a full-sized window." | |
1201 | (interactive) | |
1202 | (calc nil t (interactive-p)) | |
1203 | ) | |
1204 | ||
1205 | (defun calc-same-interface (arg) | |
1206 | "Invoke the Calculator using the most recent interface (calc or calc-keypad)." | |
1207 | (interactive "P") | |
1208 | (if (and (equal (buffer-name) "*Gnuplot Trail*") | |
1209 | (> (recursion-depth) 0)) | |
1210 | (exit-recursive-edit) | |
1211 | (if (eq major-mode 'calc-edit-mode) | |
1212 | (calc-edit-finish arg) | |
1213 | (if (eq major-mode 'MacEdit-mode) | |
1214 | (MacEdit-finish-edit) | |
1215 | (if calc-was-keypad-mode | |
1216 | (calc-keypad) | |
1217 | (calc arg calc-full-mode t))))) | |
1218 | ) | |
1219 | ||
1220 | ||
1221 | (defun calc-quit (&optional non-fatal) | |
1222 | (interactive) | |
1223 | (and calc-standalone-flag (not non-fatal) | |
1224 | (save-buffers-kill-emacs nil)) | |
1225 | (if (and (equal (buffer-name) "*Gnuplot Trail*") | |
1226 | (> (recursion-depth) 0)) | |
1227 | (exit-recursive-edit)) | |
1228 | (if (eq major-mode 'calc-edit-mode) | |
1229 | (calc-edit-cancel) | |
1230 | (if (eq major-mode 'MacEdit-mode) | |
1231 | (MacEdit-cancel-edit) | |
1232 | (if (and (interactive-p) | |
1233 | calc-embedded-info | |
1234 | (eq (current-buffer) (aref calc-embedded-info 0))) | |
1235 | (calc-embedded nil) | |
1236 | (or (eq major-mode 'calc-mode) | |
1237 | (calc-create-buffer)) | |
1238 | (run-hooks 'calc-end-hook) | |
1239 | (setq calc-undo-list nil calc-redo-list nil) | |
1240 | (mapcar (function (lambda (v) (set-default v (symbol-value v)))) | |
1241 | calc-local-var-list) | |
1242 | (let ((buf (current-buffer)) | |
1243 | (win (get-buffer-window (current-buffer))) | |
1244 | (kbuf (get-buffer "*Calc Keypad*"))) | |
1245 | (delete-windows-on (calc-trail-buffer)) | |
1246 | (if (and win | |
1247 | (< (window-height win) (1- (screen-height))) | |
1248 | (= (window-width win) (screen-width)) ; avoid calc-keypad | |
1249 | (not (get-buffer-window "*Calc Keypad*"))) | |
1250 | (setq calc-window-height (- (window-height win) 2))) | |
1251 | (if calc-was-split | |
1252 | (calc-delete-windows-keep buf kbuf) | |
1253 | (delete-windows-on buf) | |
1254 | (delete-windows-on kbuf)) | |
1255 | (bury-buffer buf) | |
1256 | (bury-buffer calc-trail-buffer) | |
1257 | (and kbuf (bury-buffer kbuf)))))) | |
1258 | ) | |
1259 | ||
1260 | ;;;###autoload | |
1261 | (defun quick-calc () | |
1262 | "Do a quick calculation in the minibuffer without invoking full Calculator." | |
1263 | (interactive) | |
1264 | (calc-do-quick-calc) | |
1265 | ) | |
1266 | ||
1267 | ;;;###autoload | |
1268 | (defun calc-eval (str &optional separator &rest args) | |
1269 | "Do a quick calculation and return the result as a string. | |
1270 | Return value will either be the formatted result in string form, | |
1271 | or a list containing a character position and an error message in string form." | |
1272 | (calc-do-calc-eval str separator args) | |
1273 | ) | |
1274 | ||
1275 | ;;;###autoload | |
1276 | (defun calc-keypad () | |
1277 | "Invoke the Calculator in \"visual keypad\" mode. | |
1278 | This is most useful in the X window system. | |
1279 | In this mode, click on the Calc \"buttons\" using the left mouse button. | |
1280 | Or, position the cursor manually and do M-x calc-keypad-press." | |
1281 | (interactive) | |
1282 | (calc-extensions) | |
1283 | (calc-do-keypad calc-full-mode (interactive-p)) | |
1284 | ) | |
1285 | ||
1286 | ;;;###autoload | |
1287 | (defun full-calc-keypad () | |
1288 | "Invoke the Calculator in full-screen \"visual keypad\" mode. | |
1289 | See calc-keypad for details." | |
1290 | (interactive) | |
1291 | (calc-extensions) | |
1292 | (calc-do-keypad t (interactive-p)) | |
1293 | ) | |
1294 | ||
1295 | ||
1296 | ;;; Note that modifications to this function may break calc-pass-errors. | |
1297 | (defun calc-do (do-body &optional do-slow) | |
1298 | (calc-check-defines) | |
1299 | (let* ((calc-command-flags nil) | |
1300 | (calc-start-time (and calc-timing (not calc-start-time) | |
1301 | (calc-extensions) | |
1302 | (current-time-string))) | |
1303 | (gc-cons-threshold (max gc-cons-threshold | |
1304 | (if calc-timing 2000000 100000)))) | |
1305 | (setq calc-aborted-prefix "") | |
1306 | (unwind-protect | |
1307 | (condition-case err | |
1308 | (save-excursion | |
1309 | (if calc-embedded-info | |
1310 | (calc-embedded-select-buffer) | |
1311 | (calc-select-buffer)) | |
1312 | (and (eq calc-algebraic-mode 'total) | |
1313 | (calc-extensions) | |
1314 | (use-local-map calc-alg-map)) | |
1315 | (and do-slow calc-display-working-message | |
1316 | (progn | |
1317 | (message "Working...") | |
1318 | (calc-set-command-flag 'clear-message))) | |
1319 | (funcall do-body) | |
1320 | (setq calc-aborted-prefix nil) | |
1321 | (and (memq 'renum-stack calc-command-flags) | |
1322 | (calc-renumber-stack)) | |
1323 | (and (memq 'clear-message calc-command-flags) | |
1324 | (message ""))) | |
1325 | (error | |
1326 | (if (and (eq (car err) 'error) | |
1327 | (stringp (nth 1 err)) | |
1328 | (string-match "max-specpdl-size\\|max-lisp-eval-depth" | |
1329 | (nth 1 err))) | |
1330 | (error "Computation got stuck or ran too long. Type `M' to increase the limit.") | |
1331 | (setq calc-aborted-prefix nil) | |
1332 | (signal (car err) (cdr err))))) | |
1333 | (setq calc-old-aborted-prefix calc-aborted-prefix) | |
1334 | (and calc-aborted-prefix | |
1335 | (calc-record "<Aborted>" calc-aborted-prefix)) | |
1336 | (and calc-start-time | |
1337 | (let* ((calc-internal-prec 12) | |
1338 | (calc-date-format nil) | |
1339 | (end-time (current-time-string)) | |
1340 | (time (if (equal calc-start-time end-time) | |
1341 | 0 | |
1342 | (math-sub | |
1343 | (calcFunc-unixtime (math-parse-date end-time) 0) | |
1344 | (calcFunc-unixtime (math-parse-date calc-start-time) | |
1345 | 0))))) | |
1346 | (if (math-lessp 1 time) | |
1347 | (calc-record time "(t)")))) | |
1348 | (or (memq 'no-align calc-command-flags) | |
1349 | (eq major-mode 'calc-trail-mode) | |
1350 | (calc-align-stack-window)) | |
1351 | (and (memq 'position-point calc-command-flags) | |
1352 | (if (eq major-mode 'calc-mode) | |
1353 | (progn | |
1354 | (goto-line calc-final-point-line) | |
1355 | (move-to-column calc-final-point-column)) | |
1356 | (save-excursion | |
1357 | (calc-select-buffer) | |
1358 | (goto-line calc-final-point-line) | |
1359 | (move-to-column calc-final-point-column)))) | |
1360 | (or (memq 'keep-flags calc-command-flags) | |
1361 | (save-excursion | |
1362 | (calc-select-buffer) | |
1363 | (setq calc-inverse-flag nil | |
1364 | calc-hyperbolic-flag nil | |
1365 | calc-keep-args-flag nil))) | |
1366 | (and (memq 'do-edit calc-command-flags) | |
1367 | (switch-to-buffer (get-buffer-create "*Calc Edit*"))) | |
1368 | (calc-set-mode-line) | |
1369 | (and calc-embedded-info | |
1370 | (calc-embedded-finish-command)))) | |
1371 | (identity nil) ; allow a GC after timing is done | |
1372 | ) | |
1373 | (setq calc-aborted-prefix nil) | |
1374 | (setq calc-start-time nil) | |
1375 | ||
1376 | (defun calc-set-command-flag (f) | |
1377 | (if (not (memq f calc-command-flags)) | |
1378 | (setq calc-command-flags (cons f calc-command-flags))) | |
1379 | ) | |
1380 | ||
1381 | (defun calc-select-buffer () | |
1382 | (or (eq major-mode 'calc-mode) | |
1383 | (if calc-main-buffer | |
1384 | (set-buffer calc-main-buffer) | |
1385 | (let ((buf (get-buffer "*Calculator*"))) | |
1386 | (if buf | |
1387 | (set-buffer buf) | |
1388 | (error "Calculator buffer not available"))))) | |
1389 | ) | |
1390 | ||
1391 | (defun calc-cursor-stack-index (&optional index) | |
1392 | (goto-char (point-max)) | |
1393 | (forward-line (- (calc-substack-height (or index 1)))) | |
1394 | ) | |
1395 | ||
1396 | (defun calc-stack-size () | |
1397 | (- (length calc-stack) calc-stack-top) | |
1398 | ) | |
1399 | ||
1400 | (defun calc-substack-height (n) | |
1401 | (let ((sum 0) | |
1402 | (stack calc-stack)) | |
1403 | (setq n (+ n calc-stack-top)) | |
1404 | (while (and (> n 0) stack) | |
1405 | (setq sum (+ sum (nth 1 (car stack))) | |
1406 | n (1- n) | |
1407 | stack (cdr stack))) | |
1408 | sum) | |
1409 | ) | |
1410 | ||
1411 | (defun calc-set-mode-line () | |
1412 | (save-excursion | |
1413 | (calc-select-buffer) | |
1414 | (let* ((fmt (car calc-float-format)) | |
1415 | (figs (nth 1 calc-float-format)) | |
1416 | (new-mode-string | |
1417 | (format "Calc%s%s: %d %s %-14s" | |
1418 | (if calc-embedded-info "Embed" "") | |
1419 | (if (and (> (length (buffer-name)) 12) | |
1420 | (equal (substring (buffer-name) 0 12) | |
1421 | "*Calculator*")) | |
1422 | (substring (buffer-name) 12) | |
1423 | "") | |
1424 | calc-internal-prec | |
1425 | (capitalize (symbol-name calc-angle-mode)) | |
1426 | (concat | |
1427 | ||
1428 | ;; Input-related modes | |
1429 | (if (eq calc-algebraic-mode 'total) "Alg* " | |
1430 | (if calc-algebraic-mode "Alg " | |
1431 | (if calc-incomplete-algebraic-mode "Alg[( " ""))) | |
1432 | ||
1433 | ;; Computational modes | |
1434 | (if calc-symbolic-mode "Symb " "") | |
1435 | (cond ((eq calc-matrix-mode 'matrix) "Matrix ") | |
1436 | ((integerp calc-matrix-mode) | |
1437 | (format "Matrix%d " calc-matrix-mode)) | |
1438 | ((eq calc-matrix-mode 'scalar) "Scalar ") | |
1439 | (t "")) | |
1440 | (if (eq calc-complex-mode 'polar) "Polar " "") | |
1441 | (if calc-prefer-frac "Frac " "") | |
1442 | (cond ((null calc-infinite-mode) "") | |
1443 | ((eq calc-infinite-mode 1) "+Inf ") | |
1444 | (t "Inf ")) | |
1445 | (cond ((eq calc-simplify-mode 'none) "NoSimp ") | |
1446 | ((eq calc-simplify-mode 'num) "NumSimp ") | |
1447 | ((eq calc-simplify-mode 'binary) | |
1448 | (format "BinSimp%d " calc-word-size)) | |
1449 | ((eq calc-simplify-mode 'alg) "AlgSimp ") | |
1450 | ((eq calc-simplify-mode 'ext) "ExtSimp ") | |
1451 | ((eq calc-simplify-mode 'units) "UnitSimp ") | |
1452 | (t "")) | |
1453 | ||
1454 | ;; Display modes | |
1455 | (cond ((= calc-number-radix 10) "") | |
1456 | ((= calc-number-radix 2) "Bin ") | |
1457 | ((= calc-number-radix 8) "Oct ") | |
1458 | ((= calc-number-radix 16) "Hex ") | |
1459 | (t (format "Radix%d " calc-number-radix))) | |
1460 | (if calc-leading-zeros "Zero " "") | |
1461 | (cond ((null calc-language) "") | |
1462 | ((eq calc-language 'tex) "TeX ") | |
1463 | (t (concat | |
1464 | (capitalize (symbol-name calc-language)) | |
1465 | " "))) | |
1466 | (cond ((eq fmt 'float) | |
1467 | (if (zerop figs) "" (format "Norm%d " figs))) | |
1468 | ((eq fmt 'fix) (format "Fix%d " figs)) | |
1469 | ((eq fmt 'sci) | |
1470 | (if (zerop figs) "Sci " (format "Sci%d " figs))) | |
1471 | ((eq fmt 'eng) | |
1472 | (if (zerop figs) "Eng " (format "Eng%d " figs)))) | |
1473 | (cond ((not calc-display-just) | |
1474 | (if calc-display-origin | |
1475 | (format "Left%d " calc-display-origin) "")) | |
1476 | ((eq calc-display-just 'right) | |
1477 | (if calc-display-origin | |
1478 | (format "Right%d " calc-display-origin) | |
1479 | "Right ")) | |
1480 | (t | |
1481 | (if calc-display-origin | |
1482 | (format "Center%d " calc-display-origin) | |
1483 | "Center "))) | |
1484 | (cond ((integerp calc-line-breaking) | |
1485 | (format "Wid%d " calc-line-breaking)) | |
1486 | (calc-line-breaking "") | |
1487 | (t "Wide ")) | |
1488 | ||
1489 | ;; Miscellaneous other modes/indicators | |
1490 | (if calc-assoc-selections "" "Break ") | |
1491 | (cond ((eq calc-mode-save-mode 'save) "Save ") | |
1492 | ((not calc-embedded-info) "") | |
1493 | ((eq calc-mode-save-mode 'local) "Local ") | |
1494 | ((eq calc-mode-save-mode 'edit) "LocEdit ") | |
1495 | ((eq calc-mode-save-mode 'perm) "LocPerm ") | |
1496 | ((eq calc-mode-save-mode 'global) "Global ") | |
1497 | (t "")) | |
1498 | (if calc-auto-recompute "" "Manual ") | |
1499 | (if (and (fboundp 'calc-gnuplot-alive) | |
1500 | (calc-gnuplot-alive)) "Graph " "") | |
1501 | (if (and calc-embedded-info | |
1502 | (> (calc-stack-size) 0) | |
1503 | (calc-top 1 'sel)) "Sel " "") | |
1504 | (if calc-display-dirty "Dirty " "") | |
1505 | (if calc-inverse-flag "Inv " "") | |
1506 | (if calc-hyperbolic-flag "Hyp " "") | |
1507 | (if calc-keep-args-flag "Keep " "") | |
1508 | (if (/= calc-stack-top 1) "Narrow " "") | |
1509 | (apply 'concat calc-other-modes))))) | |
1510 | (if (equal new-mode-string mode-line-buffer-identification) | |
1511 | nil | |
1512 | (setq mode-line-buffer-identification new-mode-string) | |
1513 | (set-buffer-modified-p (buffer-modified-p)) | |
1514 | (and calc-embedded-info (calc-embedded-mode-line-change))))) | |
1515 | ) | |
1516 | ||
1517 | (defun calc-align-stack-window () | |
1518 | (if (eq major-mode 'calc-mode) | |
1519 | (progn | |
1520 | (let ((win (get-buffer-window (current-buffer)))) | |
1521 | (if win | |
1522 | (progn | |
1523 | (calc-cursor-stack-index 0) | |
1524 | (vertical-motion (- 2 (window-height win))) | |
1525 | (set-window-start win (point))))) | |
1526 | (calc-cursor-stack-index 0) | |
1527 | (if (looking-at " *\\.$") | |
1528 | (goto-char (1- (match-end 0))))) | |
1529 | (save-excursion | |
1530 | (calc-select-buffer) | |
1531 | (calc-align-stack-window))) | |
1532 | ) | |
1533 | ||
1534 | (defun calc-check-stack (n) | |
1535 | (if (> n (calc-stack-size)) | |
1536 | (error "Too few elements on stack")) | |
1537 | (if (< n 0) | |
1538 | (error "Invalid argument")) | |
1539 | ) | |
1540 | ||
1541 | (defun calc-push-list (vals &optional m sels) | |
1542 | (while vals | |
1543 | (if calc-executing-macro | |
1544 | (calc-push-list-in-macro vals m sels) | |
1545 | (save-excursion | |
1546 | (calc-select-buffer) | |
1547 | (let* ((val (car vals)) | |
1548 | (entry (list val 1 (car sels))) | |
1549 | (mm (+ (or m 1) calc-stack-top))) | |
1550 | (calc-cursor-stack-index (1- (or m 1))) | |
1551 | (if (> mm 1) | |
1552 | (setcdr (nthcdr (- mm 2) calc-stack) | |
1553 | (cons entry (nthcdr (1- mm) calc-stack))) | |
1554 | (setq calc-stack (cons entry calc-stack))) | |
1555 | (let ((buffer-read-only nil)) | |
1556 | (insert (math-format-stack-value entry) "\n")) | |
1557 | (calc-record-undo (list 'push mm)) | |
1558 | (calc-set-command-flag 'renum-stack)))) | |
1559 | (setq vals (cdr vals) | |
1560 | sels (cdr sels))) | |
1561 | ) | |
1562 | ||
1563 | (defun calc-pop-push-list (n vals &optional m sels) | |
1564 | (if (and calc-any-selections (null sels)) | |
1565 | (calc-replace-selections n vals m) | |
1566 | (calc-pop-stack n m sels) | |
1567 | (calc-push-list vals m sels)) | |
1568 | ) | |
1569 | ||
1570 | (defun calc-pop-push-record-list (n prefix vals &optional m sels) | |
1571 | (or (and (consp vals) | |
1572 | (or (integerp (car vals)) | |
1573 | (consp (car vals)))) | |
1574 | (and vals (setq vals (list vals) | |
1575 | sels (and sels (list sels))))) | |
1576 | (calc-check-stack (+ n (or m 1) -1)) | |
1577 | (if prefix | |
1578 | (if (cdr vals) | |
1579 | (calc-record-list vals prefix) | |
1580 | (calc-record (car vals) prefix))) | |
1581 | (calc-pop-push-list n vals m sels) | |
1582 | ) | |
1583 | ||
1584 | (defun calc-enter-result (n prefix vals &optional m) | |
1585 | (setq calc-aborted-prefix prefix) | |
1586 | (if (and (consp vals) | |
1587 | (or (integerp (car vals)) | |
1588 | (consp (car vals)))) | |
1589 | (setq vals (mapcar 'calc-normalize vals)) | |
1590 | (setq vals (calc-normalize vals))) | |
1591 | (or (and (consp vals) | |
1592 | (or (integerp (car vals)) | |
1593 | (consp (car vals)))) | |
1594 | (setq vals (list vals))) | |
1595 | (if (equal vals '((nil))) | |
1596 | (setq vals nil)) | |
1597 | (calc-pop-push-record-list n prefix vals m) | |
1598 | (calc-handle-whys) | |
1599 | ) | |
1600 | ||
1601 | (defun calc-normalize (val) | |
1602 | (if (memq calc-simplify-mode '(nil none num)) | |
1603 | (math-normalize val) | |
1604 | (calc-extensions) | |
1605 | (calc-normalize-fancy val)) | |
1606 | ) | |
1607 | ||
1608 | (defun calc-handle-whys () | |
1609 | (if calc-next-why | |
1610 | (calc-do-handle-whys)) | |
1611 | ) | |
1612 | ||
1613 | ||
1614 | (defun calc-pop-stack (&optional n m sel-ok) ; pop N objs at level M of stack. | |
1615 | (or n (setq n 1)) | |
1616 | (or m (setq m 1)) | |
1617 | (or calc-keep-args-flag | |
1618 | (let ((mm (+ m calc-stack-top))) | |
1619 | (if (and calc-any-selections (not sel-ok) | |
1620 | (calc-top-selected n m)) | |
1621 | (calc-sel-error)) | |
1622 | (if calc-executing-macro | |
1623 | (calc-pop-stack-in-macro n mm) | |
1624 | (calc-record-undo (list 'pop mm (calc-top-list n m 'full))) | |
1625 | (save-excursion | |
1626 | (calc-select-buffer) | |
1627 | (let ((buffer-read-only nil)) | |
1628 | (if (> mm 1) | |
1629 | (progn | |
1630 | (calc-cursor-stack-index (1- m)) | |
1631 | (let ((bot (point))) | |
1632 | (calc-cursor-stack-index (+ n m -1)) | |
1633 | (delete-region (point) bot)) | |
1634 | (setcdr (nthcdr (- mm 2) calc-stack) | |
1635 | (nthcdr (+ n mm -1) calc-stack))) | |
1636 | (calc-cursor-stack-index n) | |
1637 | (setq calc-stack (nthcdr n calc-stack)) | |
1638 | (delete-region (point) (point-max)))) | |
1639 | (calc-set-command-flag 'renum-stack))))) | |
1640 | ) | |
1641 | ||
1642 | (defun calc-get-stack-element (x) | |
1643 | (cond ((eq sel-mode 'entry) | |
1644 | x) | |
1645 | ((eq sel-mode 'sel) | |
1646 | (nth 2 x)) | |
1647 | ((or (null (nth 2 x)) | |
1648 | (eq sel-mode 'full) | |
1649 | (not calc-use-selections)) | |
1650 | (car x)) | |
1651 | (sel-mode | |
1652 | (calc-sel-error)) | |
1653 | (t (nth 2 x))) | |
1654 | ) | |
1655 | ||
1656 | ;; Get the Nth element of the stack (N=1 is the top element). | |
1657 | (defun calc-top (&optional n sel-mode) | |
1658 | (or n (setq n 1)) | |
1659 | (calc-check-stack n) | |
1660 | (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack)) | |
1661 | ) | |
1662 | ||
1663 | (defun calc-top-n (&optional n sel-mode) ; in case precision has changed | |
1664 | (math-check-complete (calc-normalize (calc-top n sel-mode))) | |
1665 | ) | |
1666 | ||
1667 | (defun calc-top-list (&optional n m sel-mode) | |
1668 | (or n (setq n 1)) | |
1669 | (or m (setq m 1)) | |
1670 | (calc-check-stack (+ n m -1)) | |
1671 | (and (> n 0) | |
1672 | (let ((top (copy-sequence (nthcdr (+ m calc-stack-top -1) | |
1673 | calc-stack)))) | |
1674 | (setcdr (nthcdr (1- n) top) nil) | |
1675 | (nreverse (mapcar 'calc-get-stack-element top)))) | |
1676 | ) | |
1677 | ||
1678 | (defun calc-top-list-n (&optional n m sel-mode) | |
1679 | (mapcar 'math-check-complete | |
1680 | (mapcar 'calc-normalize (calc-top-list n m sel-mode))) | |
1681 | ) | |
1682 | ||
1683 | ||
1684 | (defun calc-renumber-stack () | |
1685 | (if calc-line-numbering | |
1686 | (save-excursion | |
1687 | (calc-cursor-stack-index 0) | |
1688 | (let ((lnum 1) | |
1689 | (buffer-read-only nil) | |
1690 | (stack (nthcdr calc-stack-top calc-stack))) | |
1691 | (if (re-search-forward "^[0-9]+[:*]" nil t) | |
1692 | (progn | |
1693 | (beginning-of-line) | |
1694 | (while (re-search-forward "^[0-9]+[:*]" nil t) | |
1695 | (let ((buffer-read-only nil)) | |
1696 | (beginning-of-line) | |
1697 | (delete-char 4) | |
1698 | (insert " "))) | |
1699 | (calc-cursor-stack-index 0))) | |
1700 | (while (re-search-backward "^[0-9]+[:*]" nil t) | |
1701 | (delete-char 4) | |
1702 | (if (> lnum 999) | |
1703 | (insert (format "%03d%s" (% lnum 1000) | |
1704 | (if (and (nth 2 (car stack)) | |
1705 | calc-use-selections) "*" ":"))) | |
1706 | (let ((prefix (int-to-string lnum))) | |
1707 | (insert prefix (if (and (nth 2 (car stack)) | |
1708 | calc-use-selections) "*" ":") | |
1709 | (make-string (- 3 (length prefix)) 32)))) | |
1710 | (beginning-of-line) | |
1711 | (setq lnum (1+ lnum) | |
1712 | stack (cdr stack)))))) | |
1713 | (and calc-embedded-info (calc-embedded-stack-change)) | |
1714 | ) | |
1715 | ||
1716 | (defun calc-refresh (&optional align) | |
1717 | (interactive) | |
1718 | (and (eq major-mode 'calc-mode) | |
1719 | (not calc-executing-macro) | |
1720 | (let* ((buffer-read-only nil) | |
1721 | (save-point (point)) | |
1722 | (save-mark (condition-case err (mark) (error nil))) | |
1723 | (save-aligned (looking-at "\\.$")) | |
1724 | (thing calc-stack)) | |
1725 | (setq calc-any-selections nil | |
1726 | calc-any-evaltos nil) | |
1727 | (erase-buffer) | |
1728 | (insert "--- Emacs Calculator Mode ---\n") | |
1729 | (while thing | |
1730 | (goto-char (point-min)) | |
1731 | (forward-line 1) | |
1732 | (insert (math-format-stack-value (car thing)) "\n") | |
1733 | (setq thing (cdr thing))) | |
1734 | (calc-renumber-stack) | |
1735 | (if calc-display-dirty | |
1736 | (calc-wrapper (setq calc-display-dirty nil))) | |
1737 | (and calc-any-evaltos calc-auto-recompute | |
1738 | (calc-wrapper (calc-refresh-evaltos))) | |
1739 | (if (or align save-aligned) | |
1740 | (calc-align-stack-window) | |
1741 | (goto-char save-point)) | |
1742 | (if save-mark (set-mark save-mark)))) | |
1743 | (and calc-embedded-info (not (eq major-mode 'calc-mode)) | |
1744 | (save-excursion | |
1745 | (set-buffer (aref calc-embedded-info 1)) | |
1746 | (calc-refresh align))) | |
1747 | (setq calc-refresh-count (1+ calc-refresh-count)) | |
1748 | ) | |
1749 | ||
1750 | ||
1751 | (defun calc-x-paste-text (arg) | |
1752 | "Move point to mouse position and insert window system cut buffer contents. | |
1753 | If mouse is pressed in Calc window, push cut buffer contents onto the stack." | |
1754 | (x-mouse-select arg) | |
1755 | (if (memq major-mode '(calc-mode calc-trail-mode)) | |
1756 | (progn | |
1757 | (calc-wrapper | |
1758 | (calc-extensions) | |
1759 | (let* ((buf (x-get-cut-buffer)) | |
1760 | (val (math-read-exprs (calc-clean-newlines buf)))) | |
1761 | (if (eq (car-safe val) 'error) | |
1762 | (progn | |
1763 | (setq val (math-read-exprs buf)) | |
1764 | (if (eq (car-safe val) 'error) | |
1765 | (error "%s in yanked data" (nth 2 val))))) | |
1766 | (calc-enter-result 0 "Xynk" val)))) | |
1767 | (x-paste-text arg)) | |
1768 | ) | |
1769 | ||
1770 | ||
1771 | ||
1772 | ;;;; The Calc Trail buffer. | |
1773 | ||
1774 | (defun calc-check-trail-aligned () | |
1775 | (save-excursion | |
1776 | (let ((win (get-buffer-window (current-buffer)))) | |
1777 | (and win | |
1778 | (pos-visible-in-window-p (1- (point-max)) win)))) | |
1779 | ) | |
1780 | ||
1781 | (defun calc-trail-buffer () | |
1782 | (and (or (null calc-trail-buffer) | |
1783 | (null (buffer-name calc-trail-buffer))) | |
1784 | (save-excursion | |
1785 | (setq calc-trail-buffer (get-buffer-create "*Calc Trail*")) | |
1786 | (let ((buf (or (and (not (eq major-mode 'calc-mode)) | |
1787 | (get-buffer "*Calculator*")) | |
1788 | (current-buffer)))) | |
1789 | (set-buffer calc-trail-buffer) | |
1790 | (or (eq major-mode 'calc-trail-mode) | |
1791 | (calc-trail-mode buf))))) | |
1792 | (or (and calc-trail-pointer | |
1793 | (eq (marker-buffer calc-trail-pointer) calc-trail-buffer)) | |
1794 | (save-excursion | |
1795 | (set-buffer calc-trail-buffer) | |
1796 | (goto-line 2) | |
1797 | (setq calc-trail-pointer (point-marker)))) | |
1798 | calc-trail-buffer | |
1799 | ) | |
1800 | ||
1801 | (defun calc-record (val &optional prefix) | |
1802 | (setq calc-aborted-prefix nil) | |
1803 | (or calc-executing-macro | |
1804 | (let* ((mainbuf (current-buffer)) | |
1805 | (buf (calc-trail-buffer)) | |
1806 | (calc-display-raw nil) | |
1807 | (calc-can-abbrev-vectors t) | |
1808 | (fval (if val | |
1809 | (if (stringp val) | |
1810 | val | |
1811 | (math-showing-full-precision | |
1812 | (math-format-flat-expr val 0))) | |
1813 | ""))) | |
1814 | (save-excursion | |
1815 | (set-buffer buf) | |
1816 | (let ((aligned (calc-check-trail-aligned)) | |
1817 | (buffer-read-only nil)) | |
1818 | (goto-char (point-max)) | |
1819 | (cond ((null prefix) (insert " ")) | |
1820 | ((and (> (length prefix) 4) | |
1821 | (string-match " " prefix 4)) | |
1822 | (insert (substring prefix 0 4) " ")) | |
1823 | (t (insert (format "%4s " prefix)))) | |
1824 | (insert fval "\n") | |
1825 | (let ((win (get-buffer-window buf))) | |
1826 | (if (and aligned win (not (memq 'hold-trail calc-command-flags))) | |
1827 | (calc-trail-here)) | |
1828 | (goto-char (1- (point-max)))))))) | |
1829 | val | |
1830 | ) | |
1831 | ||
1832 | ||
1833 | (defun calc-trail-display (flag &optional no-refresh) | |
1834 | (interactive "P") | |
1835 | (let ((win (get-buffer-window (calc-trail-buffer)))) | |
1836 | (if (setq calc-display-trail | |
1837 | (not (if flag (memq flag '(nil 0)) win))) | |
1838 | (if (null win) | |
1839 | (progn | |
1840 | (if (and (boundp 'calc-trail-window-hook) calc-trail-window-hook) | |
1841 | (run-hooks 'calc-trail-window-hook) | |
1842 | (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) | |
1843 | (set-window-buffer w calc-trail-buffer))) | |
1844 | (calc-wrapper | |
1845 | (setq overlay-arrow-string calc-trail-overlay | |
1846 | overlay-arrow-position calc-trail-pointer) | |
1847 | (or no-refresh | |
1848 | (if (interactive-p) | |
1849 | (calc-do-refresh) | |
1850 | (calc-refresh)))))) | |
1851 | (if win | |
1852 | (progn | |
1853 | (delete-window win) | |
1854 | (calc-wrapper | |
1855 | (or no-refresh | |
1856 | (if (interactive-p) | |
1857 | (calc-do-refresh) | |
1858 | (calc-refresh)))))))) | |
1859 | calc-trail-buffer | |
1860 | ) | |
1861 | ||
1862 | (defun calc-trail-here () | |
1863 | (interactive) | |
1864 | (if (eq major-mode 'calc-trail-mode) | |
1865 | (progn | |
1866 | (beginning-of-line) | |
1867 | (if (bobp) | |
1868 | (forward-line 1) | |
1869 | (if (eobp) | |
1870 | (forward-line -1))) | |
1871 | (if (or (bobp) (eobp)) | |
1872 | (setq overlay-arrow-position nil) ; trail is empty | |
1873 | (set-marker calc-trail-pointer (point) (current-buffer)) | |
1874 | (setq calc-trail-overlay (concat (buffer-substring (point) | |
1875 | (+ (point) 4)) | |
1876 | ">") | |
1877 | overlay-arrow-string calc-trail-overlay | |
1878 | overlay-arrow-position calc-trail-pointer) | |
1879 | (forward-char 4) | |
1880 | (let ((win (get-buffer-window (current-buffer)))) | |
1881 | (if win | |
1882 | (save-excursion | |
1883 | (forward-line (/ (window-height win) 2)) | |
1884 | (forward-line (- 1 (window-height win))) | |
1885 | (set-window-start win (point)) | |
1886 | (set-window-point win (+ calc-trail-pointer 4)) | |
1887 | (set-buffer calc-main-buffer) | |
1888 | (setq overlay-arrow-string calc-trail-overlay | |
1889 | overlay-arrow-position calc-trail-pointer)))))) | |
1890 | (error "Not in Calc Trail buffer")) | |
1891 | ) | |
1892 | ||
1893 | ||
1894 | ||
1895 | ||
1896 | ;;;; The Undo list. | |
1897 | ||
1898 | (defun calc-record-undo (rec) | |
1899 | (or calc-executing-macro | |
1900 | (if (memq 'undo calc-command-flags) | |
1901 | (setq calc-undo-list (cons (cons rec (car calc-undo-list)) | |
1902 | (cdr calc-undo-list))) | |
1903 | (setq calc-undo-list (cons (list rec) calc-undo-list) | |
1904 | calc-redo-list nil) | |
1905 | (calc-set-command-flag 'undo))) | |
1906 | ) | |
1907 | ||
1908 | ||
1909 | ||
1910 | ||
1911 | ;;; Arithmetic commands. | |
1912 | ||
1913 | (defun calc-binary-op (name func arg &optional ident unary func2) | |
1914 | (setq calc-aborted-prefix name) | |
1915 | (if (null arg) | |
1916 | (calc-enter-result 2 name (cons (or func2 func) | |
1917 | (mapcar 'math-check-complete | |
1918 | (calc-top-list 2)))) | |
1919 | (calc-extensions) | |
1920 | (calc-binary-op-fancy name func arg ident unary)) | |
1921 | ) | |
1922 | ||
1923 | (defun calc-unary-op (name func arg &optional func2) | |
1924 | (setq calc-aborted-prefix name) | |
1925 | (if (null arg) | |
1926 | (calc-enter-result 1 name (list (or func2 func) | |
1927 | (math-check-complete (calc-top 1)))) | |
1928 | (calc-extensions) | |
1929 | (calc-unary-op-fancy name func arg)) | |
1930 | ) | |
1931 | ||
1932 | ||
1933 | (defun calc-plus (arg) | |
1934 | (interactive "P") | |
1935 | (calc-slow-wrapper | |
1936 | (calc-binary-op "+" 'calcFunc-add arg 0 nil '+)) | |
1937 | ) | |
1938 | ||
1939 | (defun calc-minus (arg) | |
1940 | (interactive "P") | |
1941 | (calc-slow-wrapper | |
1942 | (calc-binary-op "-" 'calcFunc-sub arg 0 'neg '-)) | |
1943 | ) | |
1944 | ||
1945 | (defun calc-times (arg) | |
1946 | (interactive "P") | |
1947 | (calc-slow-wrapper | |
1948 | (calc-binary-op "*" 'calcFunc-mul arg 1 nil '*)) | |
1949 | ) | |
1950 | ||
1951 | (defun calc-divide (arg) | |
1952 | (interactive "P") | |
1953 | (calc-slow-wrapper | |
1954 | (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv '/)) | |
1955 | ) | |
1956 | ||
1957 | ||
1958 | (defun calc-change-sign (arg) | |
1959 | (interactive "P") | |
1960 | (calc-wrapper | |
1961 | (calc-unary-op "chs" 'neg arg)) | |
1962 | ) | |
1963 | ||
1964 | ||
1965 | ||
1966 | ;;; Stack management commands. | |
1967 | ||
1968 | (defun calc-enter (n) | |
1969 | (interactive "p") | |
1970 | (calc-wrapper | |
1971 | (cond ((< n 0) | |
1972 | (calc-push-list (calc-top-list 1 (- n)))) | |
1973 | ((= n 0) | |
1974 | (calc-push-list (calc-top-list (calc-stack-size)))) | |
1975 | (t | |
1976 | (calc-push-list (calc-top-list n))))) | |
1977 | ) | |
1978 | ||
1979 | ||
1980 | (defun calc-pop (n) | |
1981 | (interactive "P") | |
1982 | (calc-wrapper | |
1983 | (let* ((nn (prefix-numeric-value n)) | |
1984 | (top (and (null n) (calc-top 1)))) | |
1985 | (cond ((and (null n) | |
1986 | (eq (car-safe top) 'incomplete) | |
1987 | (> (length top) (if (eq (nth 1 top) 'intv) 3 2))) | |
1988 | (calc-pop-push-list 1 (let ((tt (copy-sequence top))) | |
1989 | (setcdr (nthcdr (- (length tt) 2) tt) nil) | |
1990 | (list tt)))) | |
1991 | ((< nn 0) | |
1992 | (if (and calc-any-selections | |
1993 | (calc-top-selected 1 (- nn))) | |
1994 | (calc-delete-selection (- nn)) | |
1995 | (calc-pop-stack 1 (- nn) t))) | |
1996 | ((= nn 0) | |
1997 | (calc-pop-stack (calc-stack-size) 1 t)) | |
1998 | (t | |
1999 | (if (and calc-any-selections | |
2000 | (= nn 1) | |
2001 | (calc-top-selected 1 1)) | |
2002 | (calc-delete-selection 1) | |
2003 | (calc-pop-stack nn)))))) | |
2004 | ) | |
2005 | ||
2006 | ||
2007 | ||
2008 | ||
2009 | ;;;; Reading a number using the minibuffer. | |
2010 | ||
2011 | (defun calcDigit-start () | |
2012 | (interactive) | |
2013 | (calc-wrapper | |
2014 | (if (or calc-algebraic-mode | |
2015 | (and (> calc-number-radix 14) (eq last-command-char ?e))) | |
2016 | (calc-alg-digit-entry) | |
2017 | (calc-unread-command) | |
2018 | (setq calc-aborted-prefix nil) | |
2019 | (let* ((calc-digit-value nil) | |
2020 | (calc-prev-char nil) | |
2021 | (calc-prev-prev-char nil) | |
2022 | (calc-buffer (current-buffer)) | |
2023 | (buf (if calc-emacs-type-lucid | |
2024 | (catch 'calc-foo | |
2025 | (catch 'execute-kbd-macro | |
2026 | (throw 'calc-foo | |
2027 | (read-from-minibuffer | |
2028 | "Calc: " "" calc-digit-map))) | |
2029 | (error "Lucid Emacs requires RET after %s" | |
2030 | "digit entry in kbd macro")) | |
2031 | (let ((old-esc (lookup-key global-map "\e"))) | |
2032 | (unwind-protect | |
2033 | (progn | |
2034 | (define-key global-map "\e" nil) | |
2035 | (read-from-minibuffer "Calc: " "" calc-digit-map)) | |
2036 | (define-key global-map "\e" old-esc)))))) | |
2037 | (or calc-digit-value (setq calc-digit-value (math-read-number buf))) | |
2038 | (if (stringp calc-digit-value) | |
2039 | (calc-alg-entry calc-digit-value) | |
2040 | (if calc-digit-value | |
2041 | (calc-push-list (list (calc-record (calc-normalize | |
2042 | calc-digit-value)))))) | |
2043 | (if (eq calc-prev-char 'dots) | |
2044 | (progn | |
2045 | (calc-extensions) | |
2046 | (calc-dots)))))) | |
2047 | ) | |
2048 | ||
2049 | (defun calcDigit-nondigit () | |
2050 | (interactive) | |
2051 | ;; Exercise for the reader: Figure out why this is a good precaution! | |
2052 | (or (boundp 'calc-buffer) | |
2053 | (use-local-map minibuffer-local-map)) | |
2054 | (let ((str (buffer-string))) | |
2055 | (setq calc-digit-value (save-excursion | |
2056 | (set-buffer calc-buffer) | |
2057 | (math-read-number str)))) | |
2058 | (if (and (null calc-digit-value) (> (buffer-size) 0)) | |
2059 | (progn | |
2060 | (beep) | |
2061 | (calc-temp-minibuffer-message " [Bad format]")) | |
2062 | (or (memq last-command-char '(32 13)) | |
2063 | (progn (setq prefix-arg current-prefix-arg) | |
2064 | (calc-unread-command (if (and (eq last-command-char 27) | |
2065 | (>= last-input-char 128)) | |
2066 | last-input-char | |
2067 | nil)))) | |
2068 | (exit-minibuffer)) | |
2069 | ) | |
2070 | ||
2071 | ||
2072 | (defun calc-minibuffer-contains (rex) | |
2073 | (save-excursion | |
2074 | (goto-char (point-min)) | |
2075 | (looking-at rex)) | |
2076 | ) | |
2077 | ||
2078 | (defun calcDigit-key () | |
2079 | (interactive) | |
2080 | (goto-char (point-max)) | |
2081 | (if (or (and (memq last-command-char '(?+ ?-)) | |
2082 | (> (buffer-size) 0) | |
2083 | (/= (preceding-char) ?e)) | |
2084 | (and (memq last-command-char '(?m ?s)) | |
2085 | (not (calc-minibuffer-contains "[-+]?[0-9]+\\.?0*[@oh].*")) | |
2086 | (not (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")))) | |
2087 | (calcDigit-nondigit) | |
2088 | (if (calc-minibuffer-contains "\\([-+]?\\|.* \\)\\'") | |
2089 | (cond ((memq last-command-char '(?. ?@)) (insert "0")) | |
2090 | ((and (memq last-command-char '(?o ?h ?m)) | |
2091 | (not (calc-minibuffer-contains ".*#.*"))) (insert "0")) | |
2092 | ((memq last-command-char '(?: ?e)) (insert "1")) | |
2093 | ((eq last-command-char ?#) | |
2094 | (insert (int-to-string calc-number-radix))))) | |
2095 | (if (and (calc-minibuffer-contains "\\([-+]?[0-9]+#\\|[^:]*:\\)\\'") | |
2096 | (eq last-command-char ?:)) | |
2097 | (insert "1")) | |
2098 | (if (and (calc-minibuffer-contains "[-+]?[0-9]+#\\'") | |
2099 | (eq last-command-char ?.)) | |
2100 | (insert "0")) | |
2101 | (if (and (calc-minibuffer-contains "[-+]?0*\\([2-9]\\|1[0-4]\\)#\\'") | |
2102 | (eq last-command-char ?e)) | |
2103 | (insert "1")) | |
2104 | (if (or (and (memq last-command-char '(?h ?o ?m ?s ?p)) | |
2105 | (calc-minibuffer-contains ".*#.*")) | |
2106 | (and (eq last-command-char ?e) | |
2107 | (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*")) | |
2108 | (and (eq last-command-char ?n) | |
2109 | (calc-minibuffer-contains "[-+]?\\(2[4-9]\\|[3-9][0-9]\\)#.*"))) | |
2110 | (setq last-command-char (upcase last-command-char))) | |
2111 | (cond | |
2112 | ((memq last-command-char '(?_ ?n)) | |
2113 | (goto-char (point-min)) | |
2114 | (if (and (search-forward " +/- " nil t) | |
2115 | (not (search-forward "e" nil t))) | |
2116 | (beep) | |
2117 | (and (not (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*")) | |
2118 | (search-forward "e" nil t)) | |
2119 | (if (looking-at "+") | |
2120 | (delete-char 1)) | |
2121 | (if (looking-at "-") | |
2122 | (delete-char 1) | |
2123 | (insert "-"))) | |
2124 | (goto-char (point-max))) | |
2125 | ((eq last-command-char ?p) | |
2126 | (if (or (calc-minibuffer-contains ".*\\+/-.*") | |
2127 | (calc-minibuffer-contains ".*mod.*") | |
2128 | (calc-minibuffer-contains ".*#.*") | |
2129 | (calc-minibuffer-contains ".*[-+e:]\\'")) | |
2130 | (beep) | |
2131 | (if (not (calc-minibuffer-contains ".* \\'")) | |
2132 | (insert " ")) | |
2133 | (insert "+/- "))) | |
2134 | ((and (eq last-command-char ?M) | |
2135 | (not (calc-minibuffer-contains | |
2136 | "[-+]?\\(2[3-9]\\|[3-9][0-9]\\)#.*"))) | |
2137 | (if (or (calc-minibuffer-contains ".*\\+/-.*") | |
2138 | (calc-minibuffer-contains ".*mod *[^ ]+") | |
2139 | (calc-minibuffer-contains ".*[-+e:]\\'")) | |
2140 | (beep) | |
2141 | (if (calc-minibuffer-contains ".*mod \\'") | |
2142 | (if calc-previous-modulo | |
2143 | (insert (math-format-flat-expr calc-previous-modulo 0)) | |
2144 | (beep)) | |
2145 | (if (not (calc-minibuffer-contains ".* \\'")) | |
2146 | (insert " ")) | |
2147 | (insert "mod ")))) | |
2148 | (t | |
2149 | (insert (char-to-string last-command-char)) | |
2150 | (if (or (and (calc-minibuffer-contains "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9][0-9]?\\)#[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\)?\\|.[0-9a-zA-Z]*\\(e[-+]?[0-9]*\\)?\\)?\\'") | |
2151 | (let ((radix (string-to-int | |
2152 | (buffer-substring | |
2153 | (match-beginning 2) (match-end 2))))) | |
2154 | (and (>= radix 2) | |
2155 | (<= radix 36) | |
2156 | (or (memq last-command-char '(?# ?: ?. ?e ?+ ?-)) | |
2157 | (let ((dig (math-read-radix-digit | |
2158 | (upcase last-command-char)))) | |
2159 | (and dig | |
2160 | (< dig radix))))))) | |
2161 | (save-excursion | |
2162 | (goto-char (point-min)) | |
2163 | (looking-at | |
2164 | "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9]+\\.?0*[@oh] *\\)?\\([0-9]+\\.?0*['m] *\\)?[0-9]*\\(\\.?[0-9]*\\(e[-+]?[0-3]?[0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[0-9]?\\)?\\|[0-9]:\\([0-9]+:\\)?[0-9]*\\)?[\"s]?\\'"))) | |
2165 | (if (and (memq last-command-char '(?@ ?o ?h ?\' ?m)) | |
2166 | (string-match " " calc-hms-format)) | |
2167 | (insert " ")) | |
2168 | (if (and (eq this-command last-command) | |
2169 | (eq last-command-char ?.)) | |
2170 | (progn | |
2171 | (calc-extensions) | |
2172 | (calc-digit-dots)) | |
2173 | (delete-backward-char 1) | |
2174 | (beep) | |
2175 | (calc-temp-minibuffer-message " [Bad format]")))))) | |
2176 | (setq calc-prev-prev-char calc-prev-char | |
2177 | calc-prev-char last-command-char) | |
2178 | ) | |
2179 | ||
2180 | ||
2181 | (defun calcDigit-backspace () | |
2182 | (interactive) | |
2183 | (goto-char (point-max)) | |
2184 | (cond ((calc-minibuffer-contains ".* \\+/- \\'") | |
2185 | (backward-delete-char 5)) | |
2186 | ((calc-minibuffer-contains ".* mod \\'") | |
2187 | (backward-delete-char 5)) | |
2188 | ((calc-minibuffer-contains ".* \\'") | |
2189 | (backward-delete-char 2)) | |
2190 | ((eq last-command 'calcDigit-start) | |
2191 | (erase-buffer)) | |
2192 | (t (backward-delete-char 1))) | |
2193 | (if (= (buffer-size) 0) | |
2194 | (progn | |
2195 | (setq last-command-char 13) | |
2196 | (calcDigit-nondigit))) | |
2197 | ) | |
2198 | ||
2199 | ||
2200 | ||
2201 | ||
2202 | ||
2203 | ||
2204 | ||
2205 | ;;;; Arithmetic routines. | |
2206 | ;;; | |
2207 | ;;; An object as manipulated by one of these routines may take any of the | |
2208 | ;;; following forms: | |
2209 | ;;; | |
2210 | ;;; integer An integer. For normalized numbers, this format | |
2211 | ;;; is used only for -999999 ... 999999. | |
2212 | ;;; | |
2213 | ;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ... | |
2214 | ;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ... | |
2215 | ;;; Each digit N is in the range 0 ... 999. | |
2216 | ;;; Normalized, always at least three N present, | |
2217 | ;;; and the most significant N is nonzero. | |
2218 | ;;; | |
2219 | ;;; (frac NUM DEN) A fraction. NUM and DEN are small or big integers. | |
2220 | ;;; Normalized, DEN > 1. | |
2221 | ;;; | |
2222 | ;;; (float NUM EXP) A floating-point number, NUM * 10^EXP; | |
2223 | ;;; NUM is a small or big integer, EXP is a small int. | |
2224 | ;;; Normalized, NUM is not a multiple of 10, and | |
2225 | ;;; abs(NUM) < 10^calc-internal-prec. | |
2226 | ;;; Normalized zero is stored as (float 0 0). | |
2227 | ;;; | |
2228 | ;;; (cplx REAL IMAG) A complex number; REAL and IMAG are any of above. | |
2229 | ;;; Normalized, IMAG is nonzero. | |
2230 | ;;; | |
2231 | ;;; (polar R THETA) Polar complex number. Normalized, R > 0 and THETA | |
2232 | ;;; is neither zero nor 180 degrees (pi radians). | |
2233 | ;;; | |
2234 | ;;; (vec A B C ...) Vector of objects A, B, C, ... A matrix is a | |
2235 | ;;; vector of vectors. | |
2236 | ;;; | |
2237 | ;;; (hms H M S) Angle in hours-minutes-seconds form. All three | |
2238 | ;;; components have the same sign; H and M must be | |
2239 | ;;; numerically integers; M and S are expected to | |
2240 | ;;; lie in the range [0,60). | |
2241 | ;;; | |
2242 | ;;; (date N) A date or date/time object. N is an integer to | |
2243 | ;;; store a date only, or a fraction or float to | |
2244 | ;;; store a date and time. | |
2245 | ;;; | |
2246 | ;;; (sdev X SIGMA) Error form, X +/- SIGMA. When normalized, | |
2247 | ;;; SIGMA > 0. X is any complex number and SIGMA | |
2248 | ;;; is real numbers; or these may be symbolic | |
2249 | ;;; expressions where SIGMA is assumed real. | |
2250 | ;;; | |
2251 | ;;; (intv MASK LO HI) Interval form. MASK is 0=(), 1=(], 2=[), or 3=[]. | |
2252 | ;;; LO and HI are any real numbers, or symbolic | |
2253 | ;;; expressions which are assumed real, and LO < HI. | |
2254 | ;;; For [LO..HI], if LO = HI normalization produces LO, | |
2255 | ;;; and if LO > HI normalization produces [LO..LO). | |
2256 | ;;; For other intervals, if LO > HI normalization | |
2257 | ;;; sets HI equal to LO. | |
2258 | ;;; | |
2259 | ;;; (mod N M) Number modulo M. When normalized, 0 <= N < M. | |
2260 | ;;; N and M are real numbers. | |
2261 | ;;; | |
2262 | ;;; (var V S) Symbolic variable. V is a Lisp symbol which | |
2263 | ;;; represents the variable's visible name. S is | |
2264 | ;;; the symbol which actually stores the variable's | |
2265 | ;;; value: (var pi var-pi). | |
2266 | ;;; | |
2267 | ;;; In general, combining rational numbers in a calculation always produces | |
2268 | ;;; a rational result, but if either argument is a float, result is a float. | |
2269 | ||
2270 | ;;; In the following comments, [x y z] means result is x, args must be y, z, | |
2271 | ;;; respectively, where the code letters are: | |
2272 | ;;; | |
2273 | ;;; O Normalized object (vector or number) | |
2274 | ;;; V Normalized vector | |
2275 | ;;; N Normalized number of any type | |
2276 | ;;; N Normalized complex number | |
2277 | ;;; R Normalized real number (float or rational) | |
2278 | ;;; F Normalized floating-point number | |
2279 | ;;; T Normalized rational number | |
2280 | ;;; I Normalized integer | |
2281 | ;;; B Normalized big integer | |
2282 | ;;; S Normalized small integer | |
2283 | ;;; D Digit (small integer, 0..999) | |
2284 | ;;; L Normalized bignum digit list (without "bigpos" or "bigneg" symbol) | |
2285 | ;;; or normalized vector element list (without "vec") | |
2286 | ;;; P Predicate (truth value) | |
2287 | ;;; X Any Lisp object | |
2288 | ;;; Z "nil" | |
2289 | ;;; | |
2290 | ;;; Lower-case letters signify possibly un-normalized values. | |
2291 | ;;; "L.D" means a cons of an L and a D. | |
2292 | ;;; [N N; n n] means result will be normalized if argument is. | |
2293 | ;;; Also, [Public] marks routines intended to be called from outside. | |
2294 | ;;; [This notation has been neglected in many recent routines.] | |
2295 | ||
2296 | ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] | |
2297 | (defun math-normalize (a) | |
2298 | (cond | |
2299 | ((not (consp a)) | |
2300 | (if (integerp a) | |
2301 | (if (or (>= a 1000000) (<= a -1000000)) | |
2302 | (math-bignum a) | |
2303 | a) | |
2304 | a)) | |
2305 | ((eq (car a) 'bigpos) | |
2306 | (if (eq (nth (1- (length a)) a) 0) | |
2307 | (let* ((last (setq a (copy-sequence a))) (digs a)) | |
2308 | (while (setq digs (cdr digs)) | |
2309 | (or (eq (car digs) 0) (setq last digs))) | |
2310 | (setcdr last nil))) | |
2311 | (if (cdr (cdr (cdr a))) | |
2312 | a | |
2313 | (cond | |
2314 | ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000))) | |
2315 | ((cdr a) (nth 1 a)) | |
2316 | (t 0)))) | |
2317 | ((eq (car a) 'bigneg) | |
2318 | (if (eq (nth (1- (length a)) a) 0) | |
2319 | (let* ((last (setq a (copy-sequence a))) (digs a)) | |
2320 | (while (setq digs (cdr digs)) | |
2321 | (or (eq (car digs) 0) (setq last digs))) | |
2322 | (setcdr last nil))) | |
2323 | (if (cdr (cdr (cdr a))) | |
2324 | a | |
2325 | (cond | |
2326 | ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000)))) | |
2327 | ((cdr a) (- (nth 1 a))) | |
2328 | (t 0)))) | |
2329 | ((eq (car a) 'float) | |
2330 | (math-make-float (math-normalize (nth 1 a)) (nth 2 a))) | |
2331 | ((or (memq (car a) '(frac cplx polar hms date mod sdev intv vec var quote | |
2332 | special-const calcFunc-if calcFunc-lambda | |
2333 | calcFunc-quote calcFunc-condition | |
2334 | calcFunc-evalto)) | |
2335 | (integerp (car a)) | |
2336 | (and (consp (car a)) (not (eq (car (car a)) 'lambda)))) | |
2337 | (calc-extensions) | |
2338 | (math-normalize-fancy a)) | |
2339 | (t | |
2340 | (or (and calc-simplify-mode | |
2341 | (calc-extensions) | |
2342 | (math-normalize-nonstandard)) | |
2343 | (let ((args (mapcar 'math-normalize (cdr a)))) | |
2344 | (or (condition-case err | |
2345 | (let ((func (assq (car a) '( ( + . math-add ) | |
2346 | ( - . math-sub ) | |
2347 | ( * . math-mul ) | |
2348 | ( / . math-div ) | |
2349 | ( % . math-mod ) | |
2350 | ( ^ . math-pow ) | |
2351 | ( neg . math-neg ) | |
2352 | ( | . math-concat ) )))) | |
2353 | (or (and var-EvalRules | |
2354 | (progn | |
2355 | (or (eq var-EvalRules math-eval-rules-cache-tag) | |
2356 | (progn | |
2357 | (calc-extensions) | |
2358 | (math-recompile-eval-rules))) | |
2359 | (and (or math-eval-rules-cache-other | |
2360 | (assq (car a) math-eval-rules-cache)) | |
2361 | (math-apply-rewrites | |
2362 | (cons (car a) args) | |
2363 | (cdr math-eval-rules-cache) | |
2364 | nil math-eval-rules-cache)))) | |
2365 | (if func | |
2366 | (apply (cdr func) args) | |
2367 | (and (or (consp (car a)) | |
2368 | (fboundp (car a)) | |
2369 | (and (not calc-extensions-loaded) | |
2370 | (calc-extensions) | |
2371 | (fboundp (car a)))) | |
2372 | (apply (car a) args))))) | |
2373 | (wrong-number-of-arguments | |
2374 | (calc-record-why "*Wrong number of arguments" | |
2375 | (cons (car a) args)) | |
2376 | nil) | |
2377 | (wrong-type-argument | |
2378 | (or calc-next-why (calc-record-why "Wrong type of argument" | |
2379 | (cons (car a) args))) | |
2380 | nil) | |
2381 | (args-out-of-range | |
2382 | (calc-record-why "*Argument out of range" (cons (car a) args)) | |
2383 | nil) | |
2384 | (inexact-result | |
2385 | (calc-record-why "No exact representation for result" | |
2386 | (cons (car a) args)) | |
2387 | nil) | |
2388 | (math-overflow | |
2389 | (calc-record-why "*Floating-point overflow occurred" | |
2390 | (cons (car a) args)) | |
2391 | nil) | |
2392 | (math-underflow | |
2393 | (calc-record-why "*Floating-point underflow occurred" | |
2394 | (cons (car a) args)) | |
2395 | nil) | |
2396 | (void-variable | |
2397 | (if (eq (nth 1 err) 'var-EvalRules) | |
2398 | (progn | |
2399 | (setq var-EvalRules nil) | |
2400 | (math-normalize (cons (car a) args))) | |
2401 | (calc-record-why "*Variable is void" (nth 1 err))))) | |
2402 | (if (consp (car a)) | |
2403 | (math-dimension-error) | |
2404 | (cons (car a) args))))))) | |
2405 | ) | |
2406 | ||
2407 | ||
2408 | ||
2409 | ;;; True if A is a floating-point real or complex number. [P x] [Public] | |
2410 | (defun math-floatp (a) | |
2411 | (cond ((eq (car-safe a) 'float) t) | |
2412 | ((memq (car-safe a) '(cplx polar mod sdev intv)) | |
2413 | (or (math-floatp (nth 1 a)) | |
2414 | (math-floatp (nth 2 a)) | |
2415 | (and (eq (car a) 'intv) (math-floatp (nth 3 a))))) | |
2416 | ((eq (car-safe a) 'date) | |
2417 | (math-floatp (nth 1 a)))) | |
2418 | ) | |
2419 | ||
2420 | ||
2421 | ||
2422 | ;;; Verify that A is a complete object and return A. [x x] [Public] | |
2423 | (defun math-check-complete (a) | |
2424 | (cond ((integerp a) a) | |
2425 | ((eq (car-safe a) 'incomplete) | |
2426 | (calc-incomplete-error a)) | |
2427 | ((consp a) a) | |
2428 | (t (error "Invalid data object encountered"))) | |
2429 | ) | |
2430 | ||
2431 | ||
2432 | ||
2433 | ;;; Coerce integer A to be a bignum. [B S] | |
2434 | (defun math-bignum (a) | |
2435 | (if (>= a 0) | |
2436 | (cons 'bigpos (math-bignum-big a)) | |
2437 | (cons 'bigneg (math-bignum-big (- a)))) | |
2438 | ) | |
2439 | ||
2440 | (defun math-bignum-big (a) ; [L s] | |
2441 | (if (= a 0) | |
2442 | nil | |
2443 | (cons (% a 1000) (math-bignum-big (/ a 1000)))) | |
2444 | ) | |
2445 | ||
2446 | ||
2447 | ;;; Build a normalized floating-point number. [F I S] | |
2448 | (defun math-make-float (mant exp) | |
2449 | (if (eq mant 0) | |
2450 | '(float 0 0) | |
2451 | (let* ((ldiff (- calc-internal-prec (math-numdigs mant)))) | |
2452 | (if (< ldiff 0) | |
2453 | (setq mant (math-scale-rounding mant ldiff) | |
2454 | exp (- exp ldiff)))) | |
2455 | (if (consp mant) | |
2456 | (let ((digs (cdr mant))) | |
2457 | (if (= (% (car digs) 10) 0) | |
2458 | (progn | |
2459 | (while (= (car digs) 0) | |
2460 | (setq digs (cdr digs) | |
2461 | exp (+ exp 3))) | |
2462 | (while (= (% (car digs) 10) 0) | |
2463 | (setq digs (math-div10-bignum digs) | |
2464 | exp (1+ exp))) | |
2465 | (setq mant (math-normalize (cons (car mant) digs)))))) | |
2466 | (while (= (% mant 10) 0) | |
2467 | (setq mant (/ mant 10) | |
2468 | exp (1+ exp)))) | |
2469 | (if (and (<= exp -4000000) | |
2470 | (<= (+ exp (math-numdigs mant) -1) -4000000)) | |
2471 | (signal 'math-underflow nil) | |
2472 | (if (and (>= exp 3000000) | |
2473 | (>= (+ exp (math-numdigs mant) -1) 4000000)) | |
2474 | (signal 'math-overflow nil) | |
2475 | (list 'float mant exp)))) | |
2476 | ) | |
2477 | ||
2478 | (defun math-div10-bignum (a) ; [l l] | |
2479 | (if (cdr a) | |
2480 | (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100)) | |
2481 | (math-div10-bignum (cdr a))) | |
2482 | (list (/ (car a) 10))) | |
2483 | ) | |
2484 | ||
2485 | ;;; Coerce A to be a float. [F N; V V] [Public] | |
2486 | (defun math-float (a) | |
2487 | (cond ((Math-integerp a) (math-make-float a 0)) | |
2488 | ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a))) | |
2489 | ((eq (car a) 'float) a) | |
2490 | ((memq (car a) '(cplx polar vec hms date sdev mod)) | |
2491 | (cons (car a) (mapcar 'math-float (cdr a)))) | |
2492 | (t (math-float-fancy a))) | |
2493 | ) | |
2494 | ||
2495 | ||
2496 | (defun math-neg (a) | |
2497 | (cond ((not (consp a)) (- a)) | |
2498 | ((eq (car a) 'bigpos) (cons 'bigneg (cdr a))) | |
2499 | ((eq (car a) 'bigneg) (cons 'bigpos (cdr a))) | |
2500 | ((memq (car a) '(frac float)) | |
2501 | (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a))) | |
2502 | ((memq (car a) '(cplx vec hms date calcFunc-idn)) | |
2503 | (cons (car a) (mapcar 'math-neg (cdr a)))) | |
2504 | (t (math-neg-fancy a))) | |
2505 | ) | |
2506 | ||
2507 | ||
2508 | ;;; Compute the number of decimal digits in integer A. [S I] | |
2509 | (defun math-numdigs (a) | |
2510 | (if (consp a) | |
2511 | (if (cdr a) | |
2512 | (let* ((len (1- (length a))) | |
2513 | (top (nth len a))) | |
2514 | (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2)))) | |
2515 | 0) | |
2516 | (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) | |
2517 | ((>= a 10) 2) | |
2518 | ((>= a 1) 1) | |
2519 | ((= a 0) 0) | |
2520 | ((> a -10) 1) | |
2521 | ((> a -100) 2) | |
2522 | (t (math-numdigs (- a))))) | |
2523 | ) | |
2524 | ||
2525 | ;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S] | |
2526 | (defun math-scale-int (a n) | |
2527 | (cond ((= n 0) a) | |
2528 | ((> n 0) (math-scale-left a n)) | |
2529 | (t (math-normalize (math-scale-right a (- n))))) | |
2530 | ) | |
2531 | ||
2532 | (defun math-scale-left (a n) ; [I I S] | |
2533 | (if (= n 0) | |
2534 | a | |
2535 | (if (consp a) | |
2536 | (cons (car a) (math-scale-left-bignum (cdr a) n)) | |
2537 | (if (>= n 3) | |
2538 | (if (or (>= a 1000) (<= a -1000)) | |
2539 | (math-scale-left (math-bignum a) n) | |
2540 | (math-scale-left (* a 1000) (- n 3))) | |
2541 | (if (= n 2) | |
2542 | (if (or (>= a 10000) (<= a -10000)) | |
2543 | (math-scale-left (math-bignum a) 2) | |
2544 | (* a 100)) | |
2545 | (if (or (>= a 100000) (<= a -100000)) | |
2546 | (math-scale-left (math-bignum a) 1) | |
2547 | (* a 10)))))) | |
2548 | ) | |
2549 | ||
2550 | (defun math-scale-left-bignum (a n) | |
2551 | (if (>= n 3) | |
2552 | (while (>= (setq a (cons 0 a) | |
2553 | n (- n 3)) 3))) | |
2554 | (if (> n 0) | |
2555 | (math-mul-bignum-digit a (if (= n 2) 100 10) 0) | |
2556 | a) | |
2557 | ) | |
2558 | ||
2559 | (defun math-scale-right (a n) ; [i i S] | |
2560 | (if (= n 0) | |
2561 | a | |
2562 | (if (consp a) | |
2563 | (cons (car a) (math-scale-right-bignum (cdr a) n)) | |
2564 | (if (<= a 0) | |
2565 | (if (= a 0) | |
2566 | 0 | |
2567 | (- (math-scale-right (- a) n))) | |
2568 | (if (>= n 3) | |
2569 | (while (and (> (setq a (/ a 1000)) 0) | |
2570 | (>= (setq n (- n 3)) 3)))) | |
2571 | (if (= n 2) | |
2572 | (/ a 100) | |
2573 | (if (= n 1) | |
2574 | (/ a 10) | |
2575 | a))))) | |
2576 | ) | |
2577 | ||
2578 | (defun math-scale-right-bignum (a n) ; [L L S; l l S] | |
2579 | (if (>= n 3) | |
2580 | (setq a (nthcdr (/ n 3) a) | |
2581 | n (% n 3))) | |
2582 | (if (> n 0) | |
2583 | (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0)) | |
2584 | a) | |
2585 | ) | |
2586 | ||
2587 | ;;; Multiply (with rounding) the integer A by 10^N. [I i S] | |
2588 | (defun math-scale-rounding (a n) | |
2589 | (cond ((>= n 0) | |
2590 | (math-scale-left a n)) | |
2591 | ((consp a) | |
2592 | (math-normalize | |
2593 | (cons (car a) | |
2594 | (let ((val (if (< n -3) | |
2595 | (math-scale-right-bignum (cdr a) (- -3 n)) | |
2596 | (if (= n -2) | |
2597 | (math-mul-bignum-digit (cdr a) 10 0) | |
2598 | (if (= n -1) | |
2599 | (math-mul-bignum-digit (cdr a) 100 0) | |
2600 | (cdr a)))))) ; n = -3 | |
2601 | (if (and val (>= (car val) 500)) | |
2602 | (if (cdr val) | |
2603 | (if (eq (car (cdr val)) 999) | |
2604 | (math-add-bignum (cdr val) '(1)) | |
2605 | (cons (1+ (car (cdr val))) (cdr (cdr val)))) | |
2606 | '(1)) | |
2607 | (cdr val)))))) | |
2608 | (t | |
2609 | (if (< a 0) | |
2610 | (- (math-scale-rounding (- a) n)) | |
2611 | (if (= n -1) | |
2612 | (/ (+ a 5) 10) | |
2613 | (/ (+ (math-scale-right a (- -1 n)) 5) 10))))) | |
2614 | ) | |
2615 | ||
2616 | ||
2617 | ;;; Compute the sum of A and B. [O O O] [Public] | |
2618 | (defun math-add (a b) | |
2619 | (or | |
2620 | (and (not (or (consp a) (consp b))) | |
2621 | (progn | |
2622 | (setq a (+ a b)) | |
2623 | (if (or (<= a -1000000) (>= a 1000000)) | |
2624 | (math-bignum a) | |
2625 | a))) | |
2626 | (and (Math-zerop a) (not (eq (car-safe a) 'mod)) | |
2627 | (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) | |
2628 | (and (Math-zerop b) (not (eq (car-safe b) 'mod)) | |
2629 | (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) | |
2630 | (and (Math-objvecp a) (Math-objvecp b) | |
2631 | (or | |
2632 | (and (Math-integerp a) (Math-integerp b) | |
2633 | (progn | |
2634 | (or (consp a) (setq a (math-bignum a))) | |
2635 | (or (consp b) (setq b (math-bignum b))) | |
2636 | (if (eq (car a) 'bigneg) | |
2637 | (if (eq (car b) 'bigneg) | |
2638 | (cons 'bigneg (math-add-bignum (cdr a) (cdr b))) | |
2639 | (math-normalize | |
2640 | (let ((diff (math-sub-bignum (cdr b) (cdr a)))) | |
2641 | (if (eq diff 'neg) | |
2642 | (cons 'bigneg (math-sub-bignum (cdr a) (cdr b))) | |
2643 | (cons 'bigpos diff))))) | |
2644 | (if (eq (car b) 'bigneg) | |
2645 | (math-normalize | |
2646 | (let ((diff (math-sub-bignum (cdr a) (cdr b)))) | |
2647 | (if (eq diff 'neg) | |
2648 | (cons 'bigneg (math-sub-bignum (cdr b) (cdr a))) | |
2649 | (cons 'bigpos diff)))) | |
2650 | (cons 'bigpos (math-add-bignum (cdr a) (cdr b))))))) | |
2651 | (and (Math-ratp a) (Math-ratp b) | |
2652 | (calc-extensions) | |
2653 | (calc-add-fractions a b)) | |
2654 | (and (Math-realp a) (Math-realp b) | |
2655 | (progn | |
2656 | (or (and (consp a) (eq (car a) 'float)) | |
2657 | (setq a (math-float a))) | |
2658 | (or (and (consp b) (eq (car b) 'float)) | |
2659 | (setq b (math-float b))) | |
2660 | (math-add-float a b))) | |
2661 | (and (calc-extensions) | |
2662 | (math-add-objects-fancy a b)))) | |
2663 | (and (calc-extensions) | |
2664 | (math-add-symb-fancy a b))) | |
2665 | ) | |
2666 | ||
2667 | (defun math-add-bignum (a b) ; [L L L; l l l] | |
2668 | (if a | |
2669 | (if b | |
2670 | (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) | |
2671 | (while (and aa b) | |
2672 | (if carry | |
2673 | (if (< (setq sum (+ (car aa) (car b))) 999) | |
2674 | (progn | |
2675 | (setcar aa (1+ sum)) | |
2676 | (setq carry nil)) | |
2677 | (setcar aa (+ sum -999))) | |
2678 | (if (< (setq sum (+ (car aa) (car b))) 1000) | |
2679 | (setcar aa sum) | |
2680 | (setcar aa (+ sum -1000)) | |
2681 | (setq carry t))) | |
2682 | (setq aa (cdr aa) | |
2683 | b (cdr b))) | |
2684 | (if carry | |
2685 | (if b | |
2686 | (nconc a (math-add-bignum b '(1))) | |
2687 | (while (eq (car aa) 999) | |
2688 | (setcar aa 0) | |
2689 | (setq aa (cdr aa))) | |
2690 | (if aa | |
2691 | (progn | |
2692 | (setcar aa (1+ (car aa))) | |
2693 | a) | |
2694 | (nconc a '(1)))) | |
2695 | (if b | |
2696 | (nconc a b) | |
2697 | a))) | |
2698 | a) | |
2699 | b) | |
2700 | ) | |
2701 | ||
2702 | (defun math-sub-bignum (a b) ; [l l l] | |
2703 | (if b | |
2704 | (if a | |
2705 | (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum) | |
2706 | (while (and aa b) | |
2707 | (if borrow | |
2708 | (if (>= (setq diff (- (car aa) (car b))) 1) | |
2709 | (progn | |
2710 | (setcar aa (1- diff)) | |
2711 | (setq borrow nil)) | |
2712 | (setcar aa (+ diff 999))) | |
2713 | (if (>= (setq diff (- (car aa) (car b))) 0) | |
2714 | (setcar aa diff) | |
2715 | (setcar aa (+ diff 1000)) | |
2716 | (setq borrow t))) | |
2717 | (setq aa (cdr aa) | |
2718 | b (cdr b))) | |
2719 | (if borrow | |
2720 | (progn | |
2721 | (while (eq (car aa) 0) | |
2722 | (setcar aa 999) | |
2723 | (setq aa (cdr aa))) | |
2724 | (if aa | |
2725 | (progn | |
2726 | (setcar aa (1- (car aa))) | |
2727 | a) | |
2728 | 'neg)) | |
2729 | (while (eq (car b) 0) | |
2730 | (setq b (cdr b))) | |
2731 | (if b | |
2732 | 'neg | |
2733 | a))) | |
2734 | (while (eq (car b) 0) | |
2735 | (setq b (cdr b))) | |
2736 | (and b | |
2737 | 'neg)) | |
2738 | a) | |
2739 | ) | |
2740 | ||
2741 | (defun math-add-float (a b) ; [F F F] | |
2742 | (let ((ediff (- (nth 2 a) (nth 2 b)))) | |
2743 | (if (>= ediff 0) | |
2744 | (if (>= ediff (+ calc-internal-prec calc-internal-prec)) | |
2745 | a | |
2746 | (math-make-float (math-add (nth 1 b) | |
2747 | (if (eq ediff 0) | |
2748 | (nth 1 a) | |
2749 | (math-scale-left (nth 1 a) ediff))) | |
2750 | (nth 2 b))) | |
2751 | (if (>= (setq ediff (- ediff)) | |
2752 | (+ calc-internal-prec calc-internal-prec)) | |
2753 | b | |
2754 | (math-make-float (math-add (nth 1 a) | |
2755 | (math-scale-left (nth 1 b) ediff)) | |
2756 | (nth 2 a))))) | |
2757 | ) | |
2758 | ||
2759 | ;;; Compute the difference of A and B. [O O O] [Public] | |
2760 | (defun math-sub (a b) | |
2761 | (if (or (consp a) (consp b)) | |
2762 | (math-add a (math-neg b)) | |
2763 | (setq a (- a b)) | |
2764 | (if (or (<= a -1000000) (>= a 1000000)) | |
2765 | (math-bignum a) | |
2766 | a)) | |
2767 | ) | |
2768 | ||
2769 | (defun math-sub-float (a b) ; [F F F] | |
2770 | (let ((ediff (- (nth 2 a) (nth 2 b)))) | |
2771 | (if (>= ediff 0) | |
2772 | (if (>= ediff (+ calc-internal-prec calc-internal-prec)) | |
2773 | a | |
2774 | (math-make-float (math-add (Math-integer-neg (nth 1 b)) | |
2775 | (if (eq ediff 0) | |
2776 | (nth 1 a) | |
2777 | (math-scale-left (nth 1 a) ediff))) | |
2778 | (nth 2 b))) | |
2779 | (if (>= (setq ediff (- ediff)) | |
2780 | (+ calc-internal-prec calc-internal-prec)) | |
2781 | b | |
2782 | (math-make-float (math-add (nth 1 a) | |
2783 | (Math-integer-neg | |
2784 | (math-scale-left (nth 1 b) ediff))) | |
2785 | (nth 2 a))))) | |
2786 | ) | |
2787 | ||
2788 | ||
2789 | ;;; Compute the product of A and B. [O O O] [Public] | |
2790 | (defun math-mul (a b) | |
2791 | (or | |
2792 | (and (not (consp a)) (not (consp b)) | |
2793 | (< a 1000) (> a -1000) (< b 1000) (> b -1000) | |
2794 | (* a b)) | |
2795 | (and (Math-zerop a) (not (eq (car-safe b) 'mod)) | |
2796 | (if (Math-scalarp b) | |
2797 | (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) | |
2798 | (calc-extensions) | |
2799 | (math-mul-zero a b))) | |
2800 | (and (Math-zerop b) (not (eq (car-safe a) 'mod)) | |
2801 | (if (Math-scalarp a) | |
2802 | (if (and (math-floatp a) (Math-ratp b)) (math-float b) b) | |
2803 | (calc-extensions) | |
2804 | (math-mul-zero b a))) | |
2805 | (and (Math-objvecp a) (Math-objvecp b) | |
2806 | (or | |
2807 | (and (Math-integerp a) (Math-integerp b) | |
2808 | (progn | |
2809 | (or (consp a) (setq a (math-bignum a))) | |
2810 | (or (consp b) (setq b (math-bignum b))) | |
2811 | (math-normalize | |
2812 | (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) | |
2813 | (if (cdr (cdr a)) | |
2814 | (if (cdr (cdr b)) | |
2815 | (math-mul-bignum (cdr a) (cdr b)) | |
2816 | (math-mul-bignum-digit (cdr a) (nth 1 b) 0)) | |
2817 | (math-mul-bignum-digit (cdr b) (nth 1 a) 0)))))) | |
2818 | (and (Math-ratp a) (Math-ratp b) | |
2819 | (calc-extensions) | |
2820 | (calc-mul-fractions a b)) | |
2821 | (and (Math-realp a) (Math-realp b) | |
2822 | (progn | |
2823 | (or (and (consp a) (eq (car a) 'float)) | |
2824 | (setq a (math-float a))) | |
2825 | (or (and (consp b) (eq (car b) 'float)) | |
2826 | (setq b (math-float b))) | |
2827 | (math-make-float (math-mul (nth 1 a) (nth 1 b)) | |
2828 | (+ (nth 2 a) (nth 2 b))))) | |
2829 | (and (calc-extensions) | |
2830 | (math-mul-objects-fancy a b)))) | |
2831 | (and (calc-extensions) | |
2832 | (math-mul-symb-fancy a b))) | |
2833 | ) | |
2834 | ||
2835 | (defun math-infinitep (a &optional undir) | |
2836 | (while (and (consp a) (memq (car a) '(* / neg))) | |
2837 | (if (or (not (eq (car a) '*)) (math-infinitep (nth 1 a))) | |
2838 | (setq a (nth 1 a)) | |
2839 | (setq a (nth 2 a)))) | |
2840 | (and (consp a) | |
2841 | (eq (car a) 'var) | |
2842 | (memq (nth 2 a) '(var-inf var-uinf var-nan)) | |
2843 | (if (and undir (eq (nth 2 a) 'var-inf)) | |
2844 | '(var uinf var-uinf) | |
2845 | a)) | |
2846 | ) | |
2847 | ||
2848 | ;;; Multiply digit lists A and B. [L L L; l l l] | |
2849 | (defun math-mul-bignum (a b) | |
2850 | (and a b | |
2851 | (let* ((sum (if (<= (car b) 1) | |
2852 | (if (= (car b) 0) | |
2853 | (list 0) | |
2854 | (copy-sequence a)) | |
2855 | (math-mul-bignum-digit a (car b) 0))) | |
2856 | (sump sum) c d aa ss prod) | |
2857 | (while (setq b (cdr b)) | |
2858 | (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0)))) | |
2859 | d (car b) | |
2860 | c 0 | |
2861 | aa a) | |
2862 | (while (progn | |
2863 | (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) | |
2864 | c)) 1000)) | |
2865 | (setq aa (cdr aa))) | |
2866 | (setq c (/ prod 1000) | |
2867 | ss (or (cdr ss) (setcdr ss (list 0))))) | |
2868 | (if (>= prod 1000) | |
2869 | (if (cdr ss) | |
2870 | (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss)))) | |
2871 | (setcdr ss (list (/ prod 1000)))))) | |
2872 | sum)) | |
2873 | ) | |
2874 | ||
2875 | ;;; Multiply digit list A by digit D. [L L D D; l l D D] | |
2876 | (defun math-mul-bignum-digit (a d c) | |
2877 | (if a | |
2878 | (if (<= d 1) | |
2879 | (and (= d 1) a) | |
2880 | (let* ((a (copy-sequence a)) (aa a) prod) | |
2881 | (while (progn | |
2882 | (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000)) | |
2883 | (cdr aa)) | |
2884 | (setq aa (cdr aa) | |
2885 | c (/ prod 1000))) | |
2886 | (if (>= prod 1000) | |
2887 | (setcdr aa (list (/ prod 1000)))) | |
2888 | a)) | |
2889 | (and (> c 0) | |
2890 | (list c))) | |
2891 | ) | |
2892 | ||
2893 | ||
2894 | ;;; Compute the integer (quotient . remainder) of A and B, which may be | |
2895 | ;;; small or big integers. Type and consistency of truncation is undefined | |
2896 | ;;; if A or B is negative. B must be nonzero. [I.I I I] [Public] | |
2897 | (defun math-idivmod (a b) | |
2898 | (if (eq b 0) | |
2899 | (math-reject-arg a "*Division by zero")) | |
2900 | (if (or (consp a) (consp b)) | |
2901 | (if (and (natnump b) (< b 1000)) | |
2902 | (let ((res (math-div-bignum-digit (cdr a) b))) | |
2903 | (cons | |
2904 | (math-normalize (cons (car a) (car res))) | |
2905 | (cdr res))) | |
2906 | (or (consp a) (setq a (math-bignum a))) | |
2907 | (or (consp b) (setq b (math-bignum b))) | |
2908 | (let ((res (math-div-bignum (cdr a) (cdr b)))) | |
2909 | (cons | |
2910 | (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) | |
2911 | (car res))) | |
2912 | (math-normalize (cons (car a) (cdr res)))))) | |
2913 | (cons (/ a b) (% a b))) | |
2914 | ) | |
2915 | ||
2916 | (defun math-quotient (a b) ; [I I I] [Public] | |
2917 | (if (and (not (consp a)) (not (consp b))) | |
2918 | (if (= b 0) | |
2919 | (math-reject-arg a "*Division by zero") | |
2920 | (/ a b)) | |
2921 | (if (and (natnump b) (< b 1000)) | |
2922 | (if (= b 0) | |
2923 | (math-reject-arg a "*Division by zero") | |
2924 | (math-normalize (cons (car a) | |
2925 | (car (math-div-bignum-digit (cdr a) b))))) | |
2926 | (or (consp a) (setq a (math-bignum a))) | |
2927 | (or (consp b) (setq b (math-bignum b))) | |
2928 | (let* ((alen (1- (length a))) | |
2929 | (blen (1- (length b))) | |
2930 | (d (/ 1000 (1+ (nth (1- blen) (cdr b))))) | |
2931 | (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) | |
2932 | (math-mul-bignum-digit (cdr b) d 0) | |
2933 | alen blen))) | |
2934 | (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) | |
2935 | (car res)))))) | |
2936 | ) | |
2937 | ||
2938 | ||
2939 | ;;; Divide a bignum digit list by another. [l.l l L] | |
2940 | ;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1 | |
2941 | (defun math-div-bignum (a b) | |
2942 | (if (cdr b) | |
2943 | (let* ((alen (length a)) | |
2944 | (blen (length b)) | |
2945 | (d (/ 1000 (1+ (nth (1- blen) b)))) | |
2946 | (res (math-div-bignum-big (math-mul-bignum-digit a d 0) | |
2947 | (math-mul-bignum-digit b d 0) | |
2948 | alen blen))) | |
2949 | (if (= d 1) | |
2950 | res | |
2951 | (cons (car res) | |
2952 | (car (math-div-bignum-digit (cdr res) d))))) | |
2953 | (let ((res (math-div-bignum-digit a (car b)))) | |
2954 | (cons (car res) (list (cdr res))))) | |
2955 | ) | |
2956 | ||
2957 | ;;; Divide a bignum digit list by a digit. [l.D l D] | |
2958 | (defun math-div-bignum-digit (a b) | |
2959 | (if a | |
2960 | (let* ((res (math-div-bignum-digit (cdr a) b)) | |
2961 | (num (+ (* (cdr res) 1000) (car a)))) | |
2962 | (cons | |
2963 | (cons (/ num b) (car res)) | |
2964 | (% num b))) | |
2965 | '(nil . 0)) | |
2966 | ) | |
2967 | ||
2968 | (defun math-div-bignum-big (a b alen blen) ; [l.l l L] | |
2969 | (if (< alen blen) | |
2970 | (cons nil a) | |
2971 | (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen)) | |
2972 | (num (cons (car a) (cdr res))) | |
2973 | (res2 (math-div-bignum-part num b blen))) | |
2974 | (cons | |
2975 | (cons (car res2) (car res)) | |
2976 | (cdr res2)))) | |
2977 | ) | |
2978 | ||
2979 | (defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L] | |
2980 | (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0))) | |
2981 | (den (nth (1- blen) b)) | |
2982 | (guess (min (/ num den) 999))) | |
2983 | (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)) | |
2984 | ) | |
2985 | ||
2986 | (defun math-div-bignum-try (a b c guess) ; [D.l l l D] | |
2987 | (let ((rem (math-sub-bignum a c))) | |
2988 | (if (eq rem 'neg) | |
2989 | (math-div-bignum-try a b (math-sub-bignum c b) (1- guess)) | |
2990 | (cons guess rem))) | |
2991 | ) | |
2992 | ||
2993 | ||
2994 | ;;; Compute the quotient of A and B. [O O N] [Public] | |
2995 | (defun math-div (a b) | |
2996 | (or | |
2997 | (and (Math-zerop b) | |
2998 | (calc-extensions) | |
2999 | (math-div-by-zero a b)) | |
3000 | (and (Math-zerop a) (not (eq (car-safe b) 'mod)) | |
3001 | (if (Math-scalarp b) | |
3002 | (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) | |
3003 | (calc-extensions) | |
3004 | (math-div-zero a b))) | |
3005 | (and (Math-objvecp a) (Math-objvecp b) | |
3006 | (or | |
3007 | (and (Math-integerp a) (Math-integerp b) | |
3008 | (let ((q (math-idivmod a b))) | |
3009 | (if (eq (cdr q) 0) | |
3010 | (car q) | |
3011 | (if calc-prefer-frac | |
3012 | (progn | |
3013 | (calc-extensions) | |
3014 | (math-make-frac a b)) | |
3015 | (math-div-float (math-make-float a 0) | |
3016 | (math-make-float b 0)))))) | |
3017 | (and (Math-ratp a) (Math-ratp b) | |
3018 | (calc-extensions) | |
3019 | (calc-div-fractions a b)) | |
3020 | (and (Math-realp a) (Math-realp b) | |
3021 | (progn | |
3022 | (or (and (consp a) (eq (car a) 'float)) | |
3023 | (setq a (math-float a))) | |
3024 | (or (and (consp b) (eq (car b) 'float)) | |
3025 | (setq b (math-float b))) | |
3026 | (math-div-float a b))) | |
3027 | (and (calc-extensions) | |
3028 | (math-div-objects-fancy a b)))) | |
3029 | (and (calc-extensions) | |
3030 | (math-div-symb-fancy a b))) | |
3031 | ) | |
3032 | ||
3033 | (defun math-div-float (a b) ; [F F F] | |
3034 | (let ((ldiff (max (- (1+ calc-internal-prec) | |
3035 | (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b)))) | |
3036 | 0))) | |
3037 | (math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b)) | |
3038 | (- (- (nth 2 a) (nth 2 b)) ldiff))) | |
3039 | ) | |
3040 | ||
3041 | ||
3042 | ||
3043 | ||
3044 | ||
3045 | ;;; Format the number A as a string. [X N; X Z] [Public] | |
3046 | (defun math-format-stack-value (entry) | |
3047 | (setq calc-selection-cache-entry calc-selection-cache-default-entry) | |
3048 | (let* ((a (car entry)) | |
3049 | (math-comp-selected (nth 2 entry)) | |
3050 | (c (cond ((null a) "<nil>") | |
3051 | ((eq calc-display-raw t) (format "%s" a)) | |
3052 | ((stringp a) a) | |
3053 | ((eq a 'top-of-stack) ".") | |
3054 | (calc-prepared-composition | |
3055 | calc-prepared-composition) | |
3056 | ((and (Math-scalarp a) | |
3057 | (memq calc-language '(nil flat unform)) | |
3058 | (null math-comp-selected)) | |
3059 | (math-format-number a)) | |
3060 | (t (calc-extensions) | |
3061 | (math-compose-expr a 0)))) | |
3062 | (off (math-stack-value-offset c)) | |
3063 | s w) | |
3064 | (and math-comp-selected (setq calc-any-selections t)) | |
3065 | (setq w (cdr off) | |
3066 | off (car off)) | |
3067 | (if (> off 0) | |
3068 | (setq c (math-comp-concat (make-string off ? ) c))) | |
3069 | (or (equal calc-left-label "") | |
3070 | (setq c (math-comp-concat (if (eq a 'top-of-stack) | |
3071 | (make-string (length calc-left-label) ? ) | |
3072 | calc-left-label) | |
3073 | c))) | |
3074 | (if calc-line-numbering | |
3075 | (setq c (math-comp-concat (if (eq calc-language 'big) | |
3076 | (if math-comp-selected | |
3077 | '(tag t "1: ") "1: ") | |
3078 | " ") | |
3079 | c))) | |
3080 | (or (equal calc-right-label "") | |
3081 | (eq a 'top-of-stack) | |
3082 | (progn | |
3083 | (calc-extensions) | |
3084 | (setq c (list 'horiz c | |
3085 | (make-string (max (- w (math-comp-width c) | |
3086 | (length calc-right-label)) 0) ? ) | |
3087 | '(break -1) | |
3088 | calc-right-label)))) | |
3089 | (setq s (if (stringp c) | |
3090 | (if calc-display-raw | |
3091 | (prin1-to-string c) | |
3092 | c) | |
3093 | (math-composition-to-string c w))) | |
3094 | (if calc-language-output-filter | |
3095 | (setq s (funcall calc-language-output-filter s))) | |
3096 | (if (eq calc-language 'big) | |
3097 | (setq s (concat s "\n")) | |
3098 | (if calc-line-numbering | |
3099 | (progn | |
3100 | (aset s 0 ?1) | |
3101 | (aset s 1 ?:)))) | |
3102 | (setcar (cdr entry) (calc-count-lines s)) | |
3103 | s) | |
3104 | ) | |
3105 | ||
3106 | (defun math-stack-value-offset (c) | |
3107 | (let* ((num (if calc-line-numbering 4 0)) | |
3108 | (wid (calc-window-width)) | |
3109 | off) | |
3110 | (if calc-display-just | |
3111 | (progn | |
3112 | (calc-extensions) | |
3113 | (math-stack-value-offset-fancy)) | |
3114 | (setq off (or calc-display-origin 0)) | |
3115 | (if (integerp calc-line-breaking) | |
3116 | (setq wid calc-line-breaking))) | |
3117 | (cons (max (- off (length calc-left-label)) 0) | |
3118 | (+ wid num))) | |
3119 | ) | |
3120 | ||
3121 | (defun calc-count-lines (s) | |
3122 | (let ((pos 0) | |
3123 | (num 1)) | |
3124 | (while (setq newpos (string-match "\n" s pos)) | |
3125 | (setq pos (1+ newpos) | |
3126 | num (1+ num))) | |
3127 | num) | |
3128 | ) | |
3129 | ||
3130 | (defun math-format-value (a &optional w) | |
3131 | (if (and (Math-scalarp a) | |
3132 | (memq calc-language '(nil flat unform))) | |
3133 | (math-format-number a) | |
3134 | (calc-extensions) | |
3135 | (let ((calc-line-breaking nil)) | |
3136 | (math-composition-to-string (math-compose-expr a 0) w))) | |
3137 | ) | |
3138 | ||
3139 | (defun calc-window-width () | |
3140 | (if calc-embedded-info | |
3141 | (let ((win (get-buffer-window (aref calc-embedded-info 0)))) | |
3142 | (1- (if win (window-width win) (screen-width)))) | |
3143 | (- (window-width (get-buffer-window (current-buffer))) | |
3144 | (if calc-line-numbering 5 1))) | |
3145 | ) | |
3146 | ||
3147 | (defun math-comp-concat (c1 c2) | |
3148 | (if (and (stringp c1) (stringp c2)) | |
3149 | (concat c1 c2) | |
3150 | (list 'horiz c1 c2)) | |
3151 | ) | |
3152 | ||
3153 | ||
3154 | ||
3155 | ;;; Format an expression as a one-line string suitable for re-reading. | |
3156 | ||
3157 | (defun math-format-flat-expr (a prec) | |
3158 | (cond | |
3159 | ((or (not (or (consp a) (integerp a))) | |
3160 | (eq calc-display-raw t)) | |
3161 | (let ((print-escape-newlines t)) | |
3162 | (concat "'" (prin1-to-string a)))) | |
3163 | ((Math-scalarp a) | |
3164 | (let ((calc-group-digits nil) | |
3165 | (calc-point-char ".") | |
3166 | (calc-frac-format (if (> (length (car calc-frac-format)) 1) | |
3167 | '("::" nil) '(":" nil))) | |
3168 | (calc-complex-format nil) | |
3169 | (calc-hms-format "%s@ %s' %s\"") | |
3170 | (calc-language nil)) | |
3171 | (math-format-number a))) | |
3172 | (t | |
3173 | (calc-extensions) | |
3174 | (math-format-flat-expr-fancy a prec))) | |
3175 | ) | |
3176 | ||
3177 | ||
3178 | ||
3179 | ;;; Format a number as a string. | |
3180 | (defun math-format-number (a &optional prec) ; [X N] [Public] | |
3181 | (cond | |
3182 | ((eq calc-display-raw t) (format "%s" a)) | |
3183 | ((and (nth 1 calc-frac-format) (Math-integerp a)) | |
3184 | (calc-extensions) | |
3185 | (math-format-number (math-adjust-fraction a))) | |
3186 | ((integerp a) | |
3187 | (if (not (or calc-group-digits calc-leading-zeros)) | |
3188 | (if (= calc-number-radix 10) | |
3189 | (int-to-string a) | |
3190 | (if (< a 0) | |
3191 | (concat "-" (math-format-number (- a))) | |
3192 | (calc-extensions) | |
3193 | (if math-radix-explicit-format | |
3194 | (if calc-radix-formatter | |
3195 | (funcall calc-radix-formatter | |
3196 | calc-number-radix | |
3197 | (if (= calc-number-radix 2) | |
3198 | (math-format-binary a) | |
3199 | (math-format-radix a))) | |
3200 | (format "%d#%s" calc-number-radix | |
3201 | (if (= calc-number-radix 2) | |
3202 | (math-format-binary a) | |
3203 | (math-format-radix a)))) | |
3204 | (math-format-radix a)))) | |
3205 | (math-format-number (math-bignum a)))) | |
3206 | ((stringp a) a) | |
3207 | ((not (consp a)) (prin1-to-string a)) | |
3208 | ((eq (car a) 'bigpos) (math-format-bignum (cdr a))) | |
3209 | ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a)))) | |
3210 | ((and (eq (car a) 'float) (= calc-number-radix 10)) | |
3211 | (if (Math-integer-negp (nth 1 a)) | |
3212 | (concat "-" (math-format-number (math-neg a))) | |
3213 | (let ((mant (nth 1 a)) | |
3214 | (exp (nth 2 a)) | |
3215 | (fmt (car calc-float-format)) | |
3216 | (figs (nth 1 calc-float-format)) | |
3217 | (point calc-point-char) | |
3218 | str) | |
3219 | (if (and (eq fmt 'fix) | |
3220 | (or (and (< figs 0) (setq figs (- figs))) | |
3221 | (> (+ exp (math-numdigs mant)) (- figs)))) | |
3222 | (progn | |
3223 | (setq mant (math-scale-rounding mant (+ exp figs)) | |
3224 | str (if (integerp mant) | |
3225 | (int-to-string mant) | |
3226 | (math-format-bignum-decimal (cdr mant)))) | |
3227 | (if (<= (length str) figs) | |
3228 | (setq str (concat (make-string (1+ (- figs (length str))) ?0) | |
3229 | str))) | |
3230 | (if (> figs 0) | |
3231 | (setq str (concat (substring str 0 (- figs)) point | |
3232 | (substring str (- figs)))) | |
3233 | (setq str (concat str point))) | |
3234 | (if calc-group-digits | |
3235 | (setq str (math-group-float str)))) | |
3236 | (if (< figs 0) | |
3237 | (setq figs (+ calc-internal-prec figs))) | |
3238 | (if (> figs 0) | |
3239 | (let ((adj (- figs (math-numdigs mant)))) | |
3240 | (if (< adj 0) | |
3241 | (setq mant (math-scale-rounding mant adj) | |
3242 | exp (- exp adj))))) | |
3243 | (setq str (if (integerp mant) | |
3244 | (int-to-string mant) | |
3245 | (math-format-bignum-decimal (cdr mant)))) | |
3246 | (let* ((len (length str)) | |
3247 | (dpos (+ exp len))) | |
3248 | (if (and (eq fmt 'float) | |
3249 | (<= dpos (+ calc-internal-prec calc-display-sci-high)) | |
3250 | (>= dpos (+ calc-display-sci-low 2))) | |
3251 | (progn | |
3252 | (cond | |
3253 | ((= dpos 0) | |
3254 | (setq str (concat "0" point str))) | |
3255 | ((and (<= exp 0) (> dpos 0)) | |
3256 | (setq str (concat (substring str 0 dpos) point | |
3257 | (substring str dpos)))) | |
3258 | ((> exp 0) | |
3259 | (setq str (concat str (make-string exp ?0) point))) | |
3260 | (t ; (< dpos 0) | |
3261 | (setq str (concat "0" point | |
3262 | (make-string (- dpos) ?0) str)))) | |
3263 | (if calc-group-digits | |
3264 | (setq str (math-group-float str)))) | |
3265 | (let* ((eadj (+ exp len)) | |
3266 | (scale (if (eq fmt 'eng) | |
3267 | (1+ (math-mod (+ eadj 300002) 3)) | |
3268 | 1))) | |
3269 | (if (> scale (length str)) | |
3270 | (setq str (concat str (make-string (- scale (length str)) | |
3271 | ?0)))) | |
3272 | (if (< scale (length str)) | |
3273 | (setq str (concat (substring str 0 scale) point | |
3274 | (substring str scale)))) | |
3275 | (if calc-group-digits | |
3276 | (setq str (math-group-float str))) | |
3277 | (setq str (format (if (memq calc-language '(math maple)) | |
3278 | (if (and prec (> prec 191)) | |
3279 | "(%s*10.^%d)" "%s*10.^%d") | |
3280 | "%se%d") | |
3281 | str (- eadj scale))))))) | |
3282 | str))) | |
3283 | (t | |
3284 | (calc-extensions) | |
3285 | (math-format-number-fancy a prec))) | |
3286 | ) | |
3287 | ||
3288 | (defun math-format-bignum (a) ; [X L] | |
3289 | (if (and (= calc-number-radix 10) | |
3290 | (not calc-leading-zeros) | |
3291 | (not calc-group-digits)) | |
3292 | (math-format-bignum-decimal a) | |
3293 | (calc-extensions) | |
3294 | (math-format-bignum-fancy a)) | |
3295 | ) | |
3296 | ||
3297 | (defun math-format-bignum-decimal (a) ; [X L] | |
3298 | (if a | |
3299 | (let ((s "")) | |
3300 | (while (cdr (cdr a)) | |
3301 | (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s) | |
3302 | a (cdr (cdr a)))) | |
3303 | (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s)) | |
3304 | "0") | |
3305 | ) | |
3306 | ||
3307 | ||
3308 | ||
3309 | ;;; Parse a simple number in string form. [N X] [Public] | |
3310 | (defun math-read-number (s) | |
3311 | (math-normalize | |
3312 | (cond | |
3313 | ||
3314 | ;; Integers (most common case) | |
3315 | ((string-match "\\` *\\([0-9]+\\) *\\'" s) | |
3316 | (let ((digs (math-match-substring s 1))) | |
3317 | (if (and (eq calc-language 'c) | |
3318 | (> (length digs) 1) | |
3319 | (eq (aref digs 0) ?0)) | |
3320 | (math-read-number (concat "8#" digs)) | |
3321 | (if (<= (length digs) 6) | |
3322 | (string-to-int digs) | |
3323 | (cons 'bigpos (math-read-bignum digs)))))) | |
3324 | ||
3325 | ;; Clean up the string if necessary | |
3326 | ((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]*\\)\\'" s) | |
3327 | (math-read-number (concat (math-match-substring s 1) | |
3328 | (math-match-substring s 2)))) | |
3329 | ||
3330 | ;; Plus and minus signs | |
3331 | ((string-match "^[-_+]\\(.*\\)$" s) | |
3332 | (let ((val (math-read-number (math-match-substring s 1)))) | |
3333 | (and val (if (eq (aref s 0) ?+) val (math-neg val))))) | |
3334 | ||
3335 | ;; Forms that require extensions module | |
3336 | ((string-match "[^-+0-9eE.]" s) | |
3337 | (calc-extensions) | |
3338 | (math-read-number-fancy s)) | |
3339 | ||
3340 | ;; Decimal point | |
3341 | ((string-match "^\\([0-9]*\\)\\.\\([0-9]*\\)$" s) | |
3342 | (let ((int (math-match-substring s 1)) | |
3343 | (frac (math-match-substring s 2))) | |
3344 | (let ((ilen (length int)) | |
3345 | (flen (length frac))) | |
3346 | (let ((int (if (> ilen 0) (math-read-number int) 0)) | |
3347 | (frac (if (> flen 0) (math-read-number frac) 0))) | |
3348 | (and int frac (or (> ilen 0) (> flen 0)) | |
3349 | (list 'float | |
3350 | (math-add (math-scale-int int flen) frac) | |
3351 | (- flen))))))) | |
3352 | ||
3353 | ;; "e" notation | |
3354 | ((string-match "^\\(.*\\)[eE]\\([-+]?[0-9]+\\)$" s) | |
3355 | (let ((mant (math-match-substring s 1)) | |
3356 | (exp (math-match-substring s 2))) | |
3357 | (let ((mant (if (> (length mant) 0) (math-read-number mant) 1)) | |
3358 | (exp (if (<= (length exp) (if (memq (aref exp 0) '(?+ ?-)) 8 7)) | |
3359 | (string-to-int exp)))) | |
3360 | (and mant exp (Math-realp mant) (> exp -4000000) (< exp 4000000) | |
3361 | (let ((mant (math-float mant))) | |
3362 | (list 'float (nth 1 mant) (+ (nth 2 mant) exp))))))) | |
3363 | ||
3364 | ;; Syntax error! | |
3365 | (t nil))) | |
3366 | ) | |
3367 | ||
3368 | (defun math-match-substring (s n) | |
3369 | (if (match-beginning n) | |
3370 | (substring s (match-beginning n) (match-end n)) | |
3371 | "") | |
3372 | ) | |
3373 | ||
3374 | (defun math-read-bignum (s) ; [l X] | |
3375 | (if (> (length s) 3) | |
3376 | (cons (string-to-int (substring s -3)) | |
3377 | (math-read-bignum (substring s 0 -3))) | |
3378 | (list (string-to-int s))) | |
3379 | ) | |
3380 | ||
3381 | ||
3382 | (defconst math-tex-ignore-words | |
3383 | '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") | |
3384 | ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") | |
3385 | ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") | |
3386 | ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") | |
3387 | ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") | |
3388 | ("\\rm") ("\\bf") ("\\it") ("\\sl") | |
3389 | ("\\roman") ("\\bold") ("\\italic") ("\\slanted") | |
3390 | ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") | |
3391 | ("\\evalto") | |
3392 | ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) | |
3393 | ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") | |
3394 | ("\\{" punc "[") ("\\}" punc "]") | |
3395 | )) | |
3396 | ||
3397 | (defconst math-eqn-ignore-words | |
3398 | '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") | |
3399 | ("left" ("floor") ("ceil")) | |
3400 | ("right" ("floor") ("ceil")) | |
3401 | ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) | |
3402 | ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) | |
3403 | ("above" punc ",") | |
3404 | )) | |
3405 | ||
3406 | (defconst math-standard-opers | |
3407 | '( ( "_" calcFunc-subscr 1200 1201 ) | |
3408 | ( "%" calcFunc-percent 1100 -1 ) | |
3409 | ( "u+" ident -1 1000 ) | |
3410 | ( "u-" neg -1 1000 197 ) | |
3411 | ( "u!" calcFunc-lnot -1 1000 ) | |
3412 | ( "mod" mod 400 400 185 ) | |
3413 | ( "+/-" sdev 300 300 185 ) | |
3414 | ( "!!" calcFunc-dfact 210 -1 ) | |
3415 | ( "!" calcFunc-fact 210 -1 ) | |
3416 | ( "^" ^ 201 200 ) | |
3417 | ( "**" ^ 201 200 ) | |
3418 | ( "*" * 196 195 ) | |
3419 | ( "2x" * 196 195 ) | |
3420 | ( "/" / 190 191 ) | |
3421 | ( "%" % 190 191 ) | |
3422 | ( "\\" calcFunc-idiv 190 191 ) | |
3423 | ( "+" + 180 181 ) | |
3424 | ( "-" - 180 181 ) | |
3425 | ( "|" | 170 171 ) | |
3426 | ( "<" calcFunc-lt 160 161 ) | |
3427 | ( ">" calcFunc-gt 160 161 ) | |
3428 | ( "<=" calcFunc-leq 160 161 ) | |
3429 | ( ">=" calcFunc-geq 160 161 ) | |
3430 | ( "=" calcFunc-eq 160 161 ) | |
3431 | ( "==" calcFunc-eq 160 161 ) | |
3432 | ( "!=" calcFunc-neq 160 161 ) | |
3433 | ( "&&" calcFunc-land 110 111 ) | |
3434 | ( "||" calcFunc-lor 100 101 ) | |
3435 | ( "?" (math-read-if) 91 90 ) | |
3436 | ( "!!!" calcFunc-pnot -1 85 ) | |
3437 | ( "&&&" calcFunc-pand 80 81 ) | |
3438 | ( "|||" calcFunc-por 75 76 ) | |
3439 | ( ":=" calcFunc-assign 51 50 ) | |
3440 | ( "::" calcFunc-condition 45 46 ) | |
3441 | ( "=>" calcFunc-evalto 40 41 ) | |
3442 | ( "=>" calcFunc-evalto 40 -1 ) | |
3443 | )) | |
3444 | (setq math-expr-opers math-standard-opers) | |
3445 | ||
3446 | ||
3447 | ;;;###autoload | |
3448 | (defun calc-grab-region (top bot arg) | |
3449 | "Parse the region as a vector of numbers and push it on the Calculator stack." | |
3450 | (interactive "r\nP") | |
3451 | (calc-extensions) | |
3452 | (calc-do-grab-region top bot arg) | |
3453 | ) | |
3454 | ||
3455 | ;;;###autoload | |
3456 | (defun calc-grab-rectangle (top bot arg) | |
3457 | "Parse a rectangle as a matrix of numbers and push it on the Calculator stack." | |
3458 | (interactive "r\nP") | |
3459 | (calc-extensions) | |
3460 | (calc-do-grab-rectangle top bot arg) | |
3461 | ) | |
3462 | ||
3463 | (defun calc-grab-sum-down (top bot arg) | |
3464 | "Parse a rectangle as a matrix of numbers and sum its columns." | |
3465 | (interactive "r\nP") | |
3466 | (calc-extensions) | |
3467 | (calc-do-grab-rectangle top bot arg 'calcFunc-reduced) | |
3468 | ) | |
3469 | ||
3470 | (defun calc-grab-sum-across (top bot arg) | |
3471 | "Parse a rectangle as a matrix of numbers and sum its rows." | |
3472 | (interactive "r\nP") | |
3473 | (calc-extensions) | |
3474 | (calc-do-grab-rectangle top bot arg 'calcFunc-reducea) | |
3475 | ) | |
3476 | ||
3477 | ||
3478 | ;;;###autoload | |
3479 | (defun calc-embedded (arg &optional end obeg oend) | |
3480 | "Start Calc Embedded mode on the formula surrounding point." | |
3481 | (interactive "P") | |
3482 | (calc-extensions) | |
3483 | (calc-do-embedded arg end obeg oend) | |
3484 | ) | |
3485 | ||
3486 | ;;;###autoload | |
3487 | (defun calc-embedded-activate (&optional arg cbuf) | |
3488 | "Scan the current editing buffer for all embedded := and => formulas. | |
3489 | Also looks for the equivalent TeX words, \\gets and \\evalto." | |
3490 | (interactive "P") | |
3491 | (calc-do-embedded-activate arg cbuf) | |
3492 | ) | |
3493 | ||
3494 | ||
3495 | (defun calc-user-invocation () | |
3496 | (interactive) | |
3497 | (or (stringp calc-invocation-macro) | |
3498 | (error "Use `Z I' inside Calc to define a `M-# Z' keyboard macro")) | |
3499 | (execute-kbd-macro calc-invocation-macro nil) | |
3500 | ) | |
3501 | ||
3502 | ||
3503 | ||
3504 | ||
3505 | ;;; User-programmability. | |
3506 | ||
3507 | ;;;###autoload | |
3508 | (defmacro defmath (func args &rest body) ; [Public] | |
3509 | (calc-extensions) | |
3510 | (math-do-defmath func args body) | |
3511 | ) | |
3512 | ||
3513 | ||
3514 | ;;; Functions needed for Lucid Emacs support. | |
3515 | ||
3516 | (defun calc-read-key (&optional optkey) | |
3517 | (cond (calc-emacs-type-lucid | |
3518 | (let ((event (next-command-event))) | |
3519 | (let ((key (event-to-character event t t))) | |
3520 | (or key optkey (error "Expected a plain keystroke")) | |
3521 | (cons key event)))) | |
3522 | (calc-emacs-type-gnu19 | |
3523 | (let ((key (read-event))) | |
3524 | (cons key key))) | |
3525 | (t | |
3526 | (let ((key (read-char))) | |
3527 | (cons key key)))) | |
3528 | ) | |
3529 | ||
3530 | (defun calc-unread-command (&optional input) | |
3531 | (cond (calc-emacs-type-gnu19 | |
3532 | (setq unread-command-events (cons (or input last-command-event) | |
3533 | unread-command-events))) | |
3534 | (calc-emacs-type-lucid | |
3535 | (setq unread-command-event | |
3536 | (if (integerp input) (character-to-event input) | |
3537 | (or input last-command-event)))) | |
3538 | (t | |
3539 | (setq unread-command-char (or input last-command-char)))) | |
3540 | ) | |
3541 | ||
3542 | (defun calc-clear-unread-commands () | |
3543 | (cond (calc-emacs-type-gnu19 (setq unread-command-events nil)) | |
3544 | (calc-emacs-type-lucid (setq unread-command-event nil)) | |
3545 | (t (setq unread-command-char -1))) | |
3546 | ) | |
3547 | ||
3548 | (if calc-always-load-extensions | |
3549 | (progn | |
3550 | (calc-extensions) | |
3551 | (calc-load-everything)) | |
3552 | ) | |
3553 | ||
3554 | ||
3555 | (run-hooks 'calc-load-hook) | |
3556 | ||
3557 |