code.delx.au - gnu-emacs/blob - lisp/calc/calc-stuff.el

   1 ;; Calculator for GNU Emacs, part II [calc-stuff.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-stuff () nil)
  30
  31
  32 (defun calc-num-prefix (n)
  33   "Use the number at the top of stack as the numeric prefix for the next command.
  34 With a prefix, push that prefix as a number onto the stack."
  35   (interactive "P")
  36   (calc-wrapper
  37    (if n
  38        (calc-enter-result 0 "" (prefix-numeric-value n))
  39      (let ((num (calc-top 1)))
  40        (if (math-messy-integerp num)
  41            (setq num (math-trunc num)))
  42        (or (integerp num)
  43            (error "Argument must be a small integer"))
  44        (calc-pop-stack 1)
  45        (setq prefix-arg num)
  46        (message "%d-" num)))))    ; a (lame) simulation of the real thing...
  47
  48
  49 (defun calc-more-recursion-depth (n)
  50   (interactive "P")
  51   (calc-wrapper
  52    (if (calc-is-inverse)
  53        (calc-less-recursion-depth n)
  54      (let ((n (if n (prefix-numeric-value n) 2)))
  55        (if (> n 1)
  56            (setq max-specpdl-size (* max-specpdl-size n)
  57                  max-lisp-eval-depth (* max-lisp-eval-depth n))))
  58      (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))))
  59
  60 (defun calc-less-recursion-depth (n)
  61   (interactive "P")
  62   (let ((n (if n (prefix-numeric-value n) 2)))
  63     (if (> n 1)
  64         (setq max-specpdl-size
  65               (max (/ max-specpdl-size n) 600)
  66               max-lisp-eval-depth
  67               (max (/ max-lisp-eval-depth n) 200))))
  68   (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))
  69
  70
  71 (defun calc-explain-why (why &optional more)
  72   (if (eq (car why) '*)
  73       (setq why (cdr why)))
  74   (let* ((pred (car why))
  75          (arg (nth 1 why))
  76          (msg (cond ((not pred) "Wrong type of argument")
  77                     ((stringp pred) pred)
  78                     ((eq pred 'integerp) "Integer expected")
  79                     ((eq pred 'natnump)
  80                      (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
  81                          "Integer expected"
  82                        "Nonnegative integer expected"))
  83                     ((eq pred 'posintp)
  84                      (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
  85                          "Integer expected"
  86                        "Positive integer expected"))
  87                     ((eq pred 'fixnump)
  88                      (if (and arg (Math-integerp arg))
  89                          "Small integer expected"
  90                        "Integer expected"))
  91                     ((eq pred 'fixnatnump)
  92                      (if (and arg (Math-natnump arg))
  93                          "Small integer expected"
  94                        (if (and arg (Math-objvecp arg)
  95                                 (not (Math-integerp arg)))
  96                            "Integer expected"
  97                          "Nonnegative integer expected")))
  98                     ((eq pred 'fixposintp)
  99                      (if (and arg (Math-integerp arg) (Math-posp arg))
 100                          "Small integer expected"
 101                        (if (and arg (Math-objvecp arg)
 102                                 (not (Math-integerp arg)))
 103                            "Integer expected"
 104                          "Positive integer expected")))
 105                     ((eq pred 'posp) "Positive number expected")
 106                     ((eq pred 'negp) "Negative number expected")
 107                     ((eq pred 'nonzerop) "Nonzero number expected")
 108                     ((eq pred 'realp) "Real number expected")
 109                     ((eq pred 'anglep) "Real number expected")
 110                     ((eq pred 'hmsp) "HMS form expected")
 111                     ((eq pred 'datep)
 112                      (if (and arg (Math-objectp arg)
 113                               (not (Math-realp arg)))
 114                          "Real number or date form expected"
 115                        "Date form expected"))
 116                     ((eq pred 'numberp) "Number expected")
 117                     ((eq pred 'scalarp) "Number expected")
 118                     ((eq pred 'vectorp) "Vector or matrix expected")
 119                     ((eq pred 'numvecp) "Number or vector expected")
 120                     ((eq pred 'matrixp) "Matrix expected")
 121                     ((eq pred 'square-matrixp)
 122                      (if (and arg (math-matrixp arg))
 123                          "Square matrix expected"
 124                        "Matrix expected"))
 125                     ((eq pred 'objectp) "Number expected")
 126                     ((eq pred 'constp) "Constant expected")
 127                     ((eq pred 'range) "Argument out of range")
 128                     (t (format "%s expected" pred))))
 129          (punc ": ")
 130          (calc-can-abbrev-vectors t))
 131     (while (setq why (cdr why))
 132       (and (car why)
 133            (setq msg (concat msg punc (if (stringp (car why))
 134                                           (car why)
 135                                         (math-format-flat-expr (car why) 0)))
 136                  punc ", ")))
 137     (message "%s%s" msg (if more "  [w=more]" ""))))
 138
 139 (defun calc-why ()
 140   (interactive)
 141   (if (not (eq this-command last-command))
 142       (if (eq last-command calc-last-why-command)
 143           (setq calc-which-why (cdr calc-why))
 144         (setq calc-which-why calc-why)))
 145   (if calc-which-why
 146       (progn
 147         (calc-explain-why (car calc-which-why) (cdr calc-which-why))
 148         (setq calc-which-why (cdr calc-which-why)))
 149     (if calc-why
 150         (progn
 151           (message "(No further explanations available)")
 152           (setq calc-which-why calc-why))
 153       (message "No explanations available"))))
 154 (setq calc-which-why nil)
 155 (setq calc-last-why-command nil)
 156
 157
 158 (defun calc-version ()
 159   (interactive)
 160   (message "Calc %s, installed %s" calc-version calc-installed-date))
 161
 162
 163 (defun calc-flush-caches ()
 164   (interactive)
 165   (calc-wrapper
 166    (setq math-lud-cache nil
 167          math-log2-cache nil
 168          math-radix-digits-cache nil
 169          math-radix-float-cache-tag nil
 170          math-random-cache nil
 171          math-max-digits-cache nil
 172          math-checked-rewrites nil
 173          math-integral-cache nil
 174          math-units-table nil
 175          math-decls-cache-tag nil
 176          math-eval-rules-cache-tag t
 177          math-graph-var-cache nil
 178          math-graph-data-cache nil
 179          math-format-date-cache nil
 180          math-holidays-cache-tag t)
 181    (mapcar (function (lambda (x) (set x -100))) math-cache-list)
 182    (message "All internal calculator caches have been reset.")))
 183
 184
 185 ;;; Conversions.
 186
 187 (defun calc-clean (n)
 188   (interactive "P")
 189   (calc-slow-wrapper
 190    (calc-with-default-simplification
 191     (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean)))
 192       (calc-enter-result 1 "cln"
 193                          (if n
 194                              (let ((n (prefix-numeric-value n)))
 195                                (list func
 196                                      (calc-top-n 1)
 197                                      (if (<= n 0)
 198                                          (+ n calc-internal-prec)
 199                                        n)))
 200                            (list func (calc-top-n 1))))))))
 201
 202 (defun calc-clean-num (num)
 203   (interactive "P")
 204   (calc-clean (- (if num
 205                      (prefix-numeric-value num)
 206                    (if (and (>= last-command-char ?0)
 207                             (<= last-command-char ?9))
 208                        (- last-command-char ?0)
 209                      (error "Number required"))))))
 210
 211
 212 (defun calcFunc-clean (a &optional prec)   ; [X X S] [Public]
 213   (if prec
 214       (cond ((Math-messy-integerp prec)
 215              (calcFunc-clean a (math-trunc prec)))
 216             ((or (not (integerp prec))
 217                  (< prec 3))
 218              (calc-record-why "*Precision must be an integer 3 or above")
 219              (list 'calcFunc-clean a prec))
 220             ((not (Math-objvecp a))
 221              (list 'calcFunc-clean a prec))
 222             (t (let ((calc-internal-prec prec)
 223                      (math-chopping-small t))
 224                  (calcFunc-clean (math-normalize a)))))
 225     (cond ((eq (car-safe a) 'polar)
 226            (let ((theta (math-mod (nth 2 a)
 227                                   (if (eq calc-angle-mode 'rad)
 228                                       (math-two-pi)
 229                                     360))))
 230              (math-neg
 231               (math-neg
 232                (math-normalize
 233                 (list 'polar
 234                       (calcFunc-clean (nth 1 a))
 235                       (calcFunc-clean theta)))))))
 236           ((memq (car-safe a) '(vec date hms))
 237            (cons (car a) (mapcar 'calcFunc-clean (cdr a))))
 238           ((memq (car-safe a) '(cplx mod sdev intv))
 239            (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a)))))
 240           ((eq (car-safe a) 'float)
 241            (if math-chopping-small
 242                (if (or (> (nth 2 a) (- calc-internal-prec))
 243                        (Math-lessp (- calc-internal-prec) (calcFunc-xpon a)))
 244                    (if (and (math-num-integerp a)
 245                             (math-lessp (calcFunc-xpon a) calc-internal-prec))
 246                        (math-trunc a)
 247                      a)
 248                  0)
 249              a))
 250           ((Math-objectp a) a)
 251           ((math-infinitep a) a)
 252           (t (list 'calcFunc-clean a)))))
 253 (setq math-chopping-small nil)
 254
 255 (defun calcFunc-pclean (a &optional prec)
 256   (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
 257                            a))
 258
 259 (defun calcFunc-pfloat (a)
 260   (math-map-over-constants 'math-float a))
 261
 262 (defun calcFunc-pfrac (a &optional tol)
 263   (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
 264                            a))
 265
 266 (defun math-map-over-constants (func expr)
 267   (math-map-over-constants-rec expr))
 268
 269 (defun math-map-over-constants-rec (expr)
 270   (cond ((or (Math-primp expr)
 271              (memq (car expr) '(intv sdev)))
 272          (or (and (Math-objectp expr)
 273                   (funcall func expr))
 274              expr))
 275         ((and (memq (car expr) '(^ calcFunc-subscr))
 276               (eq func 'math-float)
 277               (= (length expr) 3)
 278               (Math-integerp (nth 2 expr)))
 279          (list (car expr)
 280                (math-map-over-constants-rec (nth 1 expr))
 281                (nth 2 expr)))
 282         (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))))
 283
 284 ;;; calc-stuff.el ends here