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