lisp/calculator.el

   1 ;;; calculator.el --- A simple pocket calculator.
   2
   3 ;; Copyright (C) 1998 by Free Software Foundation, Inc.
   4
   5 ;; Author: Eli Barzilay <eli@lambda.cs.cornell.edu>
   6 ;; Keywords: tools, convenience
   7 ;; Time-stamp: <2000-02-16 21:07:54 eli>
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by the
  13 ;; Free Software Foundation; either version 2, or (at your option) any
  14 ;; later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  24 ;; MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; A simple pocket calculator for Emacs.
  29 ;; Why touch your mouse to get xcalc (or calc.exe), when you have Emacs?
  30 ;;
  31 ;; If this is not part of your Emacs distribution, then simply bind
  32 ;; `calculator' to a key and make it an autoloaded function, e.g.:
  33 ;;   (autoload 'calculator "calculator"
  34 ;;     "Run the pocket calculator." t)
  35 ;;   (global-set-key [(control return)] 'calculator)
  36 ;;
  37 ;; Written by Eli Barzilay: Maze is Life!  eli@cs.cornell.edu
  38 ;;                                         http://www.cs.cornell.edu/eli
  39 ;;
  40 ;; For latest version, check
  41 ;;     http://www.cs.cornell.edu/eli/misc/calculator.el
  42
  43
  44 (eval-and-compile
  45   (if (fboundp 'defgroup) nil
  46     (defmacro defgroup (&rest forms) nil)
  47     (defmacro defcustom (s v d &rest r) (list 'defvar s v d))))
  48
  49 ;;; Customization:
  50
  51 (defgroup calculator nil
  52   "Simple pocket calculator."
  53   :prefix "calculator"
  54   :version "21.1"
  55   :group 'tools
  56   :group 'convenience)
  57
  58 (defcustom calculator-electric-mode nil
  59   "*Run `calculator' electrically, in the echo area.
  60 Note that if you use electric-mode, you wouldn't be able to use
  61 conventional help keys."
  62   :type  'boolean
  63   :group 'calculator)
  64
  65 (defcustom calculator-use-menu t
  66   "*Make `calculator' create a menu.
  67 Note that this requires easymenu.  Must be set before loading."
  68   :type  'boolean
  69   :group 'calculator)
  70
  71 (defcustom calculator-bind-escape nil
  72   "*If non-nil, set escape to exit the calculator."
  73   :type  'boolean
  74   :group 'calculator)
  75
  76 (defcustom calculator-unary-style 'postfix
  77   "*Value is either 'prefix or 'postfix.
  78 This determines the default behavior of unary operators."
  79   :type    '(choice (const prefix) (const postfix))
  80   :group   'calculator)
  81
  82 (defcustom calculator-prompt "Calculator=%s> "
  83   "*The prompt used by the pocket calculator.
  84 It should contain a \"%s\" somewhere that will indicate the i/o radixes,
  85 this string will be a two-character string as described in the
  86 documentation for `calculator-mode'."
  87   :type  'string
  88   :group 'calculator)
  89
  90 (defcustom calculator-epsilon 1e-15
  91   "*A threshold for results.
  92 If any result computed in `calculator-funcall' is smaller than this in
  93 its absolute value, then zero will be returned."
  94   :type  'number
  95   :group 'calculator)
  96
  97 (defcustom calculator-number-format "%1.3f"
  98   "*The calculator's string used to display normal numbers."
  99   :type  'string
 100   :group 'calculator)
 101
 102 (defcustom calculator-number-exp-ulimit 1e16
 103   "*The calculator's upper limit for normal numbers."
 104   :type  'number
 105   :group 'calculator)
 106
 107 (defcustom calculator-number-exp-llimit 0.001
 108   "*The calculator's lower limit for normal numbers."
 109   :type  'number
 110   :group 'calculator)
 111
 112 (defcustom calculator-number-exp-format "%g"
 113   "*The calculator's string used to display exponential numbers."
 114   :type  'string
 115   :group 'calculator)
 116
 117 (defcustom calculator-show-integers t
 118   "*Non-nil value means delete all zero digits after the decimal point."
 119   :type  'boolean
 120   :group 'calculator)
 121
 122 (defcustom calculator-2s-complement nil
 123   "*If non-nil, show negative numbers in 2s complement in radix modes.
 124 Otherwise show as a negative number."
 125   :type  'boolean
 126   :group 'calculator)
 127
 128 (defcustom calculator-mode-hook nil
 129   "*List of hook functions run by `calculator-mode'."
 130   :type  'hook
 131   :group 'calculator)
 132
 133 (defcustom calculator-user-registers nil
 134   "*An association list of user-defined register bindings.
 135
 136 Each element in this list is a list of a character and a number that
 137 will be stored in that character's register.
 138
 139 For example, use this to define the golden ratio number:
 140   (setq calculator-user-registers '((?g .  1.61803398875)))"
 141   :type  '(repeat (cons character number))
 142   :set   '(lambda (_ val)
 143             (and (boundp 'calculator-registers)
 144                  (setq calculator-registers
 145                        (append val calculator-registers)))
 146             (setq calculator-user-registers val))
 147   :group 'calculator)
 148
 149 (defcustom calculator-user-operators nil
 150   "*A list of additional operators.
 151
 152 This is a list in the same format as specified in the documentation for
 153 `calculator-operators', that you can use to bind additional calculator
 154 operators.  It is probably not a good idea to modify this value with
 155 `customize' since it is too complex...
 156
 157 Examples:
 158
 159 * A very simple one, adding a postfix \"x-to-y\" conversion keys, using
 160   t as a prefix key:
 161
 162   (setq calculator-user-operators
 163         '((\"tf\" cl-to-fr (+ 32 (/ (* X 9) 5)) 1)
 164           (\"tc\" fr-to-cl (/ (* (- X 32) 5) 9) 1)
 165           (\"tp\" kg-to-lb (/ X 0.453592)       1)
 166           (\"tk\" lb-to-kg (* X 0.453592)       1)
 167           (\"tF\" mt-to-ft (/ X 0.3048)         1)
 168           (\"tM\" ft-to-mt (* X 0.3048)         1)))
 169
 170 * Using a function-like form is very simple, X for an argument (Y the
 171   second in case of a binary operator), TX is a truncated version of X
 172   and F does a recursive call, Here is a [very inefficient] Fibonacci
 173   number calculation:
 174
 175   (add-to-list 'calculator-user-operators
 176                '(\"F\" fib (if (<= TX 1)
 177                            1
 178                            (+ (F (- TX 1)) (F (- TX 2)))) 0))
 179
 180   Note that this will be either postfix or prefix, according to
 181   `calculator-unary-style'."
 182   :type  '(repeat (list string symbol sexp integer integer))
 183   :group 'calculator)
 184
 185 ;;; Code:
 186
 187 (defvar calculator-initial-operators
 188   '(;; "+"/"-" have keybindings of themselves, not calculator-ops
 189     ("=" =     identity        1 -1)
 190     (nobind "+" +  +         2  4)
 191     (nobind "-" -  -         2  4)
 192     (nobind "+" +  +        -1  9)
 193     (nobind "-" -  -        -1  9)
 194     ("(" \(    identity       -1 -1)
 195     (")" \)    identity       +1 10)
 196     ;; normal keys
 197     ("|"  or   (logior TX TY)  2  2)
 198     ("#"  xor  (logxor TX TY)  2  2)
 199     ("&"  and  (logand TX TY)  2  3)
 200     ("*"  *    *               2  5)
 201     ("/"  /    /               2  5)
 202     ("\\" div  (/ TX TY)       2  5)
 203     ("%"  rem  (% TX TY)       2  5)
 204     ("L"  log  log             2  6)
 205     ("S"  sin  (sin DX)        x  6)
 206     ("C"  cos  (cos DX)        x  6)
 207     ("T"  tan  (tan DX)        x  6)
 208     ("IS" asin (D (asin X))    x  6)
 209     ("IC" acos (D (acos X))    x  6)
 210     ("IT" atan (D (atan X))    x  6)
 211     ("Q"  sqrt sqrt            x  7)
 212     ("^"  ^    expt            2  7)
 213     ("!"  !    calculator-fact x  7)
 214     (";"  1/   (/ 1 X)         1  7)
 215     ("_"  -    -               1  8)
 216     ("~"  ~    (lognot TX)     x  8)
 217     (">"  repR calculator-repR 1  8)
 218     ("<"  repL calculator-repL 1  8)
 219     ("v"  avg  (/ (apply '+ L) (length L)) 0 8)
 220     ("l"  tot  (apply '+ L)    0 8)
 221     )
 222   "A list of initial operators.
 223
 224 This is a list in the same format as `calculator-operators'.  Whenever
 225 `calculator' starts, it looks at the value of this variable, and if it
 226 is not empty, its contents is prepended to `calculator-operators' and
 227 the appropriate key bindings are made.
 228
 229 This variable is then reset to nil.  Don't use this if you want to add
 230 user-defined operators, use `calculator-user-operators' instead.")
 231
 232 (defvar calculator-operators nil
 233   "The calculator operators, each a list with:
 234
 235 1. The key that is bound to for this operation (usually a string);
 236
 237 2. The displayed symbol for this function;
 238
 239 3. The function symbol, or a form that uses the variables `X' and `Y',
 240    (if it is a binary operator), `TX' and `TY' (truncated integer
 241    versions), `DX' (converted to radians if degrees mode is on), `D'
 242    (function for converting radians to degrees if deg mode is on), `L'
 243    (list of saved values), `F' (function for recursive iteration calls)
 244    and evaluates to the function value - these variables are capital;
 245
 246 4. The function's arity, optional, one of: 2=binary, -1=prefix unary,
 247    +1=postfix unary, 0=a 0-arg operator func, non-number=postfix/prefix
 248    as determined by `calculator-unary-style' (the default);
 249
 250 5. The function's precedence - should be in the range of 1=lowest to
 251    9=highest (optional, defaults to 1);
 252
 253 It it possible have a unary prefix version of a binary operator if it
 254 comes later in this list.  If the list begins with the symbol 'nobind,
 255 then no key binding will take place - this is only useful for predefined
 256 keys.
 257
 258 Use `calculator-user-operators' to add operators to this list, see its
 259 documentation for an example.")
 260
 261 (defvar calculator-stack nil
 262   "Stack contents - operations and operands.")
 263
 264 (defvar calculator-curnum nil
 265   "Current number being entered (as a string).")
 266
 267 (defvar calculator-stack-display nil
 268   "Cons of the stack and its string representation.")
 269
 270 (defvar calculator-char-radix
 271   '((?D . nil) (?B . bin) (?O . oct) (?H . hex) (?X . hex))
 272   "A table to convert input characters to corresponding radix symbols.")
 273
 274 (defvar calculator-output-radix nil
 275   "The mode for display, one of: nil (decimal), 'bin, 'oct or 'hex.")
 276
 277 (defvar calculator-input-radix nil
 278   "The mode for input, one of: nil (decimal), 'bin, 'oct or 'hex.")
 279
 280 (defvar calculator-deg nil
 281   "Non-nil if trig functions operate on degrees instead of radians.")
 282
 283 (defvar calculator-saved-list nil
 284   "A list of saved values collected.")
 285
 286 (defvar calculator-saved-ptr 0
 287   "The pointer to the current saved number.")
 288
 289 (defvar calculator-add-saved nil
 290   "Bound to t when a value should be added to the saved-list.")
 291
 292 (defvar calculator-display-fragile nil
 293   "When non-nil, we see something that the next digit should replace.")
 294
 295 (defvar calculator-buffer nil
 296   "The current calculator buffer.")
 297
 298 (defvar calculator-last-opXY nil
 299   "The last binary operation and its arguments.
 300 Used for repeating operations in calculator-repR/L.")
 301
 302 (defvar calculator-registers ; use user-bindings first
 303   (append calculator-user-registers (list (cons ?e e) (cons ?p pi)))
 304   "The association list of calculator register values.")
 305
 306 (defvar calculator-saved-global-map nil
 307   "Saved global key map.")
 308
 309 (defvar calculator-restart-other-mode nil
 310   "Used to hack restarting with the mode electric mode changed.")
 311
 312 (defvar calculator-mode-map nil
 313   "The calculator key map.")
 314
 315 (or calculator-mode-map
 316   (let ((map (make-sparse-keymap)))
 317     (suppress-keymap map t)
 318     (define-key map "i" nil)
 319     (define-key map "o" nil)
 320     (let ((p
 321            '(("("                  "[" "{")
 322              (")"                  "]" "}")
 323              (calculator-op-or-exp "+" "-" [kp-add] [kp-subtract])
 324              (calculator-digit     "0" "1" "2" "3" "4" "5" "6" "7" "8"
 325                                    "9" "a" "b" "c" "d" "f"
 326                                    [kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
 327                                    [kp-5] [kp-6] [kp-7] [kp-8] [kp-9])
 328              (calculator-op        [kp-divide] [kp-multiply])
 329              (calculator-decimal   "." [kp-decimal])
 330              (calculator-exp       "e")
 331              (calculator-dec/deg-mode "D")
 332              (calculator-set-register "s")
 333              (calculator-get-register "g")
 334              (calculator-radix-mode        "H" "X" "O" "B")
 335              (calculator-radix-input-mode  "id" "ih" "ix" "io" "ib"
 336                                            "iD" "iH" "iX" "iO" "iB")
 337              (calculator-radix-output-mode "od" "oh" "ox" "oo" "ob"
 338                                            "oD" "oH" "oX" "oO" "oB")
 339              (calculator-saved-up      [up] [?\C-p])
 340              (calculator-saved-down    [down] [?\C-n])
 341              (calculator-quit          "q" [?\C-g])
 342              ("="                      [enter] [linefeed] [kp-enter]
 343                                        [?\r] [?\n])
 344              (calculator-save-on-list  " " [space])
 345              (calculator-clear-saved   [?\C-c] [(control delete)])
 346              (calculator-save-and-quit [(control return)]
 347                                        [(control kp-enter)])
 348              (calculator-paste         [insert] [(shift insert)])
 349              (calculator-clear         [delete] [?\C-?] [?\C-d])
 350              (calculator-help          [?h] [??] [f1] [help])
 351              (calculator-copy          [(control insert)])
 352              (calculator-backspace     [backspace])
 353              )))
 354       (while p
 355         ;; reverse the keys so first defs come last - makes the more
 356         ;; sensible bindings visible in the menu
 357         (let ((func (car (car p))) (keys (reverse (cdr (car p)))))
 358           (while keys
 359             (define-key map (car keys) func)
 360             (setq keys (cdr keys))))
 361         (setq p (cdr p))))
 362     (if calculator-bind-escape
 363       (progn (define-key map [?\e] 'calculator-quit)
 364              (define-key map [escape] 'calculator-quit))
 365       (define-key map [?\e ?\e ?\e] 'calculator-quit))
 366     ;; make C-h work in text-mode
 367     (or window-system (define-key map [?\C-h] 'calculator-backspace))
 368     ;; set up a menu
 369     (if (and calculator-use-menu (not (boundp 'calculator-menu)))
 370       (let ((radix-selectors
 371              (mapcar (lambda (x)
 372                        `([,(nth 0 x)
 373                           (calculator-radix-mode ,(nth 2 x))
 374                           :style radio
 375                           :keys ,(nth 2 x)
 376                           :selected
 377                           (and
 378                            (eq calculator-input-radix ',(nth 1 x))
 379                            (eq calculator-output-radix ',(nth 1 x)))]
 380                          [,(concat (nth 0 x) " Input")
 381                           (calculator-radix-input-mode ,(nth 2 x))
 382                           :keys ,(concat "i" (downcase (nth 2 x)))
 383                           :style radio
 384                           :selected
 385                           (eq calculator-input-radix ',(nth 1 x))]
 386                          [,(concat (nth 0 x) " Output")
 387                           (calculator-radix-output-mode ,(nth 2 x))
 388                           :keys ,(concat "o" (downcase (nth 2 x)))
 389                           :style radio
 390                           :selected
 391                           (eq calculator-output-radix ',(nth 1 x))]))
 392                      '(("Decimal"     nil "D")
 393                        ("Binary"      bin "B")
 394                        ("Octal"       oct "O")
 395                        ("Hexadecimal" hex "H"))))
 396             (op '(lambda (name key)
 397                         `[,name (calculator-op ,key) :keys ,key])))
 398         (easy-menu-define
 399          calculator-menu map "Calculator menu."
 400          `("Calculator"
 401            ["Help"
 402             (let ((last-command 'calculator-help)) (calculator-help))
 403             :keys "?"]
 404            "---"
 405            ["Copy"  calculator-copy]
 406            ["Paste" calculator-paste]
 407            "---"
 408            ["Electric mode"
 409             (progn (calculator-quit)
 410                    (setq calculator-restart-other-mode t)
 411                    (run-with-timer 0.1 nil '(lambda () (message nil)))
 412                    ;; the message from the menu will be visible,
 413                    ;; couldn't make it go away...
 414                    (calculator))
 415             :active (not calculator-electric-mode)]
 416            ["Normal mode"
 417             (progn (setq calculator-restart-other-mode t)
 418                    (calculator-quit))
 419             :active calculator-electric-mode]
 420            "---"
 421            ("Functions"
 422             ,(funcall op "Repeat-right" ">")
 423             ,(funcall op "Repeat-left"  "<")
 424             "------General------"
 425             ,(funcall op "Reciprocal"   ";")
 426             ,(funcall op "Log"          "L")
 427             ,(funcall op "Square-root"  "Q")
 428             ,(funcall op "Factorial"    "!")
 429             "------Trigonometric------"
 430             ,(funcall op "Sinus"        "S")
 431             ,(funcall op "Cosine"       "C")
 432             ,(funcall op "Tangent"      "T")
 433             ,(funcall op "Inv-Sinus"    "IS")
 434             ,(funcall op "Inv-Cosine"   "IC")
 435             ,(funcall op "Inv-Tangent"  "IT")
 436             "------Bitwise------"
 437             ,(funcall op "Or"           "|")
 438             ,(funcall op "Xor"          "#")
 439             ,(funcall op "And"          "&")
 440             ,(funcall op "Not"          "~"))
 441            ("Saved List"
 442             ["Eval+Save"      calculator-save-on-list]
 443             ["Prev number"    calculator-saved-up]
 444             ["Next number"    calculator-saved-down]
 445             ["Delete current" calculator-clear
 446              :active (and calculator-display-fragile
 447                           calculator-saved-list
 448                           (= (car calculator-stack)
 449                              (nth calculator-saved-ptr
 450                                   calculator-saved-list)))]
 451             ["Delete all" calculator-clear-saved]
 452             "---"
 453             ,(funcall op "List-total"   "l")
 454             ,(funcall op "List-average" "v"))
 455            ("Registers"
 456             ["Get register" calculator-get-register]
 457             ["Set register" calculator-set-register])
 458            ("Modes"
 459             ["Radians"
 460              (progn
 461                (and (or calculator-input-radix calculator-output-radix)
 462                     (calculator-radix-mode "D"))
 463                (and calculator-deg (calculator-dec/deg-mode)))
 464              :keys "D"
 465              :style radio
 466              :selected (not (or calculator-input-radix
 467                                 calculator-output-radix
 468                                 calculator-deg))]
 469             ["Degrees"
 470              (progn
 471                (and (or calculator-input-radix calculator-output-radix)
 472                     (calculator-radix-mode "D"))
 473                (or calculator-deg (calculator-dec/deg-mode)))
 474              :keys "D"
 475              :style radio
 476              :selected (and calculator-deg
 477                             (not (or calculator-input-radix
 478                                      calculator-output-radix)))]
 479             "---"
 480             ,@(mapcar 'car radix-selectors)
 481             ("Seperate I/O"
 482              ,@(mapcar (lambda (x) (nth 1 x)) radix-selectors)
 483              "---"
 484              ,@(mapcar (lambda (x) (nth 2 x)) radix-selectors)))
 485            "---"
 486            ["Copy+Quit" calculator-save-and-quit]
 487            ["Quit"      calculator-quit]))))
 488     (setq calculator-mode-map map)))
 489
 490 (defun calculator-mode ()
 491   "A simple pocket calculator in Emacs.
 492
 493 This calculator is used in the same way as other popular calculators
 494 like xcalc or calc.exe - but using an Emacs interface.
 495
 496 Expressions are entered using normal infix notation, parens are used as
 497 normal.  Unary functions are usually postfix, but some depends on the
 498 value of `calculator-unary-style' (if the style for an operator below is
 499 specified, then it is fixed, otherwise it depends on this variable).
 500 `+' and `-' can be used as either binary operators or prefix unary
 501 operators.  Numbers can be entered with exponential notation using `e',
 502 except when using a non-decimal radix mode for input (in this case `e'
 503 will be the hexadecimal digit).
 504
 505 Here are the editing keys:
 506 * `RET' `='      evaluate the current expression
 507 * `C-insert'     copy the whole current expression to the `kill-ring'
 508 * `C-return'     evaluate, save result the `kill-ring' and exit
 509 * `insert'       paste a number if the one was copied (normally)
 510 * `delete' `C-d' clear last argument or whole expression (hit twice)
 511 * `backspace'    delete a digit or a previous expression element
 512 * `h' `?'        pop-up a quick reference help
 513 * `ESC' `q'      exit (`ESC' can be used if `calculator-bind-escape' is
 514                  non-nil, otherwise use three consecutive `ESC's)
 515
 516 These operators are pre-defined:
 517 * `+' `-' `*' `/' the common binary operators
 518 * `\\' `%'         integer division and reminder
 519 * `_' `;'         postfix unary negation and reciprocal
 520 * `^' `L'         binary operators for x^y and log(x) in base y
 521 * `Q' `!'         unary square root and factorial
 522 * `S' `C' `T'     unary trigonometric operators - sin, cos and tan
 523 * `|' `#' `&' `~' bitwise operators - or, xor, and, not
 524
 525 The trigonometric functions can be inverted if prefixed with an `I', see
 526 below for the way to use degrees instead of the default radians.
 527
 528 Two special postfix unary operators are `>' and `<': whenever a binary
 529 operator is performed, it is remembered along with its arguments; then
 530 `>' (`<') will apply the same operator with the same right (left)
 531 argument.
 532
 533 hex/oct/bin modes can be set for input and for display separately.
 534 Another toggle-able mode is for using degrees instead of radians for
 535 trigonometric functions.
 536 The keys to switch modes are (`X' is shortcut for `H'):
 537 * `D'             switch to all-decimal mode, or toggle degrees/radians
 538 * `B' `O' `H' `X' binary/octal/hexadecimal modes for input & display
 539 * `i' `o'         followed by one of `D' `B' `O' `H' `X' (case
 540                   insensitive) sets only the input or display radix mode
 541 The prompt indicates the current modes:
 542 * \"D=\": degrees mode;
 543 * \"?=\": (? is B/O/H) this is the radix for both input and output;
 544 * \"=?\": (? is B/O/H) the display radix (when input is decimal);
 545 * \"??\": (? is D/B/O/H) 1st char for input radix, 2nd for display.
 546
 547 Values can be saved for future reference in either a list of saved
 548 values, or in registers.
 549
 550 The list of saved values is useful for statistics operations on some
 551 collected data.  It is possible to navigate in this list, and if the
 552 value shown is the current one on the list, an indication is displayed
 553 as \"[N]\" if this is the last number and there are N numbers, or
 554 \"[M/N]\" if the M-th value is shown.
 555 * `SPC'            evaluate the current value as usual, but also adds
 556                    the result to the list of saved values
 557 * `l' `v'          computes total / average of saved values
 558 * `up' `C-p'       browse to the previous value in the list
 559 * `down' `C-n'     browse to the next value in the list
 560 * `delete' `C-d'   remove current value from the list (if it is on it)
 561 * `C-delete' `C-c' delete the whole list
 562
 563 Registers are variable-like place-holders for values:
 564 * `s' followed by a character attach the current value to that character
 565 * `g' followed by a character fetches the attached value
 566
 567 There are many variables that can be used to customize the calculator.
 568 Some interesting customization variables are:
 569 * `calculator-electric-mode'  use only the echo-area electrically.
 570 * `calculator-unary-style'    set most unary ops to pre/postfix style.
 571 * `calculator-user-registers' to define user-preset registers.
 572 * `calculator-user-operators' to add user-defined operators.
 573 See the documentation for these variables, and \"calculator.el\" for
 574 more information.
 575
 576 \\{calculator-mode-map}"
 577   (interactive)
 578   (kill-all-local-variables)
 579   (setq major-mode 'calculator-mode)
 580   (setq mode-name "Calculator")
 581   (use-local-map calculator-mode-map)
 582   (run-hooks 'calculator-mode-hook))
 583
 584 ;;;###autoload
 585 (defun calculator ()
 586   "Run the pocket calculator.
 587 See the documentation for `calculator-mode' for more information."
 588   (interactive)
 589   (if calculator-restart-other-mode
 590     (setq calculator-electric-mode (not calculator-electric-mode)))
 591   (if calculator-initial-operators
 592     (progn (calculator-add-operators calculator-initial-operators)
 593            (setq calculator-initial-operators nil)
 594            ;; don't change this since it is a customization variable,
 595            ;; its set function will add any new operators.
 596            (calculator-add-operators calculator-user-operators)))
 597   (if calculator-electric-mode
 598     (save-window-excursion
 599       (progn (require 'electric) (message nil)) ; hide load message
 600       (let (old-g-map old-l-map (echo-keystrokes 0)
 601             (garbage-collection-messages nil)) ; no gc msg when electric
 602         ;; strange behavior in FSF: doesn't always select correct
 603         ;; minibuffer.  I have no idea how to fix this
 604         (setq calculator-buffer (window-buffer (minibuffer-window)))
 605         (select-window (minibuffer-window))
 606         (calculator-reset)
 607         (calculator-update-display)
 608         (setq old-l-map (current-local-map))
 609         (setq old-g-map (current-global-map))
 610         (setq calculator-saved-global-map (current-global-map))
 611         (use-local-map nil)
 612         (use-global-map calculator-mode-map)
 613         (unwind-protect
 614             (catch 'calculator-done
 615               (Electric-command-loop
 616                'calculator-done
 617                ;; can't use 'noprompt, bug in electric.el
 618                '(lambda () 'noprompt)
 619                nil
 620                (lambda (x y) (calculator-update-display))))
 621           (and calculator-buffer
 622                (catch 'calculator-done (calculator-quit)))
 623           (use-local-map old-l-map)
 624           (use-global-map old-g-map))))
 625     (progn
 626       (setq calculator-buffer
 627             (or (and (bufferp calculator-buffer)
 628                      (buffer-live-p calculator-buffer)
 629                      calculator-buffer)
 630                 (if calculator-electric-mode
 631                   (get-buffer-create "*calculator*")
 632                   (let ((split-window-keep-point nil)
 633                         (window-min-height 2))
 634                     (select-window
 635                      ;; Maybe leave two lines for our window because
 636                      ;; of the normal `raised' modeline in Emacs 21.
 637                      (split-window-vertically
 638                       (- (window-height)
 639                          (if (plist-get (face-attr-construct 'modeline)
 640                                         :box)
 641                              3
 642                            2))))
 643                     (switch-to-buffer
 644                      (get-buffer-create "*calculator*"))))))
 645       (set-buffer calculator-buffer)
 646       (calculator-mode)
 647       (setq buffer-read-only t)
 648       (calculator-reset)
 649       (message "Hit `?' For a quick help screen.")))
 650   (if (and calculator-restart-other-mode calculator-electric-mode)
 651     (calculator)))
 652
 653 (defun calculator-op-arity (op)
 654   "Return OP's arity, 2, +1 or -1."
 655   (let ((arity (or (nth 3 op) 'x)))
 656     (if (numberp arity)
 657       arity
 658       (if (eq calculator-unary-style 'postfix) +1 -1))))
 659
 660 (defun calculator-op-prec (op)
 661   "Return OP's precedence for reducing when inserting into the stack.
 662 Defaults to 1."
 663   (or (nth 4 op) 1))
 664
 665 (defun calculator-add-operators (more-ops)
 666   "This function handles operator addition.
 667 Adds MORE-OPS to `calculator-operator', called initially to handle
 668 `calculator-initial-operators' and `calculator-user-operators'."
 669   (let ((added-ops nil))
 670     (while more-ops
 671       (or (eq (car (car more-ops)) 'nobind)
 672           (let ((i -1) (key (car (car more-ops))))
 673             ;; make sure the key is undefined, so it's easy to define
 674             ;; prefix keys
 675             (while (< (setq i (1+ i)) (length key))
 676               (or (keymapp
 677                    (lookup-key calculator-mode-map
 678                                (substring key 0 (1+ i))))
 679                   (progn
 680                     (define-key
 681                       calculator-mode-map (substring key 0 (1+ i)) nil)
 682                     (setq i (length key)))))
 683             (define-key calculator-mode-map key 'calculator-op)))
 684       (setq added-ops (cons (if (eq (car (car more-ops)) 'nobind)
 685                               (cdr (car more-ops))
 686                               (car more-ops))
 687                             added-ops))
 688       (setq more-ops (cdr more-ops)))
 689     ;; added-ops come first, but in correct order
 690     (setq calculator-operators
 691           (append (nreverse added-ops) calculator-operators))))
 692
 693 (defun calculator-reset ()
 694   "Reset calculator variables."
 695   (or calculator-restart-other-mode
 696       (setq calculator-stack           nil
 697             calculator-curnum          nil
 698             calculator-stack-display   nil
 699             calculator-display-fragile nil))
 700   (setq calculator-restart-other-mode nil)
 701   (calculator-update-display))
 702
 703 (defun calculator-get-prompt ()
 704   "Return a string to display.
 705 The string is set not to exceed the screen width."
 706   (let* ((calculator-prompt
 707           (format calculator-prompt
 708                   (cond
 709                     ((or calculator-output-radix calculator-input-radix)
 710                      (if (eq calculator-output-radix
 711                              calculator-input-radix)
 712                        (concat
 713                         (char-to-string
 714                          (car (rassq calculator-output-radix
 715                                      calculator-char-radix)))
 716                         "=")
 717                        (concat
 718                         (if calculator-input-radix
 719                           (char-to-string
 720                            (car (rassq calculator-input-radix
 721                                        calculator-char-radix)))
 722                           "=")
 723                         (char-to-string
 724                          (car (rassq calculator-output-radix
 725                                      calculator-char-radix))))))
 726                     (calculator-deg "D=")
 727                     (t "=="))))
 728          (prompt
 729           (concat calculator-prompt
 730                   (cdr calculator-stack-display)
 731                   (cond (calculator-curnum
 732                          ;; number being typed
 733                          (concat calculator-curnum "_"))
 734                         ((and (= 1 (length calculator-stack))
 735                               calculator-display-fragile)
 736                          ;; only the result is shown, next number will
 737                          ;; restart
 738                          nil)
 739                         (t
 740                          ;; waiting for a number or an operator
 741                          "?"))))
 742          (trim (- (length prompt) (1- (window-width)))))
 743     (if (<= trim 0)
 744       prompt
 745       (concat calculator-prompt
 746               (substring prompt (+ trim (length calculator-prompt)))))))
 747
 748 (defun calculator-curnum-value ()
 749   "Get the numeric value of the displayed number string as a float."
 750   (if calculator-input-radix
 751     (let ((radix
 752            (cdr (assq calculator-input-radix
 753                       '((bin . 2) (oct . 8) (hex . 16)))))
 754           (i -1) (value 0))
 755       ;; assume valid input (upcased & characters in range)
 756       (while (< (setq i (1+ i)) (length calculator-curnum))
 757         (setq value
 758               (+ (let ((ch (aref calculator-curnum i)))
 759                    (- ch (if (<= ch ?9) ?0 (- ?A 10))))
 760                  (* radix value))))
 761       value)
 762     (car
 763      (read-from-string
 764       (cond
 765         ((equal "." calculator-curnum)
 766          "0.0")
 767         ((string-match "[eE][+-]?$" calculator-curnum)
 768          (concat calculator-curnum "0"))
 769         ((string-match "\\.[0-9]\\|[eE]" calculator-curnum)
 770          calculator-curnum)
 771         ((string-match "\\." calculator-curnum)
 772          ;; do this because Emacs reads "23." as an integer.
 773          (concat calculator-curnum "0"))
 774         ((stringp calculator-curnum)
 775          (concat calculator-curnum ".0"))
 776         (t "0.0"))))))
 777
 778 (defun calculator-num-to-string (num)
 779   "Convert NUM to a displayable string."
 780   (cond
 781     ((and (numberp num) calculator-output-radix)
 782      ;; print with radix - for binary I convert the octal number
 783      (let ((str (format (if (eq calculator-output-radix 'hex) "%x" "%o")
 784                         (calculator-truncate
 785                          (if calculator-2s-complement num (abs num))))))
 786        (if (eq calculator-output-radix 'bin)
 787          (let ((i -1) (s ""))
 788            (while (< (setq i (1+ i)) (length str))
 789              (setq s
 790                    (concat s
 791                            (cdr (assq (aref str i)
 792                                       '((?0 . "000") (?1 . "001")
 793                                         (?2 . "010") (?3 . "011")
 794                                         (?4 . "100") (?5 . "101")
 795                                         (?6 . "110") (?7 . "111")))))))
 796            (string-match "^0*\\(.+\\)" s)
 797            (setq str (match-string 1 s))))
 798        (upcase
 799         (if (and (not calculator-2s-complement) (< num 0))
 800           (concat "-" str)
 801           str))))
 802     ((and (numberp num)
 803           ;; is this a normal-range number?
 804           (>= (abs num) calculator-number-exp-llimit)
 805           (< (abs num) calculator-number-exp-ulimit))
 806      (let ((str (format calculator-number-format num)))
 807        (cond
 808          ((and calculator-show-integers (string-match "\\.?0+$" str))
 809           ;; remove all redundant zeros
 810           (substring str 0 (match-beginning 0)))
 811          ((and (not calculator-show-integers)
 812                (string-match "\\..\\(.*[^0]\\)?\\(0+\\)$" str))
 813           ;; remove zeros, except for first after the "."
 814           (substring str 0 (match-beginning 2)))
 815          (t str))))
 816     ((numberp num) (format calculator-number-exp-format num))
 817     (t (prin1-to-string (nth 1 num) t))))
 818
 819 (defun calculator-update-display (&optional force)
 820   "Update the display.
 821 If optional argument FORCE is non-nil, don't use the cached string."
 822   (set-buffer calculator-buffer)
 823   ;; update calculator-stack-display
 824   (if (or force
 825           (not (eq (car calculator-stack-display) calculator-stack)))
 826     (setq calculator-stack-display
 827           (cons calculator-stack
 828                 (if calculator-stack
 829                   (concat
 830                    (mapconcat 'calculator-num-to-string
 831                               (reverse calculator-stack)
 832                               " ")
 833                    " "
 834                    (and calculator-display-fragile
 835                         calculator-saved-list
 836                         (= (car calculator-stack)
 837                            (nth calculator-saved-ptr
 838                                 calculator-saved-list))
 839                         (if (= 0 calculator-saved-ptr)
 840                           (format "[%s]" (length calculator-saved-list))
 841                           (format "[%s/%s]"
 842                                   (- (length calculator-saved-list)
 843                                      calculator-saved-ptr)
 844                                   (length calculator-saved-list)))))
 845                   ""))))
 846   (let ((inhibit-read-only t))
 847     (erase-buffer)
 848     (insert (calculator-get-prompt)))
 849   (set-buffer-modified-p nil)
 850   (if calculator-display-fragile
 851     (goto-char (1+ (length calculator-prompt)))
 852     (goto-char (1- (point)))))
 853
 854 (defun calculator-reduce-stack (prec)
 855   "Reduce the stack using top operator.
 856 PREC is a precedence - reduce everything with higher precedence."
 857   (while
 858       (cond
 859         ((and (cdr (cdr calculator-stack))         ; have three values
 860               (consp   (nth 0 calculator-stack))   ; two operators & num
 861               (numberp (nth 1 calculator-stack))
 862               (consp   (nth 2 calculator-stack))
 863               (eq '\) (nth 1 (nth 0 calculator-stack)))
 864               (eq '\( (nth 1 (nth 2 calculator-stack))))
 865          ;; reduce "... ( x )" --> "... x"
 866          (setq calculator-stack
 867                (cons (nth 1 calculator-stack)
 868                      (nthcdr 3 calculator-stack)))
 869          ;; another iteration
 870          t)
 871         ((and (cdr (cdr calculator-stack))         ; have three values
 872               (numberp (nth 0 calculator-stack))   ; two nums & operator
 873               (consp   (nth 1 calculator-stack))
 874               (numberp (nth 2 calculator-stack))
 875               (= 2 (calculator-op-arity            ; binary operator
 876                     (nth 1 calculator-stack)))
 877               (<= prec                             ; with higher prec.
 878                   (calculator-op-prec (nth 1 calculator-stack))))
 879          ;; reduce "... x op y" --> "... r", r is the result
 880          (setq calculator-stack
 881                (cons (calculator-funcall
 882                       (nth 2 (nth 1 calculator-stack))
 883                       (nth 2 calculator-stack)
 884                       (nth 0 calculator-stack))
 885                      (nthcdr 3 calculator-stack)))
 886          ;; another iteration
 887          t)
 888         ((and (>= (length calculator-stack) 2)     ; have two values
 889               (numberp (nth 0 calculator-stack))   ; number & operator
 890               (consp   (nth 1 calculator-stack))
 891               (= -1 (calculator-op-arity           ; prefix-unary op
 892                      (nth 1 calculator-stack)))
 893               (<= prec                             ; with higher prec.
 894                   (calculator-op-prec (nth 1 calculator-stack))))
 895          ;; reduce "... op x" --> "... r" for prefix op
 896          (setq calculator-stack
 897                (cons (calculator-funcall
 898                       (nth 2 (nth 1 calculator-stack))
 899                       (nth 0 calculator-stack))
 900                      (nthcdr 2 calculator-stack)))
 901          ;; another iteration
 902          t)
 903         ((and (cdr calculator-stack)               ; have two values
 904               (consp   (nth 0 calculator-stack))   ; operator & number
 905               (numberp (nth 1 calculator-stack))
 906               (= +1 (calculator-op-arity           ; postfix-unary op
 907                      (nth 0 calculator-stack)))
 908               (<= prec                             ; with higher prec.
 909                   (calculator-op-prec (nth 0 calculator-stack))))
 910          ;; reduce "... x op" --> "... r" for postfix op
 911          (setq calculator-stack
 912                (cons (calculator-funcall
 913                       (nth 2 (nth 0 calculator-stack))
 914                       (nth 1 calculator-stack))
 915                      (nthcdr 2 calculator-stack)))
 916          ;; another iteration
 917          t)
 918         ((and calculator-stack                     ; have one value
 919               (consp (nth 0 calculator-stack))     ; an operator
 920               (= 0 (calculator-op-arity            ; 0-ary op
 921                     (nth 0 calculator-stack))))
 922          ;; reduce "... op" --> "... r" for 0-ary op
 923          (setq calculator-stack
 924                (cons (calculator-funcall
 925                       (nth 2 (nth 0 calculator-stack)))
 926                      (nthcdr 1 calculator-stack)))
 927          ;; another iteration
 928          t)
 929         ((and (cdr calculator-stack)               ; have two values
 930               (numberp (nth 0 calculator-stack))   ; both numbers
 931               (numberp (nth 1 calculator-stack)))
 932          ;; get rid of redundant numbers:
 933          ;;   reduce "... y x" --> "... x"
 934          ;; needed for 0-ary ops that puts more values
 935          (setcdr calculator-stack (cdr (cdr calculator-stack))))
 936         (t ;; no more iterations
 937            nil))))
 938
 939 (eval-when-compile ; silence the compiler
 940   (or (fboundp 'event-key)
 941       (defun event-key (&rest _) nil))
 942   (or (fboundp 'key-press-event-p)
 943       (defun key-press-event-p (&rest _) nil)))
 944
 945 (defun calculator-last-input (&optional keys)
 946   "Last char (or event or event sequence) that was read.
 947 Optional string argument KEYS will force using it as the keys entered."
 948   (let ((inp (or keys (this-command-keys))))
 949     (if (or (stringp inp) (not (arrayp inp)))
 950       inp
 951       ;; this translates kp-x to x and [tries to] create a string to
 952       ;; lookup operators
 953       (let* ((i -1) (converted-str (make-string (length inp) ? )) k)
 954         ;; converts an array to a string the ops lookup with keypad
 955         ;; input
 956         (while (< (setq i (1+ i)) (length inp))
 957           (setq k (aref inp i))
 958           ;; if Emacs will someday have a event-key, then this would
 959           ;; probably be modified anyway
 960           (and (fboundp 'event-key) (key-press-event-p k)
 961                (setq k (event-key k)))
 962           ;; assume all symbols are translatable with an ascii-character
 963           (and (symbolp k)
 964                (setq k (or (get k 'ascii-character) ? )))
 965           (aset converted-str i k))
 966         converted-str))))
 967
 968 (defun calculator-clear-fragile (&optional op)
 969   "Clear the fragile flag if it was set, then maybe reset all.
 970 OP is the operator (if any) that caused this call."
 971   (if (and calculator-display-fragile
 972            (or (not op)
 973                (= -1 (calculator-op-arity op))
 974                (= 0 (calculator-op-arity op))))
 975     ;; reset if last calc finished, and now get a num or prefix or 0-ary
 976     ;; op.
 977     (calculator-reset))
 978   (setq calculator-display-fragile nil))
 979
 980 (defun calculator-digit ()
 981   "Enter a single digit."
 982   (interactive)
 983   (let ((inp (aref (calculator-last-input) 0)))
 984     (if (and (or calculator-display-fragile
 985                  (not (numberp (car calculator-stack))))
 986              (cond
 987                ((not calculator-input-radix)     (<= inp ?9))
 988                ((eq calculator-input-radix 'bin) (<= inp ?1))
 989                ((eq calculator-input-radix 'oct) (<= inp ?7))
 990                (t t)))
 991       ;; enter digit if starting a new computation or have an op on the
 992       ;; stack.
 993       (progn
 994         (calculator-clear-fragile)
 995         (let ((digit (upcase (char-to-string inp))))
 996           (if (equal calculator-curnum "0")
 997             (setq calculator-curnum nil))
 998           (setq calculator-curnum
 999                 (concat (or calculator-curnum "") digit)))
1000         (calculator-update-display)))))
1001
1002 (defun calculator-decimal ()
1003   "Enter a decimal period."
1004   (interactive)
1005   (if (and (not calculator-input-radix)
1006            (or calculator-display-fragile
1007                (not (numberp (car calculator-stack))))
1008            (not (and calculator-curnum
1009                      (string-match "[.eE]" calculator-curnum))))
1010     ;; enter the period on the same condition as a digit, only if no
1011     ;; period or exponent entered yet.
1012     (progn
1013       (calculator-clear-fragile)
1014       (setq calculator-curnum (concat (or calculator-curnum "0") "."))
1015       (calculator-update-display))))
1016
1017 (defun calculator-exp ()
1018   "Enter an `E' exponent character, or a digit in hex input mode."
1019   (interactive)
1020   (if calculator-input-radix
1021     (calculator-digit)
1022     (if (and (or calculator-display-fragile
1023                  (not (numberp (car calculator-stack))))
1024              (not (and calculator-curnum
1025                        (string-match "[eE]" calculator-curnum))))
1026       ;; same condition as above, also no E so far.
1027       (progn
1028         (calculator-clear-fragile)
1029         (setq calculator-curnum (concat (or calculator-curnum "1") "e"))
1030         (calculator-update-display)))))
1031
1032 (defun calculator-op (&optional keys)
1033   "Enter an operator on the stack, doing all necessary reductions.
1034 Optional string argument KEYS will force using it as the keys entered."
1035   (interactive)
1036   (let* ((last-inp (calculator-last-input keys))
1037          (op (assoc last-inp calculator-operators)))
1038     (calculator-clear-fragile op)
1039     (if (and calculator-curnum (/= (calculator-op-arity op) 0))
1040       (setq calculator-stack
1041             (cons (calculator-curnum-value) calculator-stack)))
1042     (setq calculator-curnum nil)
1043     (if (and (= 2 (calculator-op-arity op))
1044              (not (and calculator-stack
1045                        (numberp (nth 0 calculator-stack)))))
1046       ;; we have a binary operator but no number - search for a prefix
1047       ;; version
1048       (let ((rest-ops calculator-operators))
1049         (while (not (equal last-inp (car (car rest-ops))))
1050           (setq rest-ops (cdr rest-ops)))
1051         (setq op (assoc last-inp (cdr rest-ops)))
1052         (if (not (and op (= -1 (calculator-op-arity op))))
1053           (error "Binary operator without a first operand"))))
1054     (calculator-reduce-stack
1055      (cond ((eq (nth 1 op) '\() 10)
1056            ((eq (nth 1 op) '\)) 0)
1057            (t (calculator-op-prec op))))
1058     (if (or (and (= -1 (calculator-op-arity op))
1059                  (numberp (car calculator-stack)))
1060             (and (/= (calculator-op-arity op) -1)
1061                  (/= (calculator-op-arity op) 0)
1062                  (not (numberp (car calculator-stack)))))
1063       (error "Unterminated expression"))
1064     (setq calculator-stack (cons op calculator-stack))
1065     (calculator-reduce-stack (calculator-op-prec op))
1066     (and (= (length calculator-stack) 1)
1067          (numberp (nth 0 calculator-stack))
1068          ;; the display is fragile if it contains only one number
1069          (setq calculator-display-fragile t)
1070          ;; add number to the saved-list
1071          calculator-add-saved
1072          (if (= 0 calculator-saved-ptr)
1073            (setq calculator-saved-list
1074                  (cons (car calculator-stack) calculator-saved-list))
1075            (let ((p (nthcdr (1- calculator-saved-ptr)
1076                             calculator-saved-list)))
1077              (setcdr p (cons (car calculator-stack) (cdr p))))))
1078     (calculator-update-display)))
1079
1080 (defun calculator-op-or-exp ()
1081   "Either enter an operator or a digit.
1082 Used with +/- for entering them as digits in numbers like 1e-3."
1083   (interactive)
1084   (if (and (not calculator-display-fragile)
1085            calculator-curnum
1086            (string-match "[eE]$" calculator-curnum))
1087     (calculator-digit)
1088     (calculator-op)))
1089
1090 (defun calculator-dec/deg-mode ()
1091   "Set decimal mode for display & input, if decimal, toggle deg mode."
1092   (interactive)
1093   (if calculator-curnum
1094     (setq calculator-stack
1095           (cons (calculator-curnum-value) calculator-stack)))
1096   (setq calculator-curnum nil)
1097   (if (or calculator-input-radix calculator-output-radix)
1098     (progn (setq calculator-input-radix nil)
1099            (setq calculator-output-radix nil))
1100     ;; already decimal - toggle degrees mode
1101     (setq calculator-deg (not calculator-deg)))
1102   (calculator-update-display t))
1103
1104 (defun calculator-radix-mode (&optional keys)
1105   "Set input and display radix modes.
1106 Optional string argument KEYS will force using it as the keys entered."
1107   (interactive)
1108   (calculator-radix-input-mode keys)
1109   (calculator-radix-output-mode keys))
1110
1111 (defun calculator-radix-input-mode (&optional keys)
1112   "Set input radix modes.
1113 Optional string argument KEYS will force using it as the keys entered."
1114   (interactive)
1115   (if calculator-curnum
1116     (setq calculator-stack
1117           (cons (calculator-curnum-value) calculator-stack)))
1118   (setq calculator-curnum nil)
1119   (setq calculator-input-radix
1120         (let ((inp (calculator-last-input keys)))
1121           (cdr (assq (upcase (aref inp (1- (length inp))))
1122                      calculator-char-radix))))
1123   (calculator-update-display))
1124
1125 (defun calculator-radix-output-mode (&optional keys)
1126   "Set display radix modes.
1127 Optional string argument KEYS will force using it as the keys entered."
1128   (interactive)
1129   (if calculator-curnum
1130     (setq calculator-stack
1131           (cons (calculator-curnum-value) calculator-stack)))
1132   (setq calculator-curnum nil)
1133   (setq calculator-output-radix
1134         (let ((inp (calculator-last-input keys)))
1135           (cdr (assq (upcase (aref inp (1- (length inp))))
1136                      calculator-char-radix))))
1137   (calculator-update-display t))
1138
1139 (defun calculator-save-on-list ()
1140   "Evaluate current expression, put result on the saved values list."
1141   (interactive)
1142   (let ((calculator-add-saved t)) ; marks the result to be added
1143     (calculator-enter)))
1144
1145 (defun calculator-clear-saved ()
1146   "Clear the list of saved values in `calculator-saved-list'."
1147   (interactive)
1148   (setq calculator-saved-list nil)
1149   (calculator-update-display t))
1150
1151 (defun calculator-saved-move (n)
1152   "Go N elements up the list of saved values."
1153   (interactive)
1154   (and calculator-saved-list
1155        (or (null calculator-stack) calculator-display-fragile)
1156        (progn
1157          (setq calculator-saved-ptr
1158                (max (min (+ n calculator-saved-ptr)
1159                          (length calculator-saved-list))
1160                     0))
1161          (if (nth calculator-saved-ptr calculator-saved-list)
1162            (setq calculator-stack
1163                  (list (nth calculator-saved-ptr calculator-saved-list))
1164                  calculator-display-fragile t)
1165            (calculator-reset))
1166          (calculator-update-display))))
1167
1168 (defun calculator-saved-up ()
1169   "Go up the list of saved values."
1170   (interactive)
1171   (calculator-saved-move +1))
1172
1173 (defun calculator-saved-down ()
1174   "Go down the list of saved values."
1175   (interactive)
1176   (calculator-saved-move -1))
1177
1178 (defun calculator-open-paren ()
1179   "Equivalents of `(' use this."
1180   (interactive)
1181   (calculator-op "("))
1182
1183 (defun calculator-close-paren ()
1184   "Equivalents of `)' use this."
1185   (interactive)
1186   (calculator-op ")"))
1187
1188 (defun calculator-enter ()
1189   "Evaluate current expression."
1190   (interactive)
1191   (calculator-op "="))
1192
1193 (defun calculator-backspace ()
1194   "Backward delete a single digit or a stack element."
1195   (interactive)
1196   (if calculator-curnum
1197     (setq calculator-curnum
1198           (if (> (length calculator-curnum) 1)
1199             (substring calculator-curnum
1200                        0 (1- (length calculator-curnum)))
1201             nil))
1202     (setq calculator-stack (cdr calculator-stack)))
1203   (calculator-update-display))
1204
1205 (defun calculator-clear ()
1206   "Clear current number."
1207   (interactive)
1208   (setq calculator-curnum nil)
1209   (cond
1210     ;; if the current number is from the saved-list - remove it
1211     ((and calculator-display-fragile
1212           calculator-saved-list
1213           (= (car calculator-stack)
1214              (nth calculator-saved-ptr calculator-saved-list)))
1215      (if (= 0 calculator-saved-ptr)
1216        (setq calculator-saved-list (cdr calculator-saved-list))
1217        (let ((p (nthcdr (1- calculator-saved-ptr)
1218                         calculator-saved-list)))
1219          (setcdr p (cdr (cdr p)))
1220          (setq calculator-saved-ptr (1- calculator-saved-ptr))))
1221      (if calculator-saved-list
1222        (setq calculator-stack
1223              (list (nth calculator-saved-ptr calculator-saved-list)))
1224        (calculator-reset)))
1225     ;; reset if fragile or double clear
1226     ((or calculator-display-fragile (eq last-command this-command))
1227      (calculator-reset)))
1228   (calculator-update-display))
1229
1230 (defun calculator-copy ()
1231   "Copy current number to the `kill-ring'."
1232   (interactive)
1233   (calculator-enter)
1234   ;; remove trailing .0 and spaces .0
1235   (let ((s (cdr calculator-stack-display)))
1236     (if (string-match "^\\(.*[^ ]\\) *$" s)
1237       (setq s (match-string 1 s)))
1238     (kill-new s)))
1239
1240 (defun calculator-set-register (reg)
1241   "Set a register value for REG."
1242   (interactive "cRegister to store into: ")
1243   (let* ((as  (assq reg calculator-registers))
1244          (val (progn (calculator-enter) (car calculator-stack))))
1245     (if as
1246       (setcdr as val)
1247       (setq calculator-registers
1248             (cons (cons reg val) calculator-registers)))
1249     (message (format "[%c] := %S" reg val))))
1250
1251 (defun calculator-put-value (val)
1252   "Paste VAL as if entered.
1253 Used by `calculator-paste' and `get-register'."
1254   (if (and (numberp val)
1255            ;; (not calculator-curnum)
1256            (or calculator-display-fragile
1257                (not (numberp (car calculator-stack)))))
1258     (progn
1259       (calculator-clear-fragile)
1260       (setq calculator-curnum (calculator-num-to-string val))
1261       (calculator-update-display))))
1262
1263 (defun calculator-paste ()
1264   "Paste a value from the `kill-ring'."
1265   (interactive)
1266   (calculator-put-value
1267    (condition-case nil (car (read-from-string (current-kill 0)))
1268      (error nil))))
1269
1270 (defun calculator-get-register (reg)
1271   "Get a value from a register REG."
1272   (interactive "cRegister to get value from: ")
1273   (calculator-put-value (cdr (assq reg calculator-registers))))
1274
1275 (defun calculator-help ()
1276   ;; this is used as the quick reference screen you get with `h'
1277   "Quick reference:
1278 * numbers/operators/parens/./e - enter expressions
1279   + - * / \\(div) %(rem) _(-X,postfix) ;(1/X,postfix) ^(exp) L(og)
1280   Q(sqrt) !(fact) S(in) C(os) T(an) |(or) #(xor) &(and) ~(not)
1281 * >/< repeats last binary operation with its 2nd (1st) arg as postfix op
1282 * I inverses next trig function
1283 * D         - switch to all-decimal mode, or toggles deg/rad mode
1284 * B/O/H/X   - binary/octal/hex mode for i/o (X is a shortcut for H)
1285 * i/o       - prefix for d/b/o/x - set only input/output modes
1286 * enter/=   - evaluate current expr.   * s/g      - set/get a register
1287 * space     - evaluate & save on list  * l/v      - list total/average
1288 * up/down/C-p/C-n - browse saved       * C-delete - clear all saved
1289 * C-insert  - copy whole expr.         * C-return - evaluate, copy, exit
1290 * insert    - paste a number           * backspace- delete backwards
1291 * delete    - clear argument or list value or whole expression (twice)
1292 * escape/q  - exit."
1293   (interactive)
1294   (if (eq last-command 'calculator-help)
1295     (let ((mode-name "Calculator")
1296           (major-mode 'calculator-mode)
1297           (g-map (current-global-map))
1298           (win (selected-window)))
1299       (require 'ehelp)
1300       (if calculator-electric-mode
1301         (use-global-map calculator-saved-global-map))
1302       (electric-describe-mode)
1303       (if calculator-electric-mode
1304         (use-global-map g-map))
1305       (select-window win) ; these are for XEmacs (also below)
1306       (message nil))
1307     (let ((one (one-window-p t))
1308           (win (selected-window))
1309           (help-buf (get-buffer-create "*Help*")))
1310       (save-window-excursion
1311         (with-output-to-temp-buffer "*Help*"
1312           (princ (documentation 'calculator-help)))
1313         (if one
1314           (shrink-window-if-larger-than-buffer
1315            (get-buffer-window help-buf)))
1316         (message
1317          "`%s' again for more help, any other key continues normally."
1318          (calculator-last-input))
1319         (select-window win)
1320         (sit-for 360))
1321       (select-window win))))
1322
1323 (defun calculator-quit ()
1324   "Quit calculator."
1325   (interactive)
1326   (set-buffer calculator-buffer)
1327   (let ((inhibit-read-only t)) (erase-buffer))
1328   (if (not calculator-electric-mode)
1329     (progn
1330       (condition-case nil
1331           (while (get-buffer-window calculator-buffer)
1332             (delete-window (get-buffer-window calculator-buffer)))
1333         (error nil))
1334       (kill-buffer calculator-buffer)))
1335   (setq calculator-buffer nil)
1336   (message "Calculator done.")
1337   (if calculator-electric-mode (throw 'calculator-done nil)))
1338
1339 (defun calculator-save-and-quit ()
1340   "Quit the calculator, saving the result on the `kill-ring'."
1341   (interactive)
1342   (calculator-enter)
1343   (calculator-copy)
1344   (calculator-quit))
1345
1346 (defun calculator-funcall (f &optional X Y)
1347   "If F is a symbol, evaluate (F X Y).
1348 Otherwise, it should be a list, evaluate it with X, Y bound to the
1349 arguments."
1350   ;; remember binary ops for calculator-repR/L
1351   (if Y (setq calculator-last-opXY (list f X Y)))
1352   (condition-case nil
1353       (let ((result
1354              (if (symbolp f)
1355                (cond ((and X Y) (funcall f X Y))
1356                      (X         (funcall f X))
1357                      (t         (funcall f)))
1358                ;; f is an expression
1359                (let* ((__f__ f) ; so we can get this value below...
1360                       (TX (calculator-truncate X))
1361                       (TY (and Y (calculator-truncate Y)))
1362                       (DX (if calculator-deg (/ (* X pi) 180) X))
1363                       (L  calculator-saved-list)
1364                       (Fbound (fboundp 'F))
1365                       (Fsave  (and Fbound (symbol-function 'F)))
1366                       (Dbound (fboundp 'D))
1367                       (Dsave  (and Dbound (symbol-function 'D))))
1368                  ;; a shortened version of flet
1369                  (fset 'F (function
1370                            (lambda (&optional x y)
1371                              (calculator-funcall __f__ x y))))
1372                  (fset 'D (function
1373                            (lambda (x)
1374                              (if calculator-deg (/ (* x 180) pi) x))))
1375                  (unwind-protect (eval f)
1376                    (if Fbound (fset 'F Fsave) (fmakunbound 'F))
1377                    (if Dbound (fset 'D Dsave) (fmakunbound 'D)))))))
1378         (if (< (abs result) calculator-epsilon)
1379           0
1380           result))
1381     (error 0)))
1382
1383 (defun calculator-repR (x)
1384   "Repeats the last binary operation with its second argument and X.
1385 To use this, apply a binary operator (evaluate it), then call this."
1386   (if calculator-last-opXY
1387     ;; avoid rebinding calculator-last-opXY
1388     (let ((calculator-last-opXY calculator-last-opXY))
1389       (calculator-funcall
1390        (car calculator-last-opXY) x (nth 2 calculator-last-opXY)))
1391     x))
1392
1393 (defun calculator-repL (x)
1394   "Repeats the last binary operation with its first argument and X.
1395 To use this, apply a binary operator (evaluate it), then call this."
1396   (if calculator-last-opXY
1397     ;; avoid rebinding calculator-last-opXY
1398     (let ((calculator-last-opXY calculator-last-opXY))
1399       (calculator-funcall
1400        (car calculator-last-opXY) (nth 1 calculator-last-opXY) x))
1401     x))
1402
1403 (defun calculator-fact (x)
1404   "Simple factorial of X."
1405   (let ((r (if (<= x 10) 1 1.0)))
1406     (while (> x 0)
1407       (setq r (* r (truncate x)))
1408       (setq x (1- x)))
1409     r))
1410
1411 (defun calculator-truncate (n)
1412   "Truncate N, return 0 in case of overflow."
1413   (condition-case nil (truncate n) (error 0)))
1414
1415
1416 (provide 'calculator)
1417
1418 ;;; calculator.el ends here