lisp/calc/calc-misc.el

   1 ;;; calc-misc.el --- miscellaneous functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: David Gillespie <daveg@synaptics.com>
   7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; This file is autoloaded from calc.el.
  29
  30 (require 'calc)
  31 (require 'calc-macs)
  32
  33 ;; Declare functions which are defined elsewhere.
  34 (declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive))
  35 (declare-function calc-inv-hyp-prefix-help "calc-help" ())
  36 (declare-function calc-inverse-prefix-help "calc-help" ())
  37 (declare-function calc-hyperbolic-prefix-help "calc-help" ())
  38 (declare-function calc-explain-why "calc-stuff" (why &optional more))
  39 (declare-function calc-clear-command-flag "calc-ext" (f))
  40 (declare-function calc-roll-down-with-selections "calc-sel" (n m))
  41 (declare-function calc-roll-up-with-selections "calc-sel" (n m))
  42 (declare-function calc-last-args "calc-undo" (n))
  43 (declare-function calc-is-inverse "calc-ext" ())
  44 (declare-function calc-do-prefix-help "calc-ext" (msgs group key))
  45 (declare-function math-objvecp "calc-ext" (a))
  46 (declare-function math-known-scalarp "calc-arith" (a &optional assume-scalar))
  47 (declare-function math-vectorp "calc-ext" (a))
  48 (declare-function math-matrixp "calc-ext" (a))
  49 (declare-function math-trunc-special "calc-arith" (a prec))
  50 (declare-function math-trunc-fancy "calc-arith" (a))
  51 (declare-function math-floor-special "calc-arith" (a prec))
  52 (declare-function math-floor-fancy "calc-arith" (a))
  53 (declare-function math-square-matrixp "calc-ext" (a))
  54 (declare-function math-matrix-inv-raw "calc-mtx" (m))
  55 (declare-function math-known-matrixp "calc-arith" (a))
  56 (declare-function math-mod-fancy "calc-arith" (a b))
  57 (declare-function math-pow-of-zero "calc-arith" (a b))
  58 (declare-function math-pow-zero "calc-arith" (a b))
  59 (declare-function math-pow-fancy "calc-arith" (a b))
  60 (declare-function calc-locate-cursor-element "calc-yank" (pt))
  61
  62 ;;;###autoload
  63 (defun calc-dispatch-help (arg)
  64   "C-x* is a prefix key sequence; follow it with one of these letters:
  65
  66 For turning Calc on and off:
  67   C  calc.  Start the Calculator in a window at the bottom of the screen.
  68   O  calc-other-window.  Start the Calculator but don't select its window.
  69   B  calc-big-or-small.  Control whether to use the full Emacs screen for Calc.
  70   Q  quick-calc.  Use the Calculator in the minibuffer.
  71   K  calc-keypad.  Start the Calculator in keypad mode (X window system only).
  72   E  calc-embedded.  Use the Calculator on a formula in this editing buffer.
  73   J  calc-embedded-select.  Like E, but select appropriate half of => or :=.
  74   W  calc-embedded-word.  Like E, but activate a single word, i.e., a number.
  75   Z  calc-user-invocation.  Invoke Calc in the way you defined with `Z I' cmd.
  76   X  calc-quit.  Turn Calc off.
  77
  78 For moving data into and out of Calc:
  79   G  calc-grab-region.  Grab the region defined by mark and point into Calc.
  80   R  calc-grab-rectangle.  Grab the rectangle defined by mark, point into Calc.
  81   :  calc-grab-sum-down.  Grab a rectangle and sum the columns.
  82   _  calc-grab-sum-across.  Grab a rectangle and sum the rows.
  83   Y  calc-copy-to-buffer.  Copy a value from the stack into the editing buffer.
  84
  85 For use with Embedded mode:
  86   A  calc-embedded-activate.  Find and activate all :='s and =>'s in buffer.
  87   D  calc-embedded-duplicate.  Make a copy of this formula and select it.
  88   F  calc-embedded-new-formula.  Insert a new formula at current point.
  89   N  calc-embedded-next.  Advance cursor to next known formula in buffer.
  90   P  calc-embedded-previous.  Advance cursor to previous known formula.
  91   U  calc-embedded-update-formula.  Re-evaluate formula at point.
  92   `  calc-embedded-edit.  Use calc-edit to edit formula at point.
  93
  94 Documentation:
  95   I  calc-info.  Read the Calculator manual in the Emacs Info system.
  96   T  calc-tutorial.  Run the Calculator Tutorial using the Emacs Info system.
  97   S  calc-summary.  Read the Summary from the Calculator manual in Info.
  98
  99 Miscellaneous:
 100   L  calc-load-everything.  Load all parts of the Calculator into memory.
 101   M  read-kbd-macro.  Read a region of keystroke names as a keyboard macro.
 102   0  (zero) calc-reset.  Reset Calc stack and modes to default state.
 103
 104 Press `*' twice (`C-x * *') to turn Calc on or off using the same
 105 Calc user interface as before (either C-x * C or C-x * K; initially C-x * C).
 106 "
 107   (interactive "P")
 108   (calc-check-defines)
 109   (if calc-dispatch-help
 110       (progn
 111         (save-window-excursion
 112           (describe-function 'calc-dispatch-help)
 113           (let ((win (get-buffer-window "*Help*")))
 114             (if win
 115                 (let (key)
 116                   (select-window win)
 117                   (while (progn
 118                            (message "Calc options: Calc, Keypad, ...  %s"
 119                                     "press SPC, DEL to scroll, C-g to cancel")
 120                            (memq (car (setq key (calc-read-key t)))
 121                                  '(?  ?\C-h ?\C-? ?\C-v ?\M-v)))
 122                     (condition-case err
 123                         (if (memq (car key) '(?  ?\C-v))
 124                             (scroll-up)
 125                           (scroll-down))
 126                       (error (beep))))
 127                       (calc-unread-command (cdr key))))))
 128         (calc-do-dispatch nil))
 129     (let ((calc-dispatch-help t))
 130       (calc-do-dispatch arg))))
 131
 132
 133 ;;;###autoload
 134 (defun calc-big-or-small (arg)
 135   "Toggle Calc between full-screen and regular mode."
 136   (interactive "P")
 137   (let ((cwin (get-buffer-window "*Calculator*"))
 138         (twin (get-buffer-window "*Calc Trail*"))
 139         (kwin (get-buffer-window "*Calc Keypad*")))
 140     (if cwin
 141         (setq calc-full-mode
 142               (if kwin
 143                   (and twin (window-full-width-p twin))
 144                 (window-full-height-p cwin))))
 145     (setq calc-full-mode (if arg
 146                              (> (prefix-numeric-value arg) 0)
 147                            (not calc-full-mode)))
 148     (if kwin
 149         (progn
 150           (calc-quit)
 151           (calc-do-keypad calc-full-mode nil))
 152       (if cwin
 153           (progn
 154             (calc-quit)
 155             (calc nil calc-full-mode nil))))
 156     (message (if calc-full-mode
 157                  "Now using full screen for Calc"
 158                "Now using partial screen for Calc"))))
 159
 160 ;;;###autoload
 161 (defun calc-other-window (&optional interactive)
 162   "Invoke the Calculator in another window."
 163   (interactive "p")
 164   (if (memq major-mode '(calc-mode calc-trail-mode))
 165       (progn
 166         (other-window 1)
 167         (if (memq major-mode '(calc-mode calc-trail-mode))
 168             (other-window 1)))
 169     (if (get-buffer-window "*Calculator*")
 170         (calc-quit)
 171       (let ((win (selected-window)))
 172         (calc nil win interactive)))))
 173
 174 ;;;###autoload
 175 (defun another-calc ()
 176   "Create another, independent Calculator buffer."
 177   (interactive)
 178   (if (eq major-mode 'calc-mode)
 179       (mapc (function
 180              (lambda (v)
 181               (set-default v (symbol-value v)))) calc-local-var-list))
 182   (set-buffer (generate-new-buffer "*Calculator*"))
 183   (pop-to-buffer (current-buffer))
 184   (calc-mode))
 185
 186 ;;;###autoload
 187 (defun calc-info ()
 188   "Run the Emacs Info system on the Calculator documentation."
 189   (interactive)
 190   (select-window (get-largest-window))
 191   (info "Calc"))
 192
 193 ;;;###autoload
 194 (defun calc-info-goto-node (node)
 195   "Go to a node in the Calculator info documentation."
 196   (interactive)
 197   (select-window (get-largest-window))
 198   (info (concat "(Calc)" node)))
 199
 200 ;;;###autoload
 201 (defun calc-tutorial ()
 202   "Run the Emacs Info system on the Calculator Tutorial."
 203   (interactive)
 204   (if (get-buffer-window "*Calculator*")
 205       (calc-quit))
 206   (calc-info-goto-node "Interactive Tutorial")
 207   (calc-other-window)
 208   (message "Welcome to the Calc Tutorial!"))
 209
 210 ;;;###autoload
 211 (defun calc-info-summary ()
 212   "Run the Emacs Info system on the Calculator Summary."
 213   (interactive)
 214   (calc-info-goto-node "Summary"))
 215
 216 ;;;###autoload
 217 (defun calc-help ()
 218   (interactive)
 219   (let ((msgs
 220          '("Press `h' for complete help; press `?' repeatedly for a summary"
 221            "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit"
 222            "Letter keys: SHIFT + Undo, reDo; Keep-args; Inverse, Hyperbolic"
 223            "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB"
 224            "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi"
 225            "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro"
 226            "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)"
 227            "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)"
 228            "Other keys: ' (alg-entry), = (eval), ` (edit); M-RET (last-args)"
 229            "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)"
 230            "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)"
 231            "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)"
 232            "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)"
 233            "Prefix keys: Algebra, Binary/business, Convert, Display"
 234            "Prefix keys: Functions, Graphics, Help, J (select)"
 235            "Prefix keys: Kombinatorics/statistics, Modes, Store/recall"
 236            "Prefix keys: Trail/time, Units/statistics, Vector/matrix"
 237            "Prefix keys: Z (user), SHIFT + Z (define)"
 238            "Prefix keys: prefix + ? gives further help for that prefix"
 239            "  Calc by Dave Gillespie, daveg@synaptics.com")))
 240     (if calc-full-help-flag
 241         msgs
 242       (if (or calc-inverse-flag calc-hyperbolic-flag)
 243           (if calc-inverse-flag
 244               (if calc-hyperbolic-flag
 245                   (calc-inv-hyp-prefix-help)
 246                 (calc-inverse-prefix-help))
 247             (calc-hyperbolic-prefix-help))
 248         (setq calc-help-phase
 249               (if (eq this-command last-command)
 250                   (% (1+ calc-help-phase) (1+ (length msgs)))
 251                 0))
 252         (let ((msg (nth calc-help-phase msgs)))
 253           (message "%s" (if msg
 254                             (concat msg ":"
 255                                     (make-string (- (apply 'max
 256                                                            (mapcar 'length
 257                                                                    msgs))
 258                                                     (length msg)) 32)
 259                                     "  [?=MORE]")
 260                           "")))))))
 261
 262
 263
 264
 265 ;;;; Stack and buffer management.
 266
 267 ;; The variable calc-last-why-command is set in calc-do-handly-whys
 268 ;; and used in calc-why (in calc-stuff.el).
 269 (defvar calc-last-why-command)
 270
 271 ;;;###autoload
 272 (defun calc-do-handle-whys ()
 273   (setq calc-why (sort calc-next-why
 274                        (function
 275                         (lambda (x y)
 276                           (and (eq (car x) '*) (not (eq (car y) '*))))))
 277         calc-next-why nil)
 278   (if (and calc-why (or (eq calc-auto-why t)
 279                         (and (eq (car (car calc-why)) '*)
 280                              calc-auto-why)))
 281       (progn
 282         (require 'calc-ext)
 283         (calc-explain-why (car calc-why)
 284                           (if (eq calc-auto-why t)
 285                               (cdr calc-why)
 286                             (if calc-auto-why
 287                                 (eq (car (nth 1 calc-why)) '*))))
 288         (setq calc-last-why-command this-command)
 289         (calc-clear-command-flag 'clear-message))))
 290
 291 ;;;###autoload
 292 (defun calc-record-why (&rest stuff)
 293   (if (eq (car stuff) 'quiet)
 294       (setq stuff (cdr stuff))
 295     (if (and (symbolp (car stuff))
 296              (cdr stuff)
 297              (or (Math-objectp (nth 1 stuff))
 298                  (and (Math-vectorp (nth 1 stuff))
 299                       (math-constp (nth 1 stuff)))
 300                  (math-infinitep (nth 1 stuff))))
 301         (setq stuff (cons '* stuff))
 302       (if (and (stringp (car stuff))
 303                (string-match "\\`\\*" (car stuff)))
 304           (setq stuff (cons '* (cons (substring (car stuff) 1)
 305                                      (cdr stuff)))))))
 306   (setq calc-next-why (cons stuff calc-next-why))
 307   nil)
 308
 309 ;; True if A is a constant or vector of constants.  [P x] [Public]
 310 ;;;###autoload
 311 (defun math-constp (a)
 312   (or (Math-scalarp a)
 313       (and (memq (car a) '(sdev intv mod vec))
 314            (progn
 315              (while (and (setq a (cdr a))
 316                          (or (Math-scalarp (car a))  ; optimization
 317                              (math-constp (car a)))))
 318              (null a)))))
 319
 320
 321 ;;;###autoload
 322 (defun calc-roll-down-stack (n &optional m)
 323   (if (< n 0)
 324       (calc-roll-up-stack (- n) m)
 325     (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size)))
 326     (or m (setq m 1))
 327     (and (> n 1)
 328          (< m n)
 329          (if (and calc-any-selections
 330                   (not calc-use-selections))
 331              (calc-roll-down-with-selections n m)
 332            (calc-pop-push-list n
 333                                (append (calc-top-list m 1)
 334                                        (calc-top-list (- n m) (1+ m))))))))
 335
 336 ;;;###autoload
 337 (defun calc-roll-up-stack (n &optional m)
 338   (if (< n 0)
 339       (calc-roll-down-stack (- n) m)
 340     (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size)))
 341     (or m (setq m 1))
 342     (and (> n 1)
 343          (< m n)
 344          (if (and calc-any-selections
 345                   (not calc-use-selections))
 346              (calc-roll-up-with-selections n m)
 347            (calc-pop-push-list n
 348                                (append (calc-top-list (- n m) 1)
 349                                        (calc-top-list m (- n m -1))))))))
 350
 351
 352 ;;;###autoload
 353 (defun calc-do-refresh ()
 354   (if calc-hyperbolic-flag
 355       (progn
 356         (setq calc-display-dirty t)
 357         nil)
 358     (calc-refresh)
 359     t))
 360
 361
 362 ;;;###autoload
 363 (defun calc-record-list (vals &optional prefix)
 364   (while vals
 365     (or (eq (car vals) 'top-of-stack)
 366         (progn
 367           (calc-record (car vals) prefix)
 368           (setq prefix "...")))
 369     (setq vals (cdr vals))))
 370
 371
 372 ;;;###autoload
 373 (defun calc-last-args-stub (arg)
 374   (interactive "p")
 375   (require 'calc-ext)
 376   (calc-last-args arg))
 377
 378
 379 ;;;###autoload
 380 (defun calc-power (arg)
 381   (interactive "P")
 382   (calc-slow-wrapper
 383    (if (and (featurep 'calc-ext)
 384             (calc-is-inverse))
 385        (calc-binary-op "root" 'calcFunc-nroot arg nil nil)
 386      (calc-binary-op "^" 'calcFunc-pow arg nil nil '^))))
 387
 388 ;;;###autoload
 389 (defun calc-mod (arg)
 390   (interactive "P")
 391   (calc-slow-wrapper
 392    (calc-binary-op "%" 'calcFunc-mod arg nil nil '%)))
 393
 394 ;;;###autoload
 395 (defun calc-inv (arg)
 396   (interactive "P")
 397   (calc-slow-wrapper
 398    (calc-unary-op "inv" 'calcFunc-inv arg)))
 399
 400 ;;;###autoload
 401 (defun calc-percent ()
 402   (interactive)
 403   (calc-slow-wrapper
 404    (calc-pop-push-record-list
 405     1 "%" (list (list 'calcFunc-percent (calc-top-n 1))))))
 406
 407
 408 ;;;###autoload
 409 (defun calc-over (n)
 410   (interactive "P")
 411   (if n
 412       (calc-enter (- (prefix-numeric-value n)))
 413     (calc-enter -2)))
 414
 415
 416 ;;;###autoload
 417 (defun calc-pop-above (n)
 418   (interactive "P")
 419   (if n
 420       (calc-pop (- (prefix-numeric-value n)))
 421     (calc-pop -2)))
 422
 423 ;;;###autoload
 424 (defun calc-roll-down (n)
 425   (interactive "P")
 426   (calc-wrapper
 427    (let ((nn (prefix-numeric-value n)))
 428      (cond ((null n)
 429             (calc-roll-down-stack 2))
 430            ((> nn 0)
 431             (calc-roll-down-stack nn))
 432            ((= nn 0)
 433             (calc-pop-push-list (calc-stack-size)
 434                                 (reverse
 435                                  (calc-top-list (calc-stack-size)))))
 436            (t
 437             (calc-roll-down-stack (calc-stack-size) (- nn)))))))
 438
 439 ;;;###autoload
 440 (defun calc-roll-up (n)
 441   (interactive "P")
 442   (calc-wrapper
 443    (let ((nn (prefix-numeric-value n)))
 444      (cond ((null n)
 445             (calc-roll-up-stack 3))
 446            ((> nn 0)
 447             (calc-roll-up-stack nn))
 448            ((= nn 0)
 449             (calc-pop-push-list (calc-stack-size)
 450                                 (reverse
 451                                  (calc-top-list (calc-stack-size)))))
 452            (t
 453             (calc-roll-up-stack (calc-stack-size) (- nn)))))))
 454
 455 ;;;###autoload
 456 (defun calc-transpose-lines (&optional arg)
 457   "Transpose previous line and current line.
 458 With argument ARG, move previous line past ARG lines.
 459 With argument 0, switch line point is in with line mark is in."
 460   (interactive "p")
 461   (setq arg (or arg 1))
 462   (let (bot-line mid-line end-line
 463                  old-top-list new-top-list
 464                  bot-cell mid-cell
 465                  prev-mid-cell post-mid-cell post-bot-cell)
 466     (calc-wrapper
 467      (when (eq major-mode 'calc-mode)
 468        (cond
 469         ;; exchange point and mark
 470         ((= 0 arg)
 471          (setq bot-line  (calc-locate-cursor-element (point))
 472                mid-line  (mark))
 473          (if mid-line
 474              (setq mid-line  (calc-locate-cursor-element mid-line)
 475                    end-line  (1+ mid-line))
 476            (error "No mark set"))
 477          (if (< bot-line mid-line)
 478              (let ((temp mid-line))
 479                (setq mid-line bot-line
 480                      bot-line temp))))
 481         ;; move bot-line to mid-line that is above bot-line on stack (that is
 482         ;; to say mid-line displayed below bot-line in *Calculator* buffer)
 483         ((> arg 0)
 484          (setq bot-line (1+ (calc-locate-cursor-element (point)))
 485                mid-line (- bot-line arg)
 486                end-line mid-line))
 487         ;; move bot-line to mid-line that is above bot-line on stack (that is
 488         ;; to say mid-line displayed below bot-line in *Calculator* buffer)
 489         ((< arg 0)
 490          (setq mid-line (1+ (calc-locate-cursor-element (point)))
 491                bot-line (- mid-line arg)
 492                end-line bot-line)))
 493        (calc-check-stack bot-line)
 494        (if (= 0 mid-line)
 495            (error "Can't transpose beyond top"))
 496        (setq old-top-list (nreverse (calc-top-list bot-line)))
 497        ;; example: (arg = 2)
 498        ;; old-top-list =
 499        ;; 1 <-- top of stack (bottom of *Calculator* buffer)
 500        ;; 2
 501        ;; 3 <-- mid-line = 3
 502        ;; 4 <-- point
 503        ;; 5 <-- bot-line = 5
 504        (dotimes (i mid-line)
 505          (setq mid-cell old-top-list
 506                old-top-list (cdr old-top-list))
 507          (setcdr mid-cell new-top-list)
 508          (setq new-top-list  mid-cell))
 509        ;; example follow-up:
 510        ;; old-top-list =
 511        ;; 4
 512        ;; 5
 513        ;; new-top-list =
 514        ;; 3 <-- mid-cell
 515        ;; 2
 516        ;; 1
 517        (setq  prev-mid-cell old-top-list)
 518        (dotimes (i (- bot-line mid-line))
 519          (setq bot-cell old-top-list
 520                old-top-list (cdr old-top-list))
 521          (setcdr bot-cell new-top-list)
 522          (setq new-top-list  bot-cell))
 523        (setq post-mid-cell (cdr mid-cell)
 524              post-bot-cell  (cdr bot-cell))
 525        ;; example follow-up:
 526        ;; new-top-list =
 527        ;; 5 <-- bot-cell
 528        ;; 4 <-- prev-mid-cell & post-bot-cell
 529        ;; 3 <-- mid-cell
 530        ;; 2 <-- post-mid-cell
 531        ;; 1
 532        (cond
 533         ((= 0 arg); swap bot and mid
 534          (setcdr mid-cell            post-bot-cell)
 535          (setcdr bot-cell            post-mid-cell)
 536          (setcdr prev-mid-cell       bot-cell)
 537          ;; example follow-up:
 538          ;; 3 <-- mid-cell
 539          ;; 4 <-- post-bot-cell & prev-mid-cell
 540          ;; 5 <-- bot-cell
 541          ;; 2 <-- post-mid-cell
 542          ;; 1
 543          (setq new-top-list mid-cell))
 544         ((< 0 arg) ; move bot just after mid
 545          (setcdr mid-cell       bot-cell)
 546          (setcdr bot-cell       post-mid-cell)
 547          ;; example follow-up:
 548          ;; new-top-list =
 549          ;; 4 <-- post-bot-cell
 550          ;; 3 <-- mid-cell
 551          ;; 5 <-- bot-cell
 552          ;; 2 <-- post-mid-cell
 553          ;; 1
 554          (setq new-top-list post-bot-cell))
 555         ((> 0 arg) ; move mid just before bot
 556          (setcdr mid-cell       bot-cell)
 557          (setcdr prev-mid-cell  post-mid-cell)
 558          ;; example follow-up:
 559          ;; new-top-list =
 560          ;; 3 <-- mid-cell
 561          ;; 5 <-- bot-cell
 562          ;; 4 <-- prev-mid-cell
 563          ;; 2 <-- post-mid-cell
 564          ;; 1
 565          (setq new-top-list mid-cell)))
 566        (calc-pop-push-list bot-line new-top-list)))
 567     (calc-cursor-stack-index (1- end-line))))
 568
 569
 570
 571 ;;; Other commands.
 572
 573 ;;;###autoload
 574 (defun calc-num-prefix-name (n)
 575   (cond ((eq n '-) "- ")
 576         ((equal n '(4)) "C-u ")
 577         ((consp n) (format "%d " (car n)))
 578         ((integerp n) (format "%d " n))
 579         (t "")))
 580
 581 ;;;###autoload
 582 (defun calc-missing-key (n)
 583   "This is a placeholder for a command which needs to be loaded from calc-ext.
 584 When this key is used, calc-ext (the Calculator extensions module) will be
 585 loaded and the keystroke automatically re-typed."
 586   (interactive "P")
 587   (require 'calc-ext)
 588   (if (keymapp (key-binding (char-to-string last-command-event)))
 589       (message "%s%c-" (calc-num-prefix-name n) last-command-event))
 590   (calc-unread-command)
 591   (setq prefix-arg n))
 592
 593 ;;;###autoload
 594 (defun calc-shift-Y-prefix-help ()
 595   (interactive)
 596   (require 'calc-ext)
 597   (calc-do-prefix-help calc-Y-help-msgs "other" ?Y))
 598
 599
 600
 601
 602 ;;;###autoload
 603 (defun calcDigit-letter ()
 604   (interactive)
 605   (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")
 606       (progn
 607         (setq last-command-event (upcase last-command-event))
 608         (calcDigit-key))
 609     (calcDigit-nondigit)))
 610
 611
 612 ;; A Lisp version of temp_minibuffer_message from minibuf.c.
 613 ;;;###autoload
 614 (defun calc-temp-minibuffer-message (m)
 615   (let ((savemax (point-max)))
 616     (save-excursion
 617       (goto-char (point-max))
 618       (insert m))
 619     (let ((okay nil))
 620       (unwind-protect
 621           (progn
 622             (sit-for 2)
 623             (identity 1)   ; this forces a call to QUIT; in bytecode.c.
 624             (setq okay t))
 625         (progn
 626           (delete-region savemax (point-max))
 627           (or okay (abort-recursive-edit)))))))
 628
 629
 630 (put 'math-with-extra-prec 'lisp-indent-hook 1)
 631
 632
 633 ;; Concatenate two vectors, or a vector and an object.  [V O O] [Public]
 634 ;;;###autoload
 635 (defun math-concat (v1 v2)
 636   (if (stringp v1)
 637       (concat v1 v2)
 638     (require 'calc-ext)
 639     (if (and (or (math-objvecp v1) (math-known-scalarp v1))
 640              (or (math-objvecp v2) (math-known-scalarp v2)))
 641         (append (if (and (math-vectorp v1)
 642                          (or (math-matrixp v1)
 643                              (not (math-matrixp v2))))
 644                     v1
 645                   (list 'vec v1))
 646                 (if (and (math-vectorp v2)
 647                          (or (math-matrixp v2)
 648                              (not (math-matrixp v1))))
 649                     (cdr v2)
 650                   (list v2)))
 651       (list '| v1 v2))))
 652
 653
 654 ;; True if A is zero.  Works for un-normalized values.  [P n] [Public]
 655 ;;;###autoload
 656 (defun math-zerop (a)
 657   (if (consp a)
 658       (cond ((memq (car a) '(bigpos bigneg))
 659              (while (eq (car (setq a (cdr a))) 0))
 660              (null a))
 661             ((memq (car a) '(frac float polar mod))
 662              (math-zerop (nth 1 a)))
 663             ((eq (car a) 'cplx)
 664              (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a))))
 665             ((eq (car a) 'hms)
 666              (and (math-zerop (nth 1 a))
 667                   (math-zerop (nth 2 a))
 668                   (math-zerop (nth 3 a)))))
 669     (eq a 0)))
 670
 671
 672 ;; True if A is real and negative.  [P n] [Public]
 673
 674 ;;;###autoload
 675 (defun math-negp (a)
 676   (if (consp a)
 677       (cond ((eq (car a) 'bigpos) nil)
 678             ((eq (car a) 'bigneg) (cdr a))
 679             ((memq (car a) '(float frac))
 680              (Math-integer-negp (nth 1 a)))
 681             ((eq (car a) 'hms)
 682              (if (math-zerop (nth 1 a))
 683                  (if (math-zerop (nth 2 a))
 684                      (math-negp (nth 3 a))
 685                    (math-negp (nth 2 a)))
 686                (math-negp (nth 1 a))))
 687             ((eq (car a) 'date)
 688              (math-negp (nth 1 a)))
 689             ((eq (car a) 'intv)
 690              (or (math-negp (nth 3 a))
 691                  (and (math-zerop (nth 3 a))
 692                       (memq (nth 1 a) '(0 2)))))
 693             ((equal a '(neg (var inf var-inf))) t))
 694     (< a 0)))
 695
 696 ;; True if A is a negative number or an expression the starts with '-'.
 697 ;;;###autoload
 698 (defun math-looks-negp (a)   ; [P x] [Public]
 699   (or (Math-negp a)
 700       (eq (car-safe a) 'neg)
 701       (and (memq (car-safe a) '(* /))
 702            (or (math-looks-negp (nth 1 a))
 703                (math-looks-negp (nth 2 a))))
 704       (and (eq (car-safe a) '-)
 705            (math-looks-negp (nth 1 a)))))
 706
 707
 708 ;; True if A is real and positive.  [P n] [Public]
 709 ;;;###autoload
 710 (defun math-posp (a)
 711   (if (consp a)
 712       (cond ((eq (car a) 'bigpos) (cdr a))
 713             ((eq (car a) 'bigneg) nil)
 714             ((memq (car a) '(float frac))
 715              (Math-integer-posp (nth 1 a)))
 716             ((eq (car a) 'hms)
 717              (if (math-zerop (nth 1 a))
 718                  (if (math-zerop (nth 2 a))
 719                      (math-posp (nth 3 a))
 720                    (math-posp (nth 2 a)))
 721                (math-posp (nth 1 a))))
 722             ((eq (car a) 'date)
 723              (math-posp (nth 1 a)))
 724             ((eq (car a) 'mod)
 725              (not (math-zerop (nth 1 a))))
 726             ((eq (car a) 'intv)
 727              (or (math-posp (nth 2 a))
 728                  (and (math-zerop (nth 2 a))
 729                       (memq (nth 1 a) '(0 1)))))
 730             ((equal a '(var inf var-inf)) t))
 731     (> a 0)))
 732
 733 ;;;###autoload
 734 (defalias 'math-fixnump 'integerp)
 735 ;;;###autoload
 736 (defalias 'math-fixnatnump 'natnump)
 737
 738
 739 ;; True if A is an even integer.  [P R R] [Public]
 740 ;;;###autoload
 741 (defun math-evenp (a)
 742   (if (consp a)
 743       (and (memq (car a) '(bigpos bigneg))
 744            (= (% (nth 1 a) 2) 0))
 745     (= (% a 2) 0)))
 746
 747 ;; Compute A / 2, for small or big integer A.  [I i]
 748 ;; If A is negative, type of truncation is undefined.
 749 ;;;###autoload
 750 (defun math-div2 (a)
 751   (if (consp a)
 752       (if (cdr a)
 753           (math-normalize (cons (car a) (math-div2-bignum (cdr a))))
 754         0)
 755     (/ a 2)))
 756
 757 ;;;###autoload
 758 (defun math-div2-bignum (a)   ; [l l]
 759   (if (cdr a)
 760       (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) (/ math-bignum-digit-size 2)))
 761             (math-div2-bignum (cdr a)))
 762     (list (/ (car a) 2))))
 763
 764
 765 ;; Reject an argument to a calculator function.  [Public]
 766 ;;;###autoload
 767 (defun math-reject-arg (&optional a p option)
 768   (if option
 769       (calc-record-why option p a)
 770     (if p
 771         (calc-record-why p a)))
 772   (signal 'wrong-type-argument (and a (if p (list p a) (list a)))))
 773
 774
 775 ;; Coerce A to be an integer (by truncation toward zero).  [I N] [Public]
 776
 777 ;; The variable math-trunc-prec is local to math-trunc, but used by
 778 ;; math-trunc-fancy in calc-arith.el, which is called by math-trunc.
 779
 780 ;;;###autoload
 781 (defun math-trunc (a &optional math-trunc-prec)
 782   (cond (math-trunc-prec
 783          (require 'calc-ext)
 784          (math-trunc-special a math-trunc-prec))
 785         ((Math-integerp a) a)
 786         ((Math-looks-negp a)
 787          (math-neg (math-trunc (math-neg a))))
 788         ((eq (car a) 'float)
 789          (math-scale-int (nth 1 a) (nth 2 a)))
 790         (t (require 'calc-ext)
 791            (math-trunc-fancy a))))
 792 ;;;###autoload
 793 (defalias 'calcFunc-trunc 'math-trunc)
 794
 795 ;; Coerce A to be an integer (by truncation toward minus infinity).  [I N]
 796
 797 ;; The variable math-floor-prec is local to math-floor, but used by
 798 ;; math-floor-fancy in calc-arith.el, which is called by math-floor.
 799
 800 ;;;###autoload
 801 (defun math-floor (a &optional math-floor-prec)    ;  [Public]
 802   (cond (math-floor-prec
 803          (require 'calc-ext)
 804          (math-floor-special a math-floor-prec))
 805         ((Math-integerp a) a)
 806         ((Math-messy-integerp a) (math-trunc a))
 807         ((Math-realp a)
 808          (if (Math-negp a)
 809              (math-add (math-trunc a) -1)
 810            (math-trunc a)))
 811         (t (require 'calc-ext)
 812            (math-floor-fancy a))))
 813 ;;;###autoload
 814 (defalias 'calcFunc-floor 'math-floor)
 815
 816
 817 ;;;###autoload
 818 (defun math-imod (a b)   ; [I I I] [Public]
 819   (if (and (not (consp a)) (not (consp b)))
 820       (if (= b 0)
 821           (math-reject-arg a "*Division by zero")
 822         (% a b))
 823     (cdr (math-idivmod a b))))
 824
 825
 826 ;;;###autoload
 827 (defun calcFunc-inv (m)
 828   (if (Math-vectorp m)
 829       (progn
 830         (require 'calc-ext)
 831         (if (math-square-matrixp m)
 832             (or (math-with-extra-prec 2 (math-matrix-inv-raw m))
 833                 (math-reject-arg m "*Singular matrix"))
 834           (math-reject-arg m 'square-matrixp)))
 835     (if (and
 836          (require 'calc-arith)
 837          (math-known-matrixp m))
 838         (math-pow m -1)
 839       (math-div 1 m))))
 840
 841 ;;;###autoload
 842 (defun math-do-working (msg arg)
 843   (or executing-kbd-macro
 844       (progn
 845         (calc-set-command-flag 'clear-message)
 846         (if math-working-step
 847             (if math-working-step-2
 848                 (setq msg (format "[%d/%d] %s"
 849                                   math-working-step math-working-step-2 msg))
 850               (setq msg (format "[%d] %s" math-working-step msg))))
 851         (message "Working... %s = %s" msg
 852                  (math-showing-full-precision (math-format-number arg))))))
 853
 854
 855 ;; Compute A modulo B, defined in terms of truncation toward minus infinity.
 856 ;;;###autoload
 857 (defun math-mod (a b)   ; [R R R] [Public]
 858   (cond ((and (Math-zerop a) (not (eq (car-safe a) 'mod))) a)
 859         ((Math-zerop b)
 860          (math-reject-arg a "*Division by zero"))
 861         ((and (Math-natnump a) (Math-natnump b))
 862          (math-imod a b))
 863         ((and (Math-anglep a) (Math-anglep b))
 864          (math-sub a (math-mul (math-floor (math-div a b)) b)))
 865         (t (require 'calc-ext)
 866            (math-mod-fancy a b))))
 867
 868
 869
 870 ;;; General exponentiation.
 871
 872 ;;;###autoload
 873 (defun math-pow (a b)   ; [O O N] [Public]
 874   (cond ((equal b '(var nan var-nan))
 875          b)
 876         ((Math-zerop a)
 877          (if (and (Math-scalarp b) (Math-posp b))
 878              (if (math-floatp b) (math-float a) a)
 879            (require 'calc-ext)
 880            (math-pow-of-zero a b)))
 881         ((or (eq a 1) (eq b 1)) a)
 882         ((or (equal a '(float 1 0)) (equal b '(float 1 0))) a)
 883         ((Math-zerop b)
 884          (if (Math-scalarp a)
 885              (if (or (math-floatp a) (math-floatp b))
 886                  '(float 1 0) 1)
 887            (require 'calc-ext)
 888            (math-pow-zero a b)))
 889         ((and (Math-integerp b) (or (Math-numberp a) (Math-vectorp a)))
 890          (if (and (equal a '(float 1 1)) (integerp b))
 891              (math-make-float 1 b)
 892            (math-with-extra-prec 2
 893              (math-ipow a b))))
 894         (t
 895          (require 'calc-ext)
 896          (math-pow-fancy a b))))
 897
 898 ;;;###autoload
 899 (defun math-ipow (a n)   ; [O O I] [Public]
 900   (cond ((Math-integer-negp n)
 901          (math-ipow (math-div 1 a) (Math-integer-neg n)))
 902         ((not (consp n))
 903          (if (and (Math-ratp a) (> n 20))
 904              (math-iipow-show a n)
 905            (math-iipow a n)))
 906         ((math-evenp n)
 907          (math-ipow (math-mul a a) (math-div2 n)))
 908         (t
 909          (math-mul a (math-ipow (math-mul a a)
 910                                 (math-div2 (math-add n -1)))))))
 911
 912 (defun math-iipow (a n)   ; [O O S]
 913   (cond ((= n 0) 1)
 914         ((= n 1) a)
 915         ((= (% n 2) 0) (math-iipow (math-mul a a) (/ n 2)))
 916         (t (math-mul a (math-iipow (math-mul a a) (/ n 2))))))
 917
 918 (defun math-iipow-show (a n)   ; [O O S]
 919   (math-working "pow" a)
 920   (let ((val (cond
 921               ((= n 0) 1)
 922               ((= n 1) a)
 923               ((= (% n 2) 0) (math-iipow-show (math-mul a a) (/ n 2)))
 924               (t (math-mul a (math-iipow-show (math-mul a a) (/ n 2)))))))
 925     (math-working "pow" val)
 926     val))
 927
 928
 929 ;;;###autoload
 930 (defun math-read-radix-digit (dig)   ; [D S; Z S]
 931   (if (> dig ?9)
 932       (if (< dig ?A)
 933           nil
 934         (- dig 55))
 935     (if (>= dig ?0)
 936         (- dig ?0)
 937       nil)))
 938
 939
 940 ;;; Bug reporting
 941
 942 ;;;###autoload
 943 (defun report-calc-bug ()
 944   "Report a bug in Calc, the GNU Emacs calculator.
 945 Prompts for bug subject.  Leaves you in a mail buffer."
 946   (interactive)
 947   (let ((reporter-prompt-for-summary-p t))
 948     (reporter-submit-bug-report calc-bug-address "Calc"
 949                                 nil nil nil
 950                                 "Please describe exactly what actions triggered the bug and the
 951 precise symptoms of the bug.  If possible, include a backtrace by
 952 doing 'M-x toggle-debug-on-error', then reproducing the bug.
 953 " )))
 954 ;;;###autoload
 955 (defalias 'calc-report-bug 'report-calc-bug)
 956
 957 (provide 'calc-misc)
 958
 959 ;; Local variables:
 960 ;; generated-autoload-file: "calc-loaddefs.el"
 961 ;; End:
 962
 963 ;; arch-tag: 7984d9d0-62e5-41dc-afb8-e904b975f250
 964 ;;; calc-misc.el ends here