40785
|
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
|