| 1 | ;;; calc-stuff.el --- miscellaneous functions for Calc |
| 2 | |
| 3 | ;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: David Gillespie <daveg@synaptics.com> |
| 6 | ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;;; Code: |
| 26 | |
| 27 | ;; This file is autoloaded from calc-ext.el. |
| 28 | |
| 29 | (require 'calc-ext) |
| 30 | (require 'calc-macs) |
| 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 | (defvar calc-which-why nil) |
| 72 | (defvar calc-last-why-command nil) |
| 73 | (defun calc-explain-why (why &optional more) |
| 74 | (if (eq (car why) '*) |
| 75 | (setq why (cdr why))) |
| 76 | (let* ((pred (car why)) |
| 77 | (arg (nth 1 why)) |
| 78 | (msg (cond ((not pred) "Wrong type of argument") |
| 79 | ((stringp pred) pred) |
| 80 | ((eq pred 'integerp) "Integer expected") |
| 81 | ((eq pred 'natnump) |
| 82 | (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) |
| 83 | "Integer expected" |
| 84 | "Nonnegative integer expected")) |
| 85 | ((eq pred 'posintp) |
| 86 | (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) |
| 87 | "Integer expected" |
| 88 | "Positive integer expected")) |
| 89 | ((eq pred 'fixnump) |
| 90 | (if (and arg (Math-integerp arg)) |
| 91 | "Small integer expected" |
| 92 | "Integer expected")) |
| 93 | ((eq pred 'fixnatnump) |
| 94 | (if (and arg (Math-natnump arg)) |
| 95 | "Small integer expected" |
| 96 | (if (and arg (Math-objvecp arg) |
| 97 | (not (Math-integerp arg))) |
| 98 | "Integer expected" |
| 99 | "Nonnegative integer expected"))) |
| 100 | ((eq pred 'fixposintp) |
| 101 | (if (and arg (Math-integerp arg) (Math-posp arg)) |
| 102 | "Small integer expected" |
| 103 | (if (and arg (Math-objvecp arg) |
| 104 | (not (Math-integerp arg))) |
| 105 | "Integer expected" |
| 106 | "Positive integer expected"))) |
| 107 | ((eq pred 'posp) "Positive number expected") |
| 108 | ((eq pred 'negp) "Negative number expected") |
| 109 | ((eq pred 'nonzerop) "Nonzero number expected") |
| 110 | ((eq pred 'realp) "Real number expected") |
| 111 | ((eq pred 'anglep) "Real number expected") |
| 112 | ((eq pred 'hmsp) "HMS form expected") |
| 113 | ((eq pred 'datep) |
| 114 | (if (and arg (Math-objectp arg) |
| 115 | (not (Math-realp arg))) |
| 116 | "Real number or date form expected" |
| 117 | "Date form expected")) |
| 118 | ((eq pred 'numberp) "Number expected") |
| 119 | ((eq pred 'scalarp) "Number expected") |
| 120 | ((eq pred 'vectorp) "Vector or matrix expected") |
| 121 | ((eq pred 'numvecp) "Number or vector expected") |
| 122 | ((eq pred 'matrixp) "Matrix expected") |
| 123 | ((eq pred 'square-matrixp) |
| 124 | (if (and arg (math-matrixp arg)) |
| 125 | "Square matrix expected" |
| 126 | "Matrix expected")) |
| 127 | ((eq pred 'objectp) "Number expected") |
| 128 | ((eq pred 'constp) "Constant expected") |
| 129 | ((eq pred 'range) "Argument out of range") |
| 130 | (t (format "%s expected" pred)))) |
| 131 | (punc ": ") |
| 132 | (calc-can-abbrev-vectors t)) |
| 133 | (while (setq why (cdr why)) |
| 134 | (and (car why) |
| 135 | (setq msg (concat msg punc (if (stringp (car why)) |
| 136 | (car why) |
| 137 | (math-format-flat-expr (car why) 0))) |
| 138 | punc ", "))) |
| 139 | (message "%s%s" msg (if more " [w=more]" "")))) |
| 140 | |
| 141 | (defun calc-why () |
| 142 | (interactive) |
| 143 | (if (not (eq this-command last-command)) |
| 144 | (if (eq last-command calc-last-why-command) |
| 145 | (setq calc-which-why (cdr calc-why)) |
| 146 | (setq calc-which-why calc-why))) |
| 147 | (if calc-which-why |
| 148 | (progn |
| 149 | (calc-explain-why (car calc-which-why) (cdr calc-which-why)) |
| 150 | (setq calc-which-why (cdr calc-which-why))) |
| 151 | (if calc-why |
| 152 | (progn |
| 153 | (message "(No further explanations available)") |
| 154 | (setq calc-which-why calc-why)) |
| 155 | (message "No explanations available")))) |
| 156 | |
| 157 | ;; The following caches are declared in other files, but are |
| 158 | ;; reset here. |
| 159 | (defvar math-lud-cache) ; calc-mtx.el |
| 160 | (defvar math-log2-cache) ; calc-bin.el |
| 161 | (defvar math-radix-digits-cache) ; calc-bin.el |
| 162 | (defvar math-radix-float-cache-tag) ; calc-bin.el |
| 163 | (defvar math-random-cache) ; calc-comb.el |
| 164 | (defvar math-max-digits-cache) ; calc-bin.el |
| 165 | (defvar math-integral-cache) ; calcalg2.el |
| 166 | (defvar math-units-table) ; calc-units.el |
| 167 | (defvar math-decls-cache-tag) ; calc-arith.el |
| 168 | (defvar math-format-date-cache) ; calc-forms.el |
| 169 | (defvar math-holidays-cache-tag) ; calc-forms.el |
| 170 | |
| 171 | (defun calc-flush-caches (&optional inhibit-msg) |
| 172 | (interactive "P") |
| 173 | (calc-wrapper |
| 174 | (setq math-lud-cache nil |
| 175 | math-log2-cache nil |
| 176 | math-radix-digits-cache nil |
| 177 | math-radix-float-cache-tag nil |
| 178 | math-random-cache nil |
| 179 | math-max-digits-cache nil |
| 180 | math-integral-cache nil |
| 181 | math-units-table nil |
| 182 | math-decls-cache-tag nil |
| 183 | math-eval-rules-cache-tag t |
| 184 | math-format-date-cache nil |
| 185 | math-holidays-cache-tag t) |
| 186 | (mapc (function (lambda (x) (set x -100))) math-cache-list) |
| 187 | (unless inhibit-msg |
| 188 | (message "All internal calculator caches have been reset")))) |
| 189 | |
| 190 | |
| 191 | ;;; Conversions. |
| 192 | |
| 193 | (defun calc-clean (n) |
| 194 | (interactive "P") |
| 195 | (calc-slow-wrapper |
| 196 | (calc-with-default-simplification |
| 197 | (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean))) |
| 198 | (calc-enter-result 1 "cln" |
| 199 | (if n |
| 200 | (let ((n (prefix-numeric-value n))) |
| 201 | (list func |
| 202 | (calc-top-n 1) |
| 203 | (if (<= n 0) |
| 204 | (+ n calc-internal-prec) |
| 205 | n))) |
| 206 | (list func (calc-top-n 1)))))))) |
| 207 | |
| 208 | (defun calc-clean-num (num) |
| 209 | (interactive "P") |
| 210 | (calc-clean (- (if num |
| 211 | (prefix-numeric-value num) |
| 212 | (if (and (>= last-command-event ?0) |
| 213 | (<= last-command-event ?9)) |
| 214 | (- last-command-event ?0) |
| 215 | (error "Number required")))))) |
| 216 | |
| 217 | |
| 218 | (defvar math-chopping-small nil) |
| 219 | (defun calcFunc-clean (a &optional prec) ; [X X S] [Public] |
| 220 | (if prec |
| 221 | (cond ((Math-messy-integerp prec) |
| 222 | (calcFunc-clean a (math-trunc prec))) |
| 223 | ((or (not (integerp prec)) |
| 224 | (< prec 3)) |
| 225 | (calc-record-why "*Precision must be an integer 3 or above") |
| 226 | (list 'calcFunc-clean a prec)) |
| 227 | ((not (Math-objvecp a)) |
| 228 | (list 'calcFunc-clean a prec)) |
| 229 | (t (let ((calc-internal-prec prec) |
| 230 | (math-chopping-small t)) |
| 231 | (calcFunc-clean (math-normalize a))))) |
| 232 | (cond ((eq (car-safe a) 'polar) |
| 233 | (let ((theta (math-mod (nth 2 a) |
| 234 | (if (eq calc-angle-mode 'rad) |
| 235 | (math-two-pi) |
| 236 | 360)))) |
| 237 | (math-neg |
| 238 | (math-neg |
| 239 | (math-normalize |
| 240 | (list 'polar |
| 241 | (calcFunc-clean (nth 1 a)) |
| 242 | (calcFunc-clean theta))))))) |
| 243 | ((memq (car-safe a) '(vec date hms)) |
| 244 | (cons (car a) (mapcar 'calcFunc-clean (cdr a)))) |
| 245 | ((memq (car-safe a) '(cplx mod sdev intv)) |
| 246 | (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a))))) |
| 247 | ((eq (car-safe a) 'float) |
| 248 | (if math-chopping-small |
| 249 | (if (or (> (nth 2 a) (- calc-internal-prec)) |
| 250 | (Math-lessp (- calc-internal-prec) (calcFunc-xpon a))) |
| 251 | (if (and (math-num-integerp a) |
| 252 | (math-lessp (calcFunc-xpon a) calc-internal-prec)) |
| 253 | (math-trunc a) |
| 254 | a) |
| 255 | 0) |
| 256 | a)) |
| 257 | ((Math-objectp a) a) |
| 258 | ((math-infinitep a) a) |
| 259 | (t (list 'calcFunc-clean a))))) |
| 260 | |
| 261 | (defun calcFunc-pclean (a &optional prec) |
| 262 | (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec))) |
| 263 | a)) |
| 264 | |
| 265 | (defun calcFunc-pfloat (a) |
| 266 | (math-map-over-constants 'math-float a)) |
| 267 | |
| 268 | (defun calcFunc-pfrac (a &optional tol) |
| 269 | (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol))) |
| 270 | a)) |
| 271 | |
| 272 | ;; The variable math-moc-func is local to math-map-over-constants, |
| 273 | ;; but is used by math-map-over-constants-rec, which is called by |
| 274 | ;; math-map-over-constants. |
| 275 | (defvar math-moc-func) |
| 276 | |
| 277 | (defun math-map-over-constants (math-moc-func expr) |
| 278 | (math-map-over-constants-rec expr)) |
| 279 | |
| 280 | (defun math-map-over-constants-rec (expr) |
| 281 | (cond ((or (Math-primp expr) |
| 282 | (memq (car expr) '(intv sdev))) |
| 283 | (or (and (Math-objectp expr) |
| 284 | (funcall math-moc-func expr)) |
| 285 | expr)) |
| 286 | ((and (memq (car expr) '(^ calcFunc-subscr)) |
| 287 | (eq math-moc-func 'math-float) |
| 288 | (= (length expr) 3) |
| 289 | (Math-integerp (nth 2 expr))) |
| 290 | (list (car expr) |
| 291 | (math-map-over-constants-rec (nth 1 expr)) |
| 292 | (nth 2 expr))) |
| 293 | (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr)))))) |
| 294 | |
| 295 | (provide 'calc-stuff) |
| 296 | |
| 297 | ;;; calc-stuff.el ends here |