diff options
| author | Colin Walters | 2001-11-14 09:01:07 +0000 |
|---|---|---|
| committer | Colin Walters | 2001-11-14 09:01:07 +0000 |
| commit | 898ea5c0b23ce37cc76a976c6bd5c27921308eeb (patch) | |
| tree | 797495e9425450a3627bd03be3c353b1dab295d8 | |
| parent | d389648023884fc3ca5022a51796331f7cf75fb6 (diff) | |
| download | emacs-898ea5c0b23ce37cc76a976c6bd5c27921308eeb.tar.gz emacs-898ea5c0b23ce37cc76a976c6bd5c27921308eeb.zip | |
(calcFunc-abs, calcFunc-float, calcFunc-ceil, calcFunc-round): Use
`defalias' instead of `fset' and `symbol-function'.
Style cleanup; don't put closing parens on their
own line, add "foo.el ends here" to each file, and update
copyright date.
| -rw-r--r-- | lisp/calc/calc-arith.el | 447 |
1 files changed, 156 insertions, 291 deletions
diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el index 66732381873..d510c484364 100644 --- a/lisp/calc/calc-arith.el +++ b/lisp/calc/calc-arith.el | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;; Calculator for GNU Emacs, part II [calc-arith.el] | 1 | ;; Calculator for GNU Emacs, part II [calc-arith.el] |
| 2 | ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
| 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. | 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. |
| 4 | 4 | ||
| 5 | ;; This file is part of GNU Emacs. | 5 | ;; This file is part of GNU Emacs. |
| @@ -34,27 +34,23 @@ | |||
| 34 | (defun calc-min (arg) | 34 | (defun calc-min (arg) |
| 35 | (interactive "P") | 35 | (interactive "P") |
| 36 | (calc-slow-wrapper | 36 | (calc-slow-wrapper |
| 37 | (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf))) | 37 | (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf)))) |
| 38 | ) | ||
| 39 | 38 | ||
| 40 | (defun calc-max (arg) | 39 | (defun calc-max (arg) |
| 41 | (interactive "P") | 40 | (interactive "P") |
| 42 | (calc-slow-wrapper | 41 | (calc-slow-wrapper |
| 43 | (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf)))) | 42 | (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf))))) |
| 44 | ) | ||
| 45 | 43 | ||
| 46 | (defun calc-abs (arg) | 44 | (defun calc-abs (arg) |
| 47 | (interactive "P") | 45 | (interactive "P") |
| 48 | (calc-slow-wrapper | 46 | (calc-slow-wrapper |
| 49 | (calc-unary-op "abs" 'calcFunc-abs arg)) | 47 | (calc-unary-op "abs" 'calcFunc-abs arg))) |
| 50 | ) | ||
| 51 | 48 | ||
| 52 | 49 | ||
| 53 | (defun calc-idiv (arg) | 50 | (defun calc-idiv (arg) |
| 54 | (interactive "P") | 51 | (interactive "P") |
| 55 | (calc-slow-wrapper | 52 | (calc-slow-wrapper |
| 56 | (calc-binary-op "\\" 'calcFunc-idiv arg 1)) | 53 | (calc-binary-op "\\" 'calcFunc-idiv arg 1))) |
| 57 | ) | ||
| 58 | 54 | ||
| 59 | 55 | ||
| 60 | (defun calc-floor (arg) | 56 | (defun calc-floor (arg) |
| @@ -66,14 +62,12 @@ | |||
| 66 | (calc-unary-op "ceil" 'calcFunc-ceil arg)) | 62 | (calc-unary-op "ceil" 'calcFunc-ceil arg)) |
| 67 | (if (calc-is-hyperbolic) | 63 | (if (calc-is-hyperbolic) |
| 68 | (calc-unary-op "flor" 'calcFunc-ffloor arg) | 64 | (calc-unary-op "flor" 'calcFunc-ffloor arg) |
| 69 | (calc-unary-op "flor" 'calcFunc-floor arg)))) | 65 | (calc-unary-op "flor" 'calcFunc-floor arg))))) |
| 70 | ) | ||
| 71 | 66 | ||
| 72 | (defun calc-ceiling (arg) | 67 | (defun calc-ceiling (arg) |
| 73 | (interactive "P") | 68 | (interactive "P") |
| 74 | (calc-invert-func) | 69 | (calc-invert-func) |
| 75 | (calc-floor arg) | 70 | (calc-floor arg)) |
| 76 | ) | ||
| 77 | 71 | ||
| 78 | (defun calc-round (arg) | 72 | (defun calc-round (arg) |
| 79 | (interactive "P") | 73 | (interactive "P") |
| @@ -84,56 +78,47 @@ | |||
| 84 | (calc-unary-op "trnc" 'calcFunc-trunc arg)) | 78 | (calc-unary-op "trnc" 'calcFunc-trunc arg)) |
| 85 | (if (calc-is-hyperbolic) | 79 | (if (calc-is-hyperbolic) |
| 86 | (calc-unary-op "rond" 'calcFunc-fround arg) | 80 | (calc-unary-op "rond" 'calcFunc-fround arg) |
| 87 | (calc-unary-op "rond" 'calcFunc-round arg)))) | 81 | (calc-unary-op "rond" 'calcFunc-round arg))))) |
| 88 | ) | ||
| 89 | 82 | ||
| 90 | (defun calc-trunc (arg) | 83 | (defun calc-trunc (arg) |
| 91 | (interactive "P") | 84 | (interactive "P") |
| 92 | (calc-invert-func) | 85 | (calc-invert-func) |
| 93 | (calc-round arg) | 86 | (calc-round arg)) |
| 94 | ) | ||
| 95 | 87 | ||
| 96 | (defun calc-mant-part (arg) | 88 | (defun calc-mant-part (arg) |
| 97 | (interactive "P") | 89 | (interactive "P") |
| 98 | (calc-slow-wrapper | 90 | (calc-slow-wrapper |
| 99 | (calc-unary-op "mant" 'calcFunc-mant arg)) | 91 | (calc-unary-op "mant" 'calcFunc-mant arg))) |
| 100 | ) | ||
| 101 | 92 | ||
| 102 | (defun calc-xpon-part (arg) | 93 | (defun calc-xpon-part (arg) |
| 103 | (interactive "P") | 94 | (interactive "P") |
| 104 | (calc-slow-wrapper | 95 | (calc-slow-wrapper |
| 105 | (calc-unary-op "xpon" 'calcFunc-xpon arg)) | 96 | (calc-unary-op "xpon" 'calcFunc-xpon arg))) |
| 106 | ) | ||
| 107 | 97 | ||
| 108 | (defun calc-scale-float (arg) | 98 | (defun calc-scale-float (arg) |
| 109 | (interactive "P") | 99 | (interactive "P") |
| 110 | (calc-slow-wrapper | 100 | (calc-slow-wrapper |
| 111 | (calc-binary-op "scal" 'calcFunc-scf arg)) | 101 | (calc-binary-op "scal" 'calcFunc-scf arg))) |
| 112 | ) | ||
| 113 | 102 | ||
| 114 | (defun calc-abssqr (arg) | 103 | (defun calc-abssqr (arg) |
| 115 | (interactive "P") | 104 | (interactive "P") |
| 116 | (calc-slow-wrapper | 105 | (calc-slow-wrapper |
| 117 | (calc-unary-op "absq" 'calcFunc-abssqr arg)) | 106 | (calc-unary-op "absq" 'calcFunc-abssqr arg))) |
| 118 | ) | ||
| 119 | 107 | ||
| 120 | (defun calc-sign (arg) | 108 | (defun calc-sign (arg) |
| 121 | (interactive "P") | 109 | (interactive "P") |
| 122 | (calc-slow-wrapper | 110 | (calc-slow-wrapper |
| 123 | (calc-unary-op "sign" 'calcFunc-sign arg)) | 111 | (calc-unary-op "sign" 'calcFunc-sign arg))) |
| 124 | ) | ||
| 125 | 112 | ||
| 126 | (defun calc-increment (arg) | 113 | (defun calc-increment (arg) |
| 127 | (interactive "p") | 114 | (interactive "p") |
| 128 | (calc-wrapper | 115 | (calc-wrapper |
| 129 | (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg))) | 116 | (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg)))) |
| 130 | ) | ||
| 131 | 117 | ||
| 132 | (defun calc-decrement (arg) | 118 | (defun calc-decrement (arg) |
| 133 | (interactive "p") | 119 | (interactive "p") |
| 134 | (calc-wrapper | 120 | (calc-wrapper |
| 135 | (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg))) | 121 | (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg)))) |
| 136 | ) | ||
| 137 | 122 | ||
| 138 | 123 | ||
| 139 | (defun math-abs-approx (a) | 124 | (defun math-abs-approx (a) |
| @@ -155,12 +140,10 @@ | |||
| 155 | (math-reduce-vec 'math-add-abs-approx a)) | 140 | (math-reduce-vec 'math-add-abs-approx a)) |
| 156 | ((eq (car a) 'calcFunc-abs) | 141 | ((eq (car a) 'calcFunc-abs) |
| 157 | (car a)) | 142 | (car a)) |
| 158 | (t a)) | 143 | (t a))) |
| 159 | ) | ||
| 160 | 144 | ||
| 161 | (defun math-add-abs-approx (a b) | 145 | (defun math-add-abs-approx (a b) |
| 162 | (math-add (math-abs-approx a) (math-abs-approx b)) | 146 | (math-add (math-abs-approx a) (math-abs-approx b))) |
| 163 | ) | ||
| 164 | 147 | ||
| 165 | 148 | ||
| 166 | ;;;; Declarations. | 149 | ;;;; Declarations. |
| @@ -223,23 +206,20 @@ | |||
| 223 | type) | 206 | type) |
| 224 | math-decls-cache))))) | 207 | math-decls-cache))))) |
| 225 | (error nil))))) | 208 | (error nil))))) |
| 226 | (setq math-decls-all (assq 'var-All math-decls-cache)))) | 209 | (setq math-decls-all (assq 'var-All math-decls-cache))))) |
| 227 | ) | ||
| 228 | 210 | ||
| 229 | (defvar math-super-types | 211 | (defvar math-super-types |
| 230 | '( ( int numint rat real number ) | 212 | '((int numint rat real number) |
| 231 | ( numint real number ) | 213 | (numint real number) |
| 232 | ( frac rat real number ) | 214 | (frac rat real number) |
| 233 | ( rat real number ) | 215 | (rat real number) |
| 234 | ( float real number ) | 216 | (float real number) |
| 235 | ( real number ) | 217 | (real number) |
| 236 | ( number ) | 218 | (number) |
| 237 | ( scalar ) | 219 | (scalar) |
| 238 | ( matrix vector ) | 220 | (matrix vector) |
| 239 | ( vector ) | 221 | (vector) |
| 240 | ( const ) | 222 | (const))) |
| 241 | )) | ||
| 242 | |||
| 243 | 223 | ||
| 244 | (defun math-known-scalarp (a &optional assume-scalar) | 224 | (defun math-known-scalarp (a &optional assume-scalar) |
| 245 | (math-setup-declarations) | 225 | (math-setup-declarations) |
| @@ -247,13 +227,11 @@ | |||
| 247 | (eq calc-matrix-mode 'scalar) | 227 | (eq calc-matrix-mode 'scalar) |
| 248 | assume-scalar) | 228 | assume-scalar) |
| 249 | (not (math-check-known-matrixp a)) | 229 | (not (math-check-known-matrixp a)) |
| 250 | (math-check-known-scalarp a)) | 230 | (math-check-known-scalarp a))) |
| 251 | ) | ||
| 252 | 231 | ||
| 253 | (defun math-known-matrixp (a) | 232 | (defun math-known-matrixp (a) |
| 254 | (and (not (Math-scalarp a)) | 233 | (and (not (Math-scalarp a)) |
| 255 | (not (math-known-scalarp a t))) | 234 | (not (math-known-scalarp a t)))) |
| 256 | ) | ||
| 257 | 235 | ||
| 258 | ;;; Try to prove that A is a scalar (i.e., a non-vector). | 236 | ;;; Try to prove that A is a scalar (i.e., a non-vector). |
| 259 | (defun math-check-known-scalarp (a) | 237 | (defun math-check-known-scalarp (a) |
| @@ -274,8 +252,7 @@ | |||
| 274 | (or (assq (nth 2 a) math-decls-cache) | 252 | (or (assq (nth 2 a) math-decls-cache) |
| 275 | math-decls-all) | 253 | math-decls-all) |
| 276 | (assq (car a) math-decls-cache)))) | 254 | (assq (car a) math-decls-cache)))) |
| 277 | (memq 'scalar (nth 1 decl))))) | 255 | (memq 'scalar (nth 1 decl)))))) |
| 278 | ) | ||
| 279 | 256 | ||
| 280 | ;;; Try to prove that A is *not* a scalar. | 257 | ;;; Try to prove that A is *not* a scalar. |
| 281 | (defun math-check-known-matrixp (a) | 258 | (defun math-check-known-matrixp (a) |
| @@ -294,39 +271,32 @@ | |||
| 294 | (or (assq (nth 2 a) math-decls-cache) | 271 | (or (assq (nth 2 a) math-decls-cache) |
| 295 | math-decls-all) | 272 | math-decls-all) |
| 296 | (assq (car a) math-decls-cache)))) | 273 | (assq (car a) math-decls-cache)))) |
| 297 | (memq 'vector (nth 1 decl))))) | 274 | (memq 'vector (nth 1 decl)))))) |
| 298 | ) | ||
| 299 | 275 | ||
| 300 | 276 | ||
| 301 | ;;; Try to prove that A is a real (i.e., not complex). | 277 | ;;; Try to prove that A is a real (i.e., not complex). |
| 302 | (defun math-known-realp (a) | 278 | (defun math-known-realp (a) |
| 303 | (< (math-possible-signs a) 8) | 279 | (< (math-possible-signs a) 8)) |
| 304 | ) | ||
| 305 | 280 | ||
| 306 | ;;; Try to prove that A is real and positive. | 281 | ;;; Try to prove that A is real and positive. |
| 307 | (defun math-known-posp (a) | 282 | (defun math-known-posp (a) |
| 308 | (eq (math-possible-signs a) 4) | 283 | (eq (math-possible-signs a) 4)) |
| 309 | ) | ||
| 310 | 284 | ||
| 311 | ;;; Try to prove that A is real and negative. | 285 | ;;; Try to prove that A is real and negative. |
| 312 | (defun math-known-negp (a) | 286 | (defun math-known-negp (a) |
| 313 | (eq (math-possible-signs a) 1) | 287 | (eq (math-possible-signs a) 1)) |
| 314 | ) | ||
| 315 | 288 | ||
| 316 | ;;; Try to prove that A is real and nonnegative. | 289 | ;;; Try to prove that A is real and nonnegative. |
| 317 | (defun math-known-nonnegp (a) | 290 | (defun math-known-nonnegp (a) |
| 318 | (memq (math-possible-signs a) '(2 4 6)) | 291 | (memq (math-possible-signs a) '(2 4 6))) |
| 319 | ) | ||
| 320 | 292 | ||
| 321 | ;;; Try to prove that A is real and nonpositive. | 293 | ;;; Try to prove that A is real and nonpositive. |
| 322 | (defun math-known-nonposp (a) | 294 | (defun math-known-nonposp (a) |
| 323 | (memq (math-possible-signs a) '(1 2 3)) | 295 | (memq (math-possible-signs a) '(1 2 3))) |
| 324 | ) | ||
| 325 | 296 | ||
| 326 | ;;; Try to prove that A is nonzero. | 297 | ;;; Try to prove that A is nonzero. |
| 327 | (defun math-known-nonzerop (a) | 298 | (defun math-known-nonzerop (a) |
| 328 | (memq (math-possible-signs a) '(1 4 5 8 9 12 13)) | 299 | (memq (math-possible-signs a) '(1 4 5 8 9 12 13))) |
| 329 | ) | ||
| 330 | 300 | ||
| 331 | ;;; Return true if A is negative, or looks negative but we don't know. | 301 | ;;; Return true if A is negative, or looks negative but we don't know. |
| 332 | (defun math-guess-if-neg (a) | 302 | (defun math-guess-if-neg (a) |
| @@ -335,8 +305,7 @@ | |||
| 335 | t | 305 | t |
| 336 | (if (memq sgn '(2 4 6)) | 306 | (if (memq sgn '(2 4 6)) |
| 337 | nil | 307 | nil |
| 338 | (math-looks-negp a)))) | 308 | (math-looks-negp a))))) |
| 339 | ) | ||
| 340 | 309 | ||
| 341 | ;;; Find the possible signs of A, assuming A is a number of some kind. | 310 | ;;; Find the possible signs of A, assuming A is a number of some kind. |
| 342 | ;;; Returns an integer with bits: 1 may be negative, | 311 | ;;; Returns an integer with bits: 1 may be negative, |
| @@ -524,30 +493,25 @@ | |||
| 524 | (math-possible-signs (nth 2 decl) origin) | 493 | (math-possible-signs (nth 2 decl) origin) |
| 525 | (if (memq 'real (nth 1 decl)) | 494 | (if (memq 'real (nth 1 decl)) |
| 526 | 7 | 495 | 7 |
| 527 | 15))))))))) | 496 | 15)))))))))) |
| 528 | ) | ||
| 529 | 497 | ||
| 530 | (defun math-neg-signs (s1) | 498 | (defun math-neg-signs (s1) |
| 531 | (if (>= s1 8) | 499 | (if (>= s1 8) |
| 532 | (+ 8 (math-neg-signs (- s1 8))) | 500 | (+ 8 (math-neg-signs (- s1 8))) |
| 533 | (+ (if (memq s1 '(1 3 5 7)) 4 0) | 501 | (+ (if (memq s1 '(1 3 5 7)) 4 0) |
| 534 | (if (memq s1 '(2 3 6 7)) 2 0) | 502 | (if (memq s1 '(2 3 6 7)) 2 0) |
| 535 | (if (memq s1 '(4 5 6 7)) 1 0))) | 503 | (if (memq s1 '(4 5 6 7)) 1 0)))) |
| 536 | ) | ||
| 537 | 504 | ||
| 538 | 505 | ||
| 539 | ;;; Try to prove that A is an integer. | 506 | ;;; Try to prove that A is an integer. |
| 540 | (defun math-known-integerp (a) | 507 | (defun math-known-integerp (a) |
| 541 | (eq (math-possible-types a) 1) | 508 | (eq (math-possible-types a) 1)) |
| 542 | ) | ||
| 543 | 509 | ||
| 544 | (defun math-known-num-integerp (a) | 510 | (defun math-known-num-integerp (a) |
| 545 | (<= (math-possible-types a t) 3) | 511 | (<= (math-possible-types a t) 3)) |
| 546 | ) | ||
| 547 | 512 | ||
| 548 | (defun math-known-imagp (a) | 513 | (defun math-known-imagp (a) |
| 549 | (= (math-possible-types a) 16) | 514 | (= (math-possible-types a) 16)) |
| 550 | ) | ||
| 551 | 515 | ||
| 552 | 516 | ||
| 553 | ;;; Find the possible types of A. | 517 | ;;; Find the possible types of A. |
| @@ -705,8 +669,7 @@ | |||
| 705 | (math-possible-types (nth 2 decl))) | 669 | (math-possible-types (nth 2 decl))) |
| 706 | ((memq 'real (nth 1 decl)) | 670 | ((memq 'real (nth 1 decl)) |
| 707 | 15) | 671 | 15) |
| 708 | (t 63))))) | 672 | (t 63)))))) |
| 709 | ) | ||
| 710 | 673 | ||
| 711 | (defun math-known-evenp (a) | 674 | (defun math-known-evenp (a) |
| 712 | (cond ((Math-integerp a) | 675 | (cond ((Math-integerp a) |
| @@ -725,8 +688,7 @@ | |||
| 725 | (and (math-known-oddp (nth 1 a)) | 688 | (and (math-known-oddp (nth 1 a)) |
| 726 | (math-known-oddp (nth 2 a))))) | 689 | (math-known-oddp (nth 2 a))))) |
| 727 | ((eq (car a) 'neg) | 690 | ((eq (car a) 'neg) |
| 728 | (math-known-evenp (nth 1 a)))) | 691 | (math-known-evenp (nth 1 a))))) |
| 729 | ) | ||
| 730 | 692 | ||
| 731 | (defun math-known-oddp (a) | 693 | (defun math-known-oddp (a) |
| 732 | (cond ((Math-integerp a) | 694 | (cond ((Math-integerp a) |
| @@ -740,72 +702,62 @@ | |||
| 740 | (and (math-known-oddp (nth 1 a)) | 702 | (and (math-known-oddp (nth 1 a)) |
| 741 | (math-known-evenp (nth 2 a))))) | 703 | (math-known-evenp (nth 2 a))))) |
| 742 | ((eq (car a) 'neg) | 704 | ((eq (car a) 'neg) |
| 743 | (math-known-oddp (nth 1 a)))) | 705 | (math-known-oddp (nth 1 a))))) |
| 744 | ) | ||
| 745 | 706 | ||
| 746 | 707 | ||
| 747 | (defun calcFunc-dreal (expr) | 708 | (defun calcFunc-dreal (expr) |
| 748 | (let ((types (math-possible-types expr))) | 709 | (let ((types (math-possible-types expr))) |
| 749 | (if (< types 16) 1 | 710 | (if (< types 16) 1 |
| 750 | (if (= (logand types 15) 0) 0 | 711 | (if (= (logand types 15) 0) 0 |
| 751 | (math-reject-arg expr 'realp 'quiet)))) | 712 | (math-reject-arg expr 'realp 'quiet))))) |
| 752 | ) | ||
| 753 | 713 | ||
| 754 | (defun calcFunc-dimag (expr) | 714 | (defun calcFunc-dimag (expr) |
| 755 | (let ((types (math-possible-types expr))) | 715 | (let ((types (math-possible-types expr))) |
| 756 | (if (= types 16) 1 | 716 | (if (= types 16) 1 |
| 757 | (if (= (logand types 16) 0) 0 | 717 | (if (= (logand types 16) 0) 0 |
| 758 | (math-reject-arg expr "Expected an imaginary number")))) | 718 | (math-reject-arg expr "Expected an imaginary number"))))) |
| 759 | ) | ||
| 760 | 719 | ||
| 761 | (defun calcFunc-dpos (expr) | 720 | (defun calcFunc-dpos (expr) |
| 762 | (let ((signs (math-possible-signs expr))) | 721 | (let ((signs (math-possible-signs expr))) |
| 763 | (if (eq signs 4) 1 | 722 | (if (eq signs 4) 1 |
| 764 | (if (memq signs '(1 2 3)) 0 | 723 | (if (memq signs '(1 2 3)) 0 |
| 765 | (math-reject-arg expr 'posp 'quiet)))) | 724 | (math-reject-arg expr 'posp 'quiet))))) |
| 766 | ) | ||
| 767 | 725 | ||
| 768 | (defun calcFunc-dneg (expr) | 726 | (defun calcFunc-dneg (expr) |
| 769 | (let ((signs (math-possible-signs expr))) | 727 | (let ((signs (math-possible-signs expr))) |
| 770 | (if (eq signs 1) 1 | 728 | (if (eq signs 1) 1 |
| 771 | (if (memq signs '(2 4 6)) 0 | 729 | (if (memq signs '(2 4 6)) 0 |
| 772 | (math-reject-arg expr 'negp 'quiet)))) | 730 | (math-reject-arg expr 'negp 'quiet))))) |
| 773 | ) | ||
| 774 | 731 | ||
| 775 | (defun calcFunc-dnonneg (expr) | 732 | (defun calcFunc-dnonneg (expr) |
| 776 | (let ((signs (math-possible-signs expr))) | 733 | (let ((signs (math-possible-signs expr))) |
| 777 | (if (memq signs '(2 4 6)) 1 | 734 | (if (memq signs '(2 4 6)) 1 |
| 778 | (if (eq signs 1) 0 | 735 | (if (eq signs 1) 0 |
| 779 | (math-reject-arg expr 'posp 'quiet)))) | 736 | (math-reject-arg expr 'posp 'quiet))))) |
| 780 | ) | ||
| 781 | 737 | ||
| 782 | (defun calcFunc-dnonzero (expr) | 738 | (defun calcFunc-dnonzero (expr) |
| 783 | (let ((signs (math-possible-signs expr))) | 739 | (let ((signs (math-possible-signs expr))) |
| 784 | (if (memq signs '(1 4 5 8 9 12 13)) 1 | 740 | (if (memq signs '(1 4 5 8 9 12 13)) 1 |
| 785 | (if (eq signs 2) 0 | 741 | (if (eq signs 2) 0 |
| 786 | (math-reject-arg expr 'nonzerop 'quiet)))) | 742 | (math-reject-arg expr 'nonzerop 'quiet))))) |
| 787 | ) | ||
| 788 | 743 | ||
| 789 | (defun calcFunc-dint (expr) | 744 | (defun calcFunc-dint (expr) |
| 790 | (let ((types (math-possible-types expr))) | 745 | (let ((types (math-possible-types expr))) |
| 791 | (if (= types 1) 1 | 746 | (if (= types 1) 1 |
| 792 | (if (= (logand types 1) 0) 0 | 747 | (if (= (logand types 1) 0) 0 |
| 793 | (math-reject-arg expr 'integerp 'quiet)))) | 748 | (math-reject-arg expr 'integerp 'quiet))))) |
| 794 | ) | ||
| 795 | 749 | ||
| 796 | (defun calcFunc-dnumint (expr) | 750 | (defun calcFunc-dnumint (expr) |
| 797 | (let ((types (math-possible-types expr t))) | 751 | (let ((types (math-possible-types expr t))) |
| 798 | (if (<= types 3) 1 | 752 | (if (<= types 3) 1 |
| 799 | (if (= (logand types 3) 0) 0 | 753 | (if (= (logand types 3) 0) 0 |
| 800 | (math-reject-arg expr 'integerp 'quiet)))) | 754 | (math-reject-arg expr 'integerp 'quiet))))) |
| 801 | ) | ||
| 802 | 755 | ||
| 803 | (defun calcFunc-dnatnum (expr) | 756 | (defun calcFunc-dnatnum (expr) |
| 804 | (let ((res (calcFunc-dint expr))) | 757 | (let ((res (calcFunc-dint expr))) |
| 805 | (if (eq res 1) | 758 | (if (eq res 1) |
| 806 | (calcFunc-dnonneg expr) | 759 | (calcFunc-dnonneg expr) |
| 807 | res)) | 760 | res))) |
| 808 | ) | ||
| 809 | 761 | ||
| 810 | (defun calcFunc-deven (expr) | 762 | (defun calcFunc-deven (expr) |
| 811 | (if (math-known-evenp expr) | 763 | (if (math-known-evenp expr) |
| @@ -813,8 +765,7 @@ | |||
| 813 | (if (or (math-known-oddp expr) | 765 | (if (or (math-known-oddp expr) |
| 814 | (= (logand (math-possible-types expr) 3) 0)) | 766 | (= (logand (math-possible-types expr) 3) 0)) |
| 815 | 0 | 767 | 0 |
| 816 | (math-reject-arg expr "Can't tell if expression is odd or even"))) | 768 | (math-reject-arg expr "Can't tell if expression is odd or even")))) |
| 817 | ) | ||
| 818 | 769 | ||
| 819 | (defun calcFunc-dodd (expr) | 770 | (defun calcFunc-dodd (expr) |
| 820 | (if (math-known-oddp expr) | 771 | (if (math-known-oddp expr) |
| @@ -822,15 +773,13 @@ | |||
| 822 | (if (or (math-known-evenp expr) | 773 | (if (or (math-known-evenp expr) |
| 823 | (= (logand (math-possible-types expr) 3) 0)) | 774 | (= (logand (math-possible-types expr) 3) 0)) |
| 824 | 0 | 775 | 0 |
| 825 | (math-reject-arg expr "Can't tell if expression is odd or even"))) | 776 | (math-reject-arg expr "Can't tell if expression is odd or even")))) |
| 826 | ) | ||
| 827 | 777 | ||
| 828 | (defun calcFunc-drat (expr) | 778 | (defun calcFunc-drat (expr) |
| 829 | (let ((types (math-possible-types expr))) | 779 | (let ((types (math-possible-types expr))) |
| 830 | (if (memq types '(1 4 5)) 1 | 780 | (if (memq types '(1 4 5)) 1 |
| 831 | (if (= (logand types 5) 0) 0 | 781 | (if (= (logand types 5) 0) 0 |
| 832 | (math-reject-arg expr "Rational number expected")))) | 782 | (math-reject-arg expr "Rational number expected"))))) |
| 833 | ) | ||
| 834 | 783 | ||
| 835 | (defun calcFunc-drange (expr) | 784 | (defun calcFunc-drange (expr) |
| 836 | (math-setup-declarations) | 785 | (math-setup-declarations) |
| @@ -856,14 +805,12 @@ | |||
| 856 | (intv 1 0 (var inf var-inf))) | 805 | (intv 1 0 (var inf var-inf))) |
| 857 | (intv 3 0 (var inf var-inf)) | 806 | (intv 3 0 (var inf var-inf)) |
| 858 | (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range) | 807 | (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range) |
| 859 | (math-reject-arg expr 'realp 'quiet)))))) | 808 | (math-reject-arg expr 'realp 'quiet))))))) |
| 860 | ) | ||
| 861 | 809 | ||
| 862 | (defun calcFunc-dscalar (a) | 810 | (defun calcFunc-dscalar (a) |
| 863 | (if (math-known-scalarp a) 1 | 811 | (if (math-known-scalarp a) 1 |
| 864 | (if (math-known-matrixp a) 0 | 812 | (if (math-known-matrixp a) 0 |
| 865 | (math-reject-arg a 'objectp 'quiet))) | 813 | (math-reject-arg a 'objectp 'quiet)))) |
| 866 | ) | ||
| 867 | 814 | ||
| 868 | 815 | ||
| 869 | ;;; The following lists are not exhaustive. | 816 | ;;; The following lists are not exhaustive. |
| @@ -871,16 +818,14 @@ | |||
| 871 | calcFunc-cnorm calcFunc-rnorm | 818 | calcFunc-cnorm calcFunc-rnorm |
| 872 | calcFunc-vlen calcFunc-vcount | 819 | calcFunc-vlen calcFunc-vcount |
| 873 | calcFunc-vsum calcFunc-vprod | 820 | calcFunc-vsum calcFunc-vprod |
| 874 | calcFunc-vmin calcFunc-vmax | 821 | calcFunc-vmin calcFunc-vmax)) |
| 875 | )) | ||
| 876 | 822 | ||
| 877 | (defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag | 823 | (defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag |
| 878 | calcFunc-cvec calcFunc-index | 824 | calcFunc-cvec calcFunc-index |
| 879 | calcFunc-trn | 825 | calcFunc-trn |
| 880 | | calcFunc-append | 826 | | calcFunc-append |
| 881 | calcFunc-cons calcFunc-rcons | 827 | calcFunc-cons calcFunc-rcons |
| 882 | calcFunc-tail calcFunc-rhead | 828 | calcFunc-tail calcFunc-rhead)) |
| 883 | )) | ||
| 884 | 829 | ||
| 885 | (defvar math-scalar-if-args-functions '(+ - * / neg)) | 830 | (defvar math-scalar-if-args-functions '(+ - * / neg)) |
| 886 | 831 | ||
| @@ -891,15 +836,12 @@ | |||
| 891 | calcFunc-rounde calcFunc-roundu | 836 | calcFunc-rounde calcFunc-roundu |
| 892 | calcFunc-ffloor calcFunc-fceil | 837 | calcFunc-ffloor calcFunc-fceil |
| 893 | calcFunc-ftrunc calcFunc-fround | 838 | calcFunc-ftrunc calcFunc-fround |
| 894 | calcFunc-frounde calcFunc-froundu | 839 | calcFunc-frounde calcFunc-froundu)) |
| 895 | )) | ||
| 896 | 840 | ||
| 897 | (defvar math-positive-functions '( | 841 | (defvar math-positive-functions '()) |
| 898 | )) | ||
| 899 | 842 | ||
| 900 | (defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm | 843 | (defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm |
| 901 | calcFunc-vlen calcFunc-vcount | 844 | calcFunc-vlen calcFunc-vcount)) |
| 902 | )) | ||
| 903 | 845 | ||
| 904 | (defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs | 846 | (defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs |
| 905 | calcFunc-choose calcFunc-perm | 847 | calcFunc-choose calcFunc-perm |
| @@ -907,47 +849,39 @@ | |||
| 907 | calcFunc-lt calcFunc-gt | 849 | calcFunc-lt calcFunc-gt |
| 908 | calcFunc-leq calcFunc-geq | 850 | calcFunc-leq calcFunc-geq |
| 909 | calcFunc-lnot | 851 | calcFunc-lnot |
| 910 | calcFunc-max calcFunc-min | 852 | calcFunc-max calcFunc-min)) |
| 911 | )) | ||
| 912 | 853 | ||
| 913 | (defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos | 854 | (defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos |
| 914 | calcFunc-tan calcFunc-arctan | 855 | calcFunc-tan calcFunc-arctan |
| 915 | calcFunc-sinh calcFunc-cosh | 856 | calcFunc-sinh calcFunc-cosh |
| 916 | calcFunc-tanh calcFunc-exp | 857 | calcFunc-tanh calcFunc-exp |
| 917 | calcFunc-gamma calcFunc-fact | 858 | calcFunc-gamma calcFunc-fact)) |
| 918 | )) | ||
| 919 | 859 | ||
| 920 | (defvar math-integer-functions '(calcFunc-idiv | 860 | (defvar math-integer-functions '(calcFunc-idiv |
| 921 | calcFunc-isqrt calcFunc-ilog | 861 | calcFunc-isqrt calcFunc-ilog |
| 922 | calcFunc-vlen calcFunc-vcount | 862 | calcFunc-vlen calcFunc-vcount)) |
| 923 | )) | ||
| 924 | 863 | ||
| 925 | (defvar math-num-integer-functions '( | 864 | (defvar math-num-integer-functions '()) |
| 926 | )) | ||
| 927 | 865 | ||
| 928 | (defvar math-rounding-functions '(calcFunc-floor | 866 | (defvar math-rounding-functions '(calcFunc-floor |
| 929 | calcFunc-ceil | 867 | calcFunc-ceil |
| 930 | calcFunc-round calcFunc-trunc | 868 | calcFunc-round calcFunc-trunc |
| 931 | calcFunc-rounde calcFunc-roundu | 869 | calcFunc-rounde calcFunc-roundu)) |
| 932 | )) | ||
| 933 | 870 | ||
| 934 | (defvar math-float-rounding-functions '(calcFunc-ffloor | 871 | (defvar math-float-rounding-functions '(calcFunc-ffloor |
| 935 | calcFunc-fceil | 872 | calcFunc-fceil |
| 936 | calcFunc-fround calcFunc-ftrunc | 873 | calcFunc-fround calcFunc-ftrunc |
| 937 | calcFunc-frounde calcFunc-froundu | 874 | calcFunc-frounde calcFunc-froundu)) |
| 938 | )) | ||
| 939 | 875 | ||
| 940 | (defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs | 876 | (defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs |
| 941 | calcFunc-min calcFunc-max | 877 | calcFunc-min calcFunc-max |
| 942 | calcFunc-choose calcFunc-perm | 878 | calcFunc-choose calcFunc-perm)) |
| 943 | )) | ||
| 944 | 879 | ||
| 945 | 880 | ||
| 946 | ;;;; Arithmetic. | 881 | ;;;; Arithmetic. |
| 947 | 882 | ||
| 948 | (defun calcFunc-neg (a) | 883 | (defun calcFunc-neg (a) |
| 949 | (math-normalize (list 'neg a)) | 884 | (math-normalize (list 'neg a))) |
| 950 | ) | ||
| 951 | 885 | ||
| 952 | (defun math-neg-fancy (a) | 886 | (defun math-neg-fancy (a) |
| 953 | (cond ((eq (car a) 'polar) | 887 | (cond ((eq (car a) 'polar) |
| @@ -993,17 +927,14 @@ | |||
| 993 | a) | 927 | a) |
| 994 | ((eq (car a) 'neg) | 928 | ((eq (car a) 'neg) |
| 995 | (nth 1 a)) | 929 | (nth 1 a)) |
| 996 | (t (list 'neg a))) | 930 | (t (list 'neg a)))) |
| 997 | ) | ||
| 998 | 931 | ||
| 999 | (defun math-okay-neg (a) | 932 | (defun math-okay-neg (a) |
| 1000 | (or (math-looks-negp a) | 933 | (or (math-looks-negp a) |
| 1001 | (eq (car-safe a) '-)) | 934 | (eq (car-safe a) '-))) |
| 1002 | ) | ||
| 1003 | 935 | ||
| 1004 | (defun math-neg-float (a) | 936 | (defun math-neg-float (a) |
| 1005 | (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a)) | 937 | (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a))) |
| 1006 | ) | ||
| 1007 | 938 | ||
| 1008 | 939 | ||
| 1009 | (defun calcFunc-add (&rest rest) | 940 | (defun calcFunc-add (&rest rest) |
| @@ -1012,8 +943,7 @@ | |||
| 1012 | (while (setq rest (cdr rest)) | 943 | (while (setq rest (cdr rest)) |
| 1013 | (setq a (list '+ a (car rest)))) | 944 | (setq a (list '+ a (car rest)))) |
| 1014 | (math-normalize a)) | 945 | (math-normalize a)) |
| 1015 | 0) | 946 | 0)) |
| 1016 | ) | ||
| 1017 | 947 | ||
| 1018 | (defun calcFunc-sub (&rest rest) | 948 | (defun calcFunc-sub (&rest rest) |
| 1019 | (if rest | 949 | (if rest |
| @@ -1021,8 +951,7 @@ | |||
| 1021 | (while (setq rest (cdr rest)) | 951 | (while (setq rest (cdr rest)) |
| 1022 | (setq a (list '- a (car rest)))) | 952 | (setq a (list '- a (car rest)))) |
| 1023 | (math-normalize a)) | 953 | (math-normalize a)) |
| 1024 | 0) | 954 | 0)) |
| 1025 | ) | ||
| 1026 | 955 | ||
| 1027 | (defun math-add-objects-fancy (a b) | 956 | (defun math-add-objects-fancy (a b) |
| 1028 | (cond ((and (Math-numberp a) (Math-numberp b)) | 957 | (cond ((and (Math-numberp a) (Math-numberp b)) |
| @@ -1130,8 +1059,7 @@ | |||
| 1130 | (m (math-add (nth 2 a) (nth 2 b))) | 1059 | (m (math-add (nth 2 a) (nth 2 b))) |
| 1131 | (h (math-add (nth 1 a) (nth 1 b)))) | 1060 | (h (math-add (nth 1 a) (nth 1 b)))) |
| 1132 | (list 'hms h m s)))))) | 1061 | (list 'hms h m s)))))) |
| 1133 | (t (calc-record-why "*Incompatible arguments for +" a b))) | 1062 | (t (calc-record-why "*Incompatible arguments for +" a b)))) |
| 1134 | ) | ||
| 1135 | 1063 | ||
| 1136 | (defun math-add-symb-fancy (a b) | 1064 | (defun math-add-symb-fancy (a b) |
| 1137 | (or (and math-simplify-only | 1065 | (or (and math-simplify-only |
| @@ -1210,8 +1138,7 @@ | |||
| 1210 | (math-add a (math-mimic-ident (nth 1 b) a))) | 1138 | (math-add a (math-mimic-ident (nth 1 b) a))) |
| 1211 | (and (math-known-scalarp a) | 1139 | (and (math-known-scalarp a) |
| 1212 | (math-add a (nth 1 b))))) | 1140 | (math-add a (nth 1 b))))) |
| 1213 | (list '+ a b)) | 1141 | (list '+ a b))) |
| 1214 | ) | ||
| 1215 | 1142 | ||
| 1216 | 1143 | ||
| 1217 | (defun calcFunc-mul (&rest rest) | 1144 | (defun calcFunc-mul (&rest rest) |
| @@ -1220,8 +1147,7 @@ | |||
| 1220 | (while (setq rest (cdr rest)) | 1147 | (while (setq rest (cdr rest)) |
| 1221 | (setq a (list '* a (car rest)))) | 1148 | (setq a (list '* a (car rest)))) |
| 1222 | (math-normalize a)) | 1149 | (math-normalize a)) |
| 1223 | 1) | 1150 | 1)) |
| 1224 | ) | ||
| 1225 | 1151 | ||
| 1226 | (defun math-mul-objects-fancy (a b) | 1152 | (defun math-mul-objects-fancy (a b) |
| 1227 | (cond ((and (Math-numberp a) (Math-numberp b)) | 1153 | (cond ((and (Math-numberp a) (Math-numberp b)) |
| @@ -1320,19 +1246,16 @@ | |||
| 1320 | (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg))) | 1246 | (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg))) |
| 1321 | ((and (eq (car-safe b) 'hms) (Math-realp a)) | 1247 | ((and (eq (car-safe b) 'hms) (Math-realp a)) |
| 1322 | (math-mul b a)) | 1248 | (math-mul b a)) |
| 1323 | (t (calc-record-why "*Incompatible arguments for *" a b))) | 1249 | (t (calc-record-why "*Incompatible arguments for *" a b)))) |
| 1324 | ) | ||
| 1325 | 1250 | ||
| 1326 | ;;; Fast function to multiply floating-point numbers. | 1251 | ;;; Fast function to multiply floating-point numbers. |
| 1327 | (defun math-mul-float (a b) ; [F F F] | 1252 | (defun math-mul-float (a b) ; [F F F] |
| 1328 | (math-make-float (math-mul (nth 1 a) (nth 1 b)) | 1253 | (math-make-float (math-mul (nth 1 a) (nth 1 b)) |
| 1329 | (+ (nth 2 a) (nth 2 b))) | 1254 | (+ (nth 2 a) (nth 2 b)))) |
| 1330 | ) | ||
| 1331 | 1255 | ||
| 1332 | (defun math-sqr-float (a) ; [F F] | 1256 | (defun math-sqr-float (a) ; [F F] |
| 1333 | (math-make-float (math-mul (nth 1 a) (nth 1 a)) | 1257 | (math-make-float (math-mul (nth 1 a) (nth 1 a)) |
| 1334 | (+ (nth 2 a) (nth 2 a))) | 1258 | (+ (nth 2 a) (nth 2 a)))) |
| 1335 | ) | ||
| 1336 | 1259 | ||
| 1337 | (defun math-intv-constp (a &optional finite) | 1260 | (defun math-intv-constp (a &optional finite) |
| 1338 | (and (or (Math-anglep (nth 2 a)) | 1261 | (and (or (Math-anglep (nth 2 a)) |
| @@ -1342,8 +1265,7 @@ | |||
| 1342 | (or (Math-anglep (nth 3 a)) | 1265 | (or (Math-anglep (nth 3 a)) |
| 1343 | (and (equal (nth 3 a) '(var inf var-inf)) | 1266 | (and (equal (nth 3 a) '(var inf var-inf)) |
| 1344 | (or (not finite) | 1267 | (or (not finite) |
| 1345 | (memq (nth 1 a) '(0 2)))))) | 1268 | (memq (nth 1 a) '(0 2))))))) |
| 1346 | ) | ||
| 1347 | 1269 | ||
| 1348 | (defun math-mul-zero (a b) | 1270 | (defun math-mul-zero (a b) |
| 1349 | (if (math-known-matrixp b) | 1271 | (if (math-known-matrixp b) |
| @@ -1371,8 +1293,7 @@ | |||
| 1371 | (if (math-negp a) | 1293 | (if (math-negp a) |
| 1372 | (math-neg (list 'intv 3 (or aa 0) (or bb 0))) | 1294 | (math-neg (list 'intv 3 (or aa 0) (or bb 0))) |
| 1373 | '(var nan var-nan))) | 1295 | '(var nan var-nan))) |
| 1374 | (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0))))) | 1296 | (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)))))) |
| 1375 | ) | ||
| 1376 | 1297 | ||
| 1377 | 1298 | ||
| 1378 | (defun math-mul-symb-fancy (a b) | 1299 | (defun math-mul-symb-fancy (a b) |
| @@ -1484,16 +1405,14 @@ | |||
| 1484 | (list '* (list 'polar 1 (nth 2 a)) b))))) | 1405 | (list '* (list 'polar 1 (nth 2 a)) b))))) |
| 1485 | (and (equal a '(var inf var-inf)) | 1406 | (and (equal a '(var inf var-inf)) |
| 1486 | (math-mul b a)) | 1407 | (math-mul b a)) |
| 1487 | (list '* a b)) | 1408 | (list '* a b))) |
| 1488 | ) | ||
| 1489 | 1409 | ||
| 1490 | 1410 | ||
| 1491 | (defun calcFunc-div (a &rest rest) | 1411 | (defun calcFunc-div (a &rest rest) |
| 1492 | (while rest | 1412 | (while rest |
| 1493 | (setq a (list '/ a (car rest)) | 1413 | (setq a (list '/ a (car rest)) |
| 1494 | rest (cdr rest))) | 1414 | rest (cdr rest))) |
| 1495 | (math-normalize a) | 1415 | (math-normalize a)) |
| 1496 | ) | ||
| 1497 | 1416 | ||
| 1498 | (defun math-div-objects-fancy (a b) | 1417 | (defun math-div-objects-fancy (a b) |
| 1499 | (cond ((and (Math-numberp a) (Math-numberp b)) | 1418 | (cond ((and (Math-numberp a) (Math-numberp b)) |
| @@ -1640,8 +1559,7 @@ | |||
| 1640 | (math-from-hms b 'deg))) | 1559 | (math-from-hms b 'deg))) |
| 1641 | (math-with-extra-prec 2 | 1560 | (math-with-extra-prec 2 |
| 1642 | (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg)))) | 1561 | (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg)))) |
| 1643 | (t (calc-record-why "*Incompatible arguments for /" a b))) | 1562 | (t (calc-record-why "*Incompatible arguments for /" a b)))) |
| 1644 | ) | ||
| 1645 | 1563 | ||
| 1646 | (defun math-div-by-zero (a b) | 1564 | (defun math-div-by-zero (a b) |
| 1647 | (if (math-infinitep a) | 1565 | (if (math-infinitep a) |
| @@ -1660,8 +1578,7 @@ | |||
| 1660 | (if (eq (car-safe a) 'intv) | 1578 | (if (eq (car-safe a) 'intv) |
| 1661 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) | 1579 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
| 1662 | '(var uinf var-uinf))))) | 1580 | '(var uinf var-uinf))))) |
| 1663 | (math-reject-arg a "*Division by zero"))) | 1581 | (math-reject-arg a "*Division by zero")))) |
| 1664 | ) | ||
| 1665 | 1582 | ||
| 1666 | (defun math-div-zero (a b) | 1583 | (defun math-div-zero (a b) |
| 1667 | (if (math-known-matrixp b) | 1584 | (if (math-known-matrixp b) |
| @@ -1681,8 +1598,7 @@ | |||
| 1681 | (memq calc-infinite-mode '(1 -1))) | 1598 | (memq calc-infinite-mode '(1 -1))) |
| 1682 | (nth 3 b) '(var inf var-inf))) | 1599 | (nth 3 b) '(var inf var-inf))) |
| 1683 | (math-reject-arg b "*Division by zero")) | 1600 | (math-reject-arg b "*Division by zero")) |
| 1684 | a))) | 1601 | a)))) |
| 1685 | ) | ||
| 1686 | 1602 | ||
| 1687 | (defun math-div-symb-fancy (a b) | 1603 | (defun math-div-symb-fancy (a b) |
| 1688 | (or (and math-simplify-only | 1604 | (or (and math-simplify-only |
| @@ -1788,13 +1704,11 @@ | |||
| 1788 | b | 1704 | b |
| 1789 | (let ((calc-infinite-mode 1)) | 1705 | (let ((calc-infinite-mode 1)) |
| 1790 | (math-mul-zero b a)))) | 1706 | (math-mul-zero b a)))) |
| 1791 | (list '/ a b)) | 1707 | (list '/ a b))) |
| 1792 | ) | ||
| 1793 | 1708 | ||
| 1794 | 1709 | ||
| 1795 | (defun calcFunc-mod (a b) | 1710 | (defun calcFunc-mod (a b) |
| 1796 | (math-normalize (list '% a b)) | 1711 | (math-normalize (list '% a b))) |
| 1797 | ) | ||
| 1798 | 1712 | ||
| 1799 | (defun math-mod-fancy (a b) | 1713 | (defun math-mod-fancy (a b) |
| 1800 | (cond ((equal b '(var inf var-inf)) | 1714 | (cond ((equal b '(var inf var-inf)) |
| @@ -1815,13 +1729,11 @@ | |||
| 1815 | (if (Math-anglep a) | 1729 | (if (Math-anglep a) |
| 1816 | (calc-record-why 'anglep b) | 1730 | (calc-record-why 'anglep b) |
| 1817 | (calc-record-why 'anglep a)) | 1731 | (calc-record-why 'anglep a)) |
| 1818 | (list '% a b))) | 1732 | (list '% a b)))) |
| 1819 | ) | ||
| 1820 | 1733 | ||
| 1821 | 1734 | ||
| 1822 | (defun calcFunc-pow (a b) | 1735 | (defun calcFunc-pow (a b) |
| 1823 | (math-normalize (list '^ a b)) | 1736 | (math-normalize (list '^ a b))) |
| 1824 | ) | ||
| 1825 | 1737 | ||
| 1826 | (defun math-pow-of-zero (a b) | 1738 | (defun math-pow-of-zero (a b) |
| 1827 | (if (Math-zerop b) | 1739 | (if (Math-zerop b) |
| @@ -1840,8 +1752,7 @@ | |||
| 1840 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) | 1752 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
| 1841 | (if (math-objectp b) | 1753 | (if (math-objectp b) |
| 1842 | (list '^ a b) | 1754 | (list '^ a b) |
| 1843 | a)))))) | 1755 | a))))))) |
| 1844 | ) | ||
| 1845 | 1756 | ||
| 1846 | (defun math-pow-zero (a b) | 1757 | (defun math-pow-zero (a b) |
| 1847 | (if (eq (car-safe a) 'mod) | 1758 | (if (eq (car-safe a) 'mod) |
| @@ -1855,8 +1766,7 @@ | |||
| 1855 | (not (math-intv-constp a t)))) | 1766 | (not (math-intv-constp a t)))) |
| 1856 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) | 1767 | '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
| 1857 | (if (or (math-floatp a) (math-floatp b)) | 1768 | (if (or (math-floatp a) (math-floatp b)) |
| 1858 | '(float 1 0) 1))))) | 1769 | '(float 1 0) 1)))))) |
| 1859 | ) | ||
| 1860 | 1770 | ||
| 1861 | (defun math-pow-fancy (a b) | 1771 | (defun math-pow-fancy (a b) |
| 1862 | (cond ((and (Math-numberp a) (Math-numberp b)) | 1772 | (cond ((and (Math-numberp a) (Math-numberp b)) |
| @@ -2063,8 +1973,7 @@ | |||
| 2063 | ((not (Math-numberp a)) | 1973 | ((not (Math-numberp a)) |
| 2064 | (math-reject-arg a 'numberp)) | 1974 | (math-reject-arg a 'numberp)) |
| 2065 | (t | 1975 | (t |
| 2066 | (math-reject-arg b 'numberp))) | 1976 | (math-reject-arg b 'numberp)))) |
| 2067 | ) | ||
| 2068 | 1977 | ||
| 2069 | (defun math-quarter-integer (x) | 1978 | (defun math-quarter-integer (x) |
| 2070 | (if (Math-integerp x) | 1979 | (if (Math-integerp x) |
| @@ -2092,8 +2001,7 @@ | |||
| 2092 | (setq x (nth 1 x) | 2001 | (setq x (nth 1 x) |
| 2093 | x (% (if (consp x) (nth 1 x) x) 100)) | 2002 | x (% (if (consp x) (nth 1 x) x) 100)) |
| 2094 | (if (= x 25) 1 | 2003 | (if (= x 25) 1 |
| 2095 | (if (= x 75) 3)))))))))) | 2004 | (if (= x 75) 3))))))))))) |
| 2096 | ) | ||
| 2097 | 2005 | ||
| 2098 | ;;; This assumes A < M and M > 0. | 2006 | ;;; This assumes A < M and M > 0. |
| 2099 | (defun math-pow-mod (a b m) ; [R R R R] | 2007 | (defun math-pow-mod (a b m) ; [R R R R] |
| @@ -2103,8 +2011,7 @@ | |||
| 2103 | (if (eq m 1) | 2011 | (if (eq m 1) |
| 2104 | 0 | 2012 | 0 |
| 2105 | (math-pow-mod-step a b m))) | 2013 | (math-pow-mod-step a b m))) |
| 2106 | (math-mod (math-pow a b) m)) | 2014 | (math-mod (math-pow a b) m))) |
| 2107 | ) | ||
| 2108 | 2015 | ||
| 2109 | (defun math-pow-mod-step (a n m) ; [I I I I] | 2016 | (defun math-pow-mod-step (a n m) ; [I I I I] |
| 2110 | (math-working "pow" a) | 2017 | (math-working "pow" a) |
| @@ -2120,8 +2027,7 @@ | |||
| 2120 | rest | 2027 | rest |
| 2121 | (math-mod (math-mul a rest) m))))))) | 2028 | (math-mod (math-mul a rest) m))))))) |
| 2122 | (math-working "pow" val) | 2029 | (math-working "pow" val) |
| 2123 | val) | 2030 | val)) |
| 2124 | ) | ||
| 2125 | 2031 | ||
| 2126 | 2032 | ||
| 2127 | ;;; Compute the minimum of two real numbers. [R R R] [Public] | 2033 | ;;; Compute the minimum of two real numbers. [R R R] [Public] |
| @@ -2150,8 +2056,7 @@ | |||
| 2150 | b | 2056 | b |
| 2151 | (if (= res 2) | 2057 | (if (= res 2) |
| 2152 | '(var nan var-nan) | 2058 | '(var nan var-nan) |
| 2153 | a))))) | 2059 | a)))))) |
| 2154 | ) | ||
| 2155 | 2060 | ||
| 2156 | (defun calcFunc-min (&optional a &rest b) | 2061 | (defun calcFunc-min (&optional a &rest b) |
| 2157 | (if (not a) | 2062 | (if (not a) |
| @@ -2160,8 +2065,7 @@ | |||
| 2160 | (and (eq (car a) 'intv) (math-intv-constp a)) | 2065 | (and (eq (car a) 'intv) (math-intv-constp a)) |
| 2161 | (math-infinitep a))) | 2066 | (math-infinitep a))) |
| 2162 | (math-reject-arg a 'anglep)) | 2067 | (math-reject-arg a 'anglep)) |
| 2163 | (math-min-list a b)) | 2068 | (math-min-list a b))) |
| 2164 | ) | ||
| 2165 | 2069 | ||
| 2166 | (defun math-min-list (a b) | 2070 | (defun math-min-list (a b) |
| 2167 | (if b | 2071 | (if b |
| @@ -2170,8 +2074,7 @@ | |||
| 2170 | (math-infinitep (car b))) | 2074 | (math-infinitep (car b))) |
| 2171 | (math-min-list (math-min a (car b)) (cdr b)) | 2075 | (math-min-list (math-min a (car b)) (cdr b)) |
| 2172 | (math-reject-arg (car b) 'anglep)) | 2076 | (math-reject-arg (car b) 'anglep)) |
| 2173 | a) | 2077 | a)) |
| 2174 | ) | ||
| 2175 | 2078 | ||
| 2176 | ;;; Compute the maximum of two real numbers. [R R R] [Public] | 2079 | ;;; Compute the maximum of two real numbers. [R R R] [Public] |
| 2177 | (defun math-max (a b) | 2080 | (defun math-max (a b) |
| @@ -2183,8 +2086,7 @@ | |||
| 2183 | b | 2086 | b |
| 2184 | (if (= res 2) | 2087 | (if (= res 2) |
| 2185 | '(var nan var-nan) | 2088 | '(var nan var-nan) |
| 2186 | a)))) | 2089 | a))))) |
| 2187 | ) | ||
| 2188 | 2090 | ||
| 2189 | (defun calcFunc-max (&optional a &rest b) | 2091 | (defun calcFunc-max (&optional a &rest b) |
| 2190 | (if (not a) | 2092 | (if (not a) |
| @@ -2193,8 +2095,7 @@ | |||
| 2193 | (and (eq (car a) 'intv) (math-intv-constp a)) | 2095 | (and (eq (car a) 'intv) (math-intv-constp a)) |
| 2194 | (math-infinitep a))) | 2096 | (math-infinitep a))) |
| 2195 | (math-reject-arg a 'anglep)) | 2097 | (math-reject-arg a 'anglep)) |
| 2196 | (math-max-list a b)) | 2098 | (math-max-list a b))) |
| 2197 | ) | ||
| 2198 | 2099 | ||
| 2199 | (defun math-max-list (a b) | 2100 | (defun math-max-list (a b) |
| 2200 | (if b | 2101 | (if b |
| @@ -2203,8 +2104,7 @@ | |||
| 2203 | (math-infinitep (car b))) | 2104 | (math-infinitep (car b))) |
| 2204 | (math-max-list (math-max a (car b)) (cdr b)) | 2105 | (math-max-list (math-max a (car b)) (cdr b)) |
| 2205 | (math-reject-arg (car b) 'anglep)) | 2106 | (math-reject-arg (car b) 'anglep)) |
| 2206 | a) | 2107 | a)) |
| 2207 | ) | ||
| 2208 | 2108 | ||
| 2209 | 2109 | ||
| 2210 | ;;; Compute the absolute value of A. [O O; r r] [Public] | 2110 | ;;; Compute the absolute value of A. [O O; r r] [Public] |
| @@ -2250,10 +2150,9 @@ | |||
| 2250 | inf | 2150 | inf |
| 2251 | '(var inf var-inf))))) | 2151 | '(var inf var-inf))))) |
| 2252 | (t (calc-record-why 'numvecp a) | 2152 | (t (calc-record-why 'numvecp a) |
| 2253 | (list 'calcFunc-abs a))) | 2153 | (list 'calcFunc-abs a)))) |
| 2254 | ) | ||
| 2255 | (fset 'calcFunc-abs (symbol-function 'math-abs)) | ||
| 2256 | 2154 | ||
| 2155 | (defalias 'calcFunc-abs 'math-abs) | ||
| 2257 | 2156 | ||
| 2258 | (defun math-float-fancy (a) | 2157 | (defun math-float-fancy (a) |
| 2259 | (cond ((eq (car a) 'intv) | 2158 | (cond ((eq (car a) 'intv) |
| @@ -2276,10 +2175,9 @@ | |||
| 2276 | (calcFunc-rounde . calcFunc-frounde) | 2175 | (calcFunc-rounde . calcFunc-frounde) |
| 2277 | (calcFunc-roundu . calcFunc-froundu))))) | 2176 | (calcFunc-roundu . calcFunc-froundu))))) |
| 2278 | (and func (cons (cdr func) (cdr a))))) | 2177 | (and func (cons (cdr func) (cdr a))))) |
| 2279 | (t (math-reject-arg a 'objectp))) | 2178 | (t (math-reject-arg a 'objectp)))) |
| 2280 | ) | ||
| 2281 | (fset 'calcFunc-float (symbol-function 'math-float)) | ||
| 2282 | 2179 | ||
| 2180 | (defalias 'calcFunc-float 'math-float) | ||
| 2283 | 2181 | ||
| 2284 | (defun math-trunc-fancy (a) | 2182 | (defun math-trunc-fancy (a) |
| 2285 | (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) | 2183 | (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) |
| @@ -2316,8 +2214,7 @@ | |||
| 2316 | a | 2214 | a |
| 2317 | '(var nan var-nan))) | 2215 | '(var nan var-nan))) |
| 2318 | ((math-to-integer a)) | 2216 | ((math-to-integer a)) |
| 2319 | (t (math-reject-arg a 'numberp))) | 2217 | (t (math-reject-arg a 'numberp)))) |
| 2320 | ) | ||
| 2321 | 2218 | ||
| 2322 | (defun math-trunc-special (a prec) | 2219 | (defun math-trunc-special (a prec) |
| 2323 | (if (Math-messy-integerp prec) | 2220 | (if (Math-messy-integerp prec) |
| @@ -2329,8 +2226,7 @@ | |||
| 2329 | a | 2226 | a |
| 2330 | (calcFunc-scf (math-trunc (let ((calc-prefer-frac t)) | 2227 | (calcFunc-scf (math-trunc (let ((calc-prefer-frac t)) |
| 2331 | (calcFunc-scf a prec))) | 2228 | (calcFunc-scf a prec))) |
| 2332 | (- prec))) | 2229 | (- prec)))) |
| 2333 | ) | ||
| 2334 | 2230 | ||
| 2335 | (defun math-to-integer (a) | 2231 | (defun math-to-integer (a) |
| 2336 | (let ((func (assq (car-safe a) '((calcFunc-ffloor . calcFunc-floor) | 2232 | (let ((func (assq (car-safe a) '((calcFunc-ffloor . calcFunc-floor) |
| @@ -2340,16 +2236,14 @@ | |||
| 2340 | (calcFunc-frounde . calcFunc-rounde) | 2236 | (calcFunc-frounde . calcFunc-rounde) |
| 2341 | (calcFunc-froundu . calcFunc-roundu))))) | 2237 | (calcFunc-froundu . calcFunc-roundu))))) |
| 2342 | (and func (= (length a) 2) | 2238 | (and func (= (length a) 2) |
| 2343 | (cons (cdr func) (cdr a)))) | 2239 | (cons (cdr func) (cdr a))))) |
| 2344 | ) | ||
| 2345 | 2240 | ||
| 2346 | (defun calcFunc-ftrunc (a &optional prec) | 2241 | (defun calcFunc-ftrunc (a &optional prec) |
| 2347 | (if (and (Math-messy-integerp a) | 2242 | (if (and (Math-messy-integerp a) |
| 2348 | (or (not prec) (and (integerp prec) | 2243 | (or (not prec) (and (integerp prec) |
| 2349 | (<= prec 0)))) | 2244 | (<= prec 0)))) |
| 2350 | a | 2245 | a |
| 2351 | (math-float (math-trunc a prec))) | 2246 | (math-float (math-trunc a prec)))) |
| 2352 | ) | ||
| 2353 | 2247 | ||
| 2354 | (defun math-floor-fancy (a) | 2248 | (defun math-floor-fancy (a) |
| 2355 | (cond ((math-provably-integerp a) a) | 2249 | (cond ((math-provably-integerp a) a) |
| @@ -2379,8 +2273,7 @@ | |||
| 2379 | a | 2273 | a |
| 2380 | '(var nan var-nan))) | 2274 | '(var nan var-nan))) |
| 2381 | ((math-to-integer a)) | 2275 | ((math-to-integer a)) |
| 2382 | (t (math-reject-arg a 'anglep))) | 2276 | (t (math-reject-arg a 'anglep)))) |
| 2383 | ) | ||
| 2384 | 2277 | ||
| 2385 | (defun math-floor-special (a prec) | 2278 | (defun math-floor-special (a prec) |
| 2386 | (if (Math-messy-integerp prec) | 2279 | (if (Math-messy-integerp prec) |
| @@ -2392,16 +2285,14 @@ | |||
| 2392 | a | 2285 | a |
| 2393 | (calcFunc-scf (math-floor (let ((calc-prefer-frac t)) | 2286 | (calcFunc-scf (math-floor (let ((calc-prefer-frac t)) |
| 2394 | (calcFunc-scf a prec))) | 2287 | (calcFunc-scf a prec))) |
| 2395 | (- prec))) | 2288 | (- prec)))) |
| 2396 | ) | ||
| 2397 | 2289 | ||
| 2398 | (defun calcFunc-ffloor (a &optional prec) | 2290 | (defun calcFunc-ffloor (a &optional prec) |
| 2399 | (if (and (Math-messy-integerp a) | 2291 | (if (and (Math-messy-integerp a) |
| 2400 | (or (not prec) (and (integerp prec) | 2292 | (or (not prec) (and (integerp prec) |
| 2401 | (<= prec 0)))) | 2293 | (<= prec 0)))) |
| 2402 | a | 2294 | a |
| 2403 | (math-float (math-floor a prec))) | 2295 | (math-float (math-floor a prec)))) |
| 2404 | ) | ||
| 2405 | 2296 | ||
| 2406 | ;;; Coerce A to be an integer (by truncation toward plus infinity). [I N] | 2297 | ;;; Coerce A to be an integer (by truncation toward plus infinity). [I N] |
| 2407 | (defun math-ceiling (a &optional prec) ; [Public] | 2298 | (defun math-ceiling (a &optional prec) ; [Public] |
| @@ -2449,17 +2340,16 @@ | |||
| 2449 | a | 2340 | a |
| 2450 | '(var nan var-nan))) | 2341 | '(var nan var-nan))) |
| 2451 | ((math-to-integer a)) | 2342 | ((math-to-integer a)) |
| 2452 | (t (math-reject-arg a 'anglep))) | 2343 | (t (math-reject-arg a 'anglep)))) |
| 2453 | ) | 2344 | |
| 2454 | (fset 'calcFunc-ceil (symbol-function 'math-ceiling)) | 2345 | (defalias 'calcFunc-ceil 'math-ceiling) |
| 2455 | 2346 | ||
| 2456 | (defun calcFunc-fceil (a &optional prec) | 2347 | (defun calcFunc-fceil (a &optional prec) |
| 2457 | (if (and (Math-messy-integerp a) | 2348 | (if (and (Math-messy-integerp a) |
| 2458 | (or (not prec) (and (integerp prec) | 2349 | (or (not prec) (and (integerp prec) |
| 2459 | (<= prec 0)))) | 2350 | (<= prec 0)))) |
| 2460 | a | 2351 | a |
| 2461 | (math-float (math-ceiling a prec))) | 2352 | (math-float (math-ceiling a prec)))) |
| 2462 | ) | ||
| 2463 | 2353 | ||
| 2464 | (setq math-rounding-mode nil) | 2354 | (setq math-rounding-mode nil) |
| 2465 | 2355 | ||
| @@ -2503,38 +2393,32 @@ | |||
| 2503 | a | 2393 | a |
| 2504 | '(var nan var-nan))) | 2394 | '(var nan var-nan))) |
| 2505 | ((math-to-integer a)) | 2395 | ((math-to-integer a)) |
| 2506 | (t (math-reject-arg a 'anglep))) | 2396 | (t (math-reject-arg a 'anglep)))) |
| 2507 | ) | ||
| 2508 | (fset 'calcFunc-round (symbol-function 'math-round)) | ||
| 2509 | 2397 | ||
| 2510 | (defun calcFunc-rounde (a &optional prec) | 2398 | (defalias 'calcFunc-round 'math-round) |
| 2399 | |||
| 2400 | (defsubst calcFunc-rounde (a &optional prec) | ||
| 2511 | (let ((math-rounding-mode 'even)) | 2401 | (let ((math-rounding-mode 'even)) |
| 2512 | (math-round a prec)) | 2402 | (math-round a prec))) |
| 2513 | ) | ||
| 2514 | 2403 | ||
| 2515 | (defun calcFunc-roundu (a &optional prec) | 2404 | (defsubst calcFunc-roundu (a &optional prec) |
| 2516 | (let ((math-rounding-mode 'up)) | 2405 | (let ((math-rounding-mode 'up)) |
| 2517 | (math-round a prec)) | 2406 | (math-round a prec))) |
| 2518 | ) | ||
| 2519 | 2407 | ||
| 2520 | (defun calcFunc-fround (a &optional prec) | 2408 | (defun calcFunc-fround (a &optional prec) |
| 2521 | (if (and (Math-messy-integerp a) | 2409 | (if (and (Math-messy-integerp a) |
| 2522 | (or (not prec) (and (integerp prec) | 2410 | (or (not prec) (and (integerp prec) |
| 2523 | (<= prec 0)))) | 2411 | (<= prec 0)))) |
| 2524 | a | 2412 | a |
| 2525 | (math-float (math-round a prec))) | 2413 | (math-float (math-round a prec)))) |
| 2526 | ) | ||
| 2527 | 2414 | ||
| 2528 | (defun calcFunc-frounde (a &optional prec) | 2415 | (defsubst calcFunc-frounde (a &optional prec) |
| 2529 | (let ((math-rounding-mode 'even)) | 2416 | (let ((math-rounding-mode 'even)) |
| 2530 | (calcFunc-fround a prec)) | 2417 | (calcFunc-fround a prec))) |
| 2531 | ) | ||
| 2532 | 2418 | ||
| 2533 | (defun calcFunc-froundu (a &optional prec) | 2419 | (defsubst calcFunc-froundu (a &optional prec) |
| 2534 | (let ((math-rounding-mode 'up)) | 2420 | (let ((math-rounding-mode 'up)) |
| 2535 | (calcFunc-fround a prec)) | 2421 | (calcFunc-fround a prec))) |
| 2536 | ) | ||
| 2537 | |||
| 2538 | 2422 | ||
| 2539 | ;;; Pull floating-point values apart into mantissa and exponent. | 2423 | ;;; Pull floating-point values apart into mantissa and exponent. |
| 2540 | (defun calcFunc-mant (x) | 2424 | (defun calcFunc-mant (x) |
| @@ -2544,8 +2428,7 @@ | |||
| 2544 | x | 2428 | x |
| 2545 | (list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x))))) | 2429 | (list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x))))) |
| 2546 | (calc-record-why 'realp x) | 2430 | (calc-record-why 'realp x) |
| 2547 | (list 'calcFunc-mant x)) | 2431 | (list 'calcFunc-mant x))) |
| 2548 | ) | ||
| 2549 | 2432 | ||
| 2550 | (defun calcFunc-xpon (x) | 2433 | (defun calcFunc-xpon (x) |
| 2551 | (if (Math-realp x) | 2434 | (if (Math-realp x) |
| @@ -2554,8 +2437,7 @@ | |||
| 2554 | 0 | 2437 | 0 |
| 2555 | (math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) | 2438 | (math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) |
| 2556 | (calc-record-why 'realp x) | 2439 | (calc-record-why 'realp x) |
| 2557 | (list 'calcFunc-xpon x)) | 2440 | (list 'calcFunc-xpon x))) |
| 2558 | ) | ||
| 2559 | 2441 | ||
| 2560 | (defun calcFunc-scf (x n) | 2442 | (defun calcFunc-scf (x n) |
| 2561 | (if (integerp n) | 2443 | (if (integerp n) |
| @@ -2601,8 +2483,7 @@ | |||
| 2601 | (if (math-integerp n) | 2483 | (if (math-integerp n) |
| 2602 | (math-overflow n) | 2484 | (math-overflow n) |
| 2603 | (calc-record-why 'integerp n) | 2485 | (calc-record-why 'integerp n) |
| 2604 | (list 'calcFunc-scf x n)))) | 2486 | (list 'calcFunc-scf x n))))) |
| 2605 | ) | ||
| 2606 | 2487 | ||
| 2607 | 2488 | ||
| 2608 | (defun calcFunc-incr (x &optional step relative-to) | 2489 | (defun calcFunc-incr (x &optional step relative-to) |
| @@ -2626,28 +2507,21 @@ | |||
| 2626 | (math-add x step) | 2507 | (math-add x step) |
| 2627 | (math-add x (list 'hms 0 0 step)))) | 2508 | (math-add x (list 'hms 0 0 step)))) |
| 2628 | (t | 2509 | (t |
| 2629 | (math-reject-arg x 'realp))) | 2510 | (math-reject-arg x 'realp)))) |
| 2630 | ) | ||
| 2631 | |||
| 2632 | (defun calcFunc-decr (x &optional step relative-to) | ||
| 2633 | (calcFunc-incr x (math-neg (or step 1)) relative-to) | ||
| 2634 | ) | ||
| 2635 | 2511 | ||
| 2512 | (defsubst calcFunc-decr (x &optional step relative-to) | ||
| 2513 | (calcFunc-incr x (math-neg (or step 1)) relative-to)) | ||
| 2636 | 2514 | ||
| 2637 | (defun calcFunc-percent (x) | 2515 | (defun calcFunc-percent (x) |
| 2638 | (if (math-objectp x) | 2516 | (if (math-objectp x) |
| 2639 | (let ((calc-prefer-frac nil)) | 2517 | (let ((calc-prefer-frac nil)) |
| 2640 | (math-div x 100)) | 2518 | (math-div x 100)) |
| 2641 | (list 'calcFunc-percent x)) | 2519 | (list 'calcFunc-percent x))) |
| 2642 | ) | ||
| 2643 | 2520 | ||
| 2644 | (defun calcFunc-relch (x y) | 2521 | (defun calcFunc-relch (x y) |
| 2645 | (if (and (math-objectp x) (math-objectp y)) | 2522 | (if (and (math-objectp x) (math-objectp y)) |
| 2646 | (math-div (math-sub y x) x) | 2523 | (math-div (math-sub y x) x) |
| 2647 | (list 'calcFunc-relch x y)) | 2524 | (list 'calcFunc-relch x y))) |
| 2648 | ) | ||
| 2649 | |||
| 2650 | |||
| 2651 | 2525 | ||
| 2652 | ;;; Compute the absolute value squared of A. [F N] [Public] | 2526 | ;;; Compute the absolute value squared of A. [F N] [Public] |
| 2653 | (defun calcFunc-abssqr (a) | 2527 | (defun calcFunc-abssqr (a) |
| @@ -2668,12 +2542,10 @@ | |||
| 2668 | (and inf | 2542 | (and inf |
| 2669 | (math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf)))) | 2543 | (math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf)))) |
| 2670 | (t (calc-record-why 'numvecp a) | 2544 | (t (calc-record-why 'numvecp a) |
| 2671 | (list 'calcFunc-abssqr a))) | 2545 | (list 'calcFunc-abssqr a)))) |
| 2672 | ) | ||
| 2673 | (defun math-sqr (a) | ||
| 2674 | (math-mul a a) | ||
| 2675 | ) | ||
| 2676 | 2546 | ||
| 2547 | (defsubst math-sqr (a) | ||
| 2548 | (math-mul a a)) | ||
| 2677 | 2549 | ||
| 2678 | ;;;; Number theory. | 2550 | ;;;; Number theory. |
| 2679 | 2551 | ||
| @@ -2696,8 +2568,7 @@ | |||
| 2696 | ((or (math-infinitep a) | 2568 | ((or (math-infinitep a) |
| 2697 | (math-infinitep b)) | 2569 | (math-infinitep b)) |
| 2698 | (math-div a b)) | 2570 | (math-div a b)) |
| 2699 | (t (math-reject-arg a 'anglep))) | 2571 | (t (math-reject-arg a 'anglep)))) |
| 2700 | ) | ||
| 2701 | 2572 | ||
| 2702 | 2573 | ||
| 2703 | ;;; Combine two terms being added, if possible. | 2574 | ;;; Combine two terms being added, if possible. |
| @@ -2740,16 +2611,14 @@ | |||
| 2740 | (if nega (setq amult (math-neg amult))) | 2611 | (if nega (setq amult (math-neg amult))) |
| 2741 | (if negb (setq bmult (math-neg bmult))) | 2612 | (if negb (setq bmult (math-neg bmult))) |
| 2742 | (setq amult (math-add amult bmult)) | 2613 | (setq amult (math-add amult bmult)) |
| 2743 | (math-mul amult a))))) | 2614 | (math-mul amult a)))))) |
| 2744 | ) | ||
| 2745 | 2615 | ||
| 2746 | (defun math-add-or-sub (a b aneg bneg) | 2616 | (defun math-add-or-sub (a b aneg bneg) |
| 2747 | (if aneg (setq a (math-neg a))) | 2617 | (if aneg (setq a (math-neg a))) |
| 2748 | (if bneg (setq b (math-neg b))) | 2618 | (if bneg (setq b (math-neg b))) |
| 2749 | (if (or (Math-vectorp a) (Math-vectorp b)) | 2619 | (if (or (Math-vectorp a) (Math-vectorp b)) |
| 2750 | (math-normalize (list '+ a b)) | 2620 | (math-normalize (list '+ a b)) |
| 2751 | (math-add a b)) | 2621 | (math-add a b))) |
| 2752 | ) | ||
| 2753 | 2622 | ||
| 2754 | ;;; The following is expanded out four ways for speed. | 2623 | ;;; The following is expanded out four ways for speed. |
| 2755 | (defun math-combine-prod (a b inva invb scalar-okay) | 2624 | (defun math-combine-prod (a b inva invb scalar-okay) |
| @@ -2864,8 +2733,7 @@ | |||
| 2864 | (setq a (math-mul a b)) | 2733 | (setq a (math-mul a b)) |
| 2865 | (condition-case err | 2734 | (condition-case err |
| 2866 | (math-pow a apow) | 2735 | (math-pow a apow) |
| 2867 | (inexact-result (list '^ a apow)))))))))) | 2736 | (inexact-result (list '^ a apow))))))))))) |
| 2868 | ) | ||
| 2869 | (setq math-combine-prod-e '(var e var-e)) | 2737 | (setq math-combine-prod-e '(var e var-e)) |
| 2870 | 2738 | ||
| 2871 | (defun math-mul-or-div (a b ainv binv) | 2739 | (defun math-mul-or-div (a b ainv binv) |
| @@ -2884,8 +2752,7 @@ | |||
| 2884 | (math-div b a)) | 2752 | (math-div b a)) |
| 2885 | (if binv | 2753 | (if binv |
| 2886 | (math-div a b) | 2754 | (math-div a b) |
| 2887 | (math-mul a b)))) | 2755 | (math-mul a b))))) |
| 2888 | ) | ||
| 2889 | 2756 | ||
| 2890 | (defun math-commutative-equal (a b) | 2757 | (defun math-commutative-equal (a b) |
| 2891 | (if (memq (car-safe a) '(+ -)) | 2758 | (if (memq (car-safe a) '(+ -)) |
| @@ -2906,8 +2773,7 @@ | |||
| 2906 | (setq bterms (delq (car p) bterms) | 2773 | (setq bterms (delq (car p) bterms) |
| 2907 | aterms (cdr aterms))) | 2774 | aterms (cdr aterms))) |
| 2908 | (not aterms))))) | 2775 | (not aterms))))) |
| 2909 | (equal a b)) | 2776 | (equal a b))) |
| 2910 | ) | ||
| 2911 | 2777 | ||
| 2912 | (defun math-commutative-collect (b neg) | 2778 | (defun math-commutative-collect (b neg) |
| 2913 | (if (eq (car-safe b) '+) | 2779 | (if (eq (car-safe b) '+) |
| @@ -2918,7 +2784,6 @@ | |||
| 2918 | (progn | 2784 | (progn |
| 2919 | (math-commutative-collect (nth 1 b) neg) | 2785 | (math-commutative-collect (nth 1 b) neg) |
| 2920 | (math-commutative-collect (nth 2 b) (not neg))) | 2786 | (math-commutative-collect (nth 2 b) (not neg))) |
| 2921 | (setq bterms (cons (if neg (math-neg b) b) bterms)))) | 2787 | (setq bterms (cons (if neg (math-neg b) b) bterms))))) |
| 2922 | ) | ||
| 2923 | |||
| 2924 | 2788 | ||
| 2789 | ;;; calc-arith.el ends here | ||