cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc.el

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