aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorColin Walters2001-11-14 09:01:07 +0000
committerColin Walters2001-11-14 09:01:07 +0000
commit898ea5c0b23ce37cc76a976c6bd5c27921308eeb (patch)
tree797495e9425450a3627bd03be3c353b1dab295d8
parentd389648023884fc3ca5022a51796331f7cf75fb6 (diff)
downloademacs-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.el447
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