1 |
;; Calculator for GNU Emacs, part II [calc-arith.el] |
;; Calculator for GNU Emacs, part II [calc-arith.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
34 |
(defun calc-min (arg) |
(defun calc-min (arg) |
35 |
(interactive "P") |
(interactive "P") |
36 |
(calc-slow-wrapper |
(calc-slow-wrapper |
37 |
(calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf))) |
(calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf)))) |
|
) |
|
38 |
|
|
39 |
(defun calc-max (arg) |
(defun calc-max (arg) |
40 |
(interactive "P") |
(interactive "P") |
41 |
(calc-slow-wrapper |
(calc-slow-wrapper |
42 |
(calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf)))) |
(calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf))))) |
|
) |
|
43 |
|
|
44 |
(defun calc-abs (arg) |
(defun calc-abs (arg) |
45 |
(interactive "P") |
(interactive "P") |
46 |
(calc-slow-wrapper |
(calc-slow-wrapper |
47 |
(calc-unary-op "abs" 'calcFunc-abs arg)) |
(calc-unary-op "abs" 'calcFunc-abs arg))) |
|
) |
|
48 |
|
|
49 |
|
|
50 |
(defun calc-idiv (arg) |
(defun calc-idiv (arg) |
51 |
(interactive "P") |
(interactive "P") |
52 |
(calc-slow-wrapper |
(calc-slow-wrapper |
53 |
(calc-binary-op "\\" 'calcFunc-idiv arg 1)) |
(calc-binary-op "\\" 'calcFunc-idiv arg 1))) |
|
) |
|
54 |
|
|
55 |
|
|
56 |
(defun calc-floor (arg) |
(defun calc-floor (arg) |
62 |
(calc-unary-op "ceil" 'calcFunc-ceil arg)) |
(calc-unary-op "ceil" 'calcFunc-ceil arg)) |
63 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
64 |
(calc-unary-op "flor" 'calcFunc-ffloor arg) |
(calc-unary-op "flor" 'calcFunc-ffloor arg) |
65 |
(calc-unary-op "flor" 'calcFunc-floor arg)))) |
(calc-unary-op "flor" 'calcFunc-floor arg))))) |
|
) |
|
66 |
|
|
67 |
(defun calc-ceiling (arg) |
(defun calc-ceiling (arg) |
68 |
(interactive "P") |
(interactive "P") |
69 |
(calc-invert-func) |
(calc-invert-func) |
70 |
(calc-floor arg) |
(calc-floor arg)) |
|
) |
|
71 |
|
|
72 |
(defun calc-round (arg) |
(defun calc-round (arg) |
73 |
(interactive "P") |
(interactive "P") |
78 |
(calc-unary-op "trnc" 'calcFunc-trunc arg)) |
(calc-unary-op "trnc" 'calcFunc-trunc arg)) |
79 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
80 |
(calc-unary-op "rond" 'calcFunc-fround arg) |
(calc-unary-op "rond" 'calcFunc-fround arg) |
81 |
(calc-unary-op "rond" 'calcFunc-round arg)))) |
(calc-unary-op "rond" 'calcFunc-round arg))))) |
|
) |
|
82 |
|
|
83 |
(defun calc-trunc (arg) |
(defun calc-trunc (arg) |
84 |
(interactive "P") |
(interactive "P") |
85 |
(calc-invert-func) |
(calc-invert-func) |
86 |
(calc-round arg) |
(calc-round arg)) |
|
) |
|
87 |
|
|
88 |
(defun calc-mant-part (arg) |
(defun calc-mant-part (arg) |
89 |
(interactive "P") |
(interactive "P") |
90 |
(calc-slow-wrapper |
(calc-slow-wrapper |
91 |
(calc-unary-op "mant" 'calcFunc-mant arg)) |
(calc-unary-op "mant" 'calcFunc-mant arg))) |
|
) |
|
92 |
|
|
93 |
(defun calc-xpon-part (arg) |
(defun calc-xpon-part (arg) |
94 |
(interactive "P") |
(interactive "P") |
95 |
(calc-slow-wrapper |
(calc-slow-wrapper |
96 |
(calc-unary-op "xpon" 'calcFunc-xpon arg)) |
(calc-unary-op "xpon" 'calcFunc-xpon arg))) |
|
) |
|
97 |
|
|
98 |
(defun calc-scale-float (arg) |
(defun calc-scale-float (arg) |
99 |
(interactive "P") |
(interactive "P") |
100 |
(calc-slow-wrapper |
(calc-slow-wrapper |
101 |
(calc-binary-op "scal" 'calcFunc-scf arg)) |
(calc-binary-op "scal" 'calcFunc-scf arg))) |
|
) |
|
102 |
|
|
103 |
(defun calc-abssqr (arg) |
(defun calc-abssqr (arg) |
104 |
(interactive "P") |
(interactive "P") |
105 |
(calc-slow-wrapper |
(calc-slow-wrapper |
106 |
(calc-unary-op "absq" 'calcFunc-abssqr arg)) |
(calc-unary-op "absq" 'calcFunc-abssqr arg))) |
|
) |
|
107 |
|
|
108 |
(defun calc-sign (arg) |
(defun calc-sign (arg) |
109 |
(interactive "P") |
(interactive "P") |
110 |
(calc-slow-wrapper |
(calc-slow-wrapper |
111 |
(calc-unary-op "sign" 'calcFunc-sign arg)) |
(calc-unary-op "sign" 'calcFunc-sign arg))) |
|
) |
|
112 |
|
|
113 |
(defun calc-increment (arg) |
(defun calc-increment (arg) |
114 |
(interactive "p") |
(interactive "p") |
115 |
(calc-wrapper |
(calc-wrapper |
116 |
(calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg))) |
(calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg)))) |
|
) |
|
117 |
|
|
118 |
(defun calc-decrement (arg) |
(defun calc-decrement (arg) |
119 |
(interactive "p") |
(interactive "p") |
120 |
(calc-wrapper |
(calc-wrapper |
121 |
(calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg))) |
(calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg)))) |
|
) |
|
122 |
|
|
123 |
|
|
124 |
(defun math-abs-approx (a) |
(defun math-abs-approx (a) |
140 |
(math-reduce-vec 'math-add-abs-approx a)) |
(math-reduce-vec 'math-add-abs-approx a)) |
141 |
((eq (car a) 'calcFunc-abs) |
((eq (car a) 'calcFunc-abs) |
142 |
(car a)) |
(car a)) |
143 |
(t a)) |
(t a))) |
|
) |
|
144 |
|
|
145 |
(defun math-add-abs-approx (a b) |
(defun math-add-abs-approx (a b) |
146 |
(math-add (math-abs-approx a) (math-abs-approx b)) |
(math-add (math-abs-approx a) (math-abs-approx b))) |
|
) |
|
147 |
|
|
148 |
|
|
149 |
;;;; Declarations. |
;;;; Declarations. |
206 |
type) |
type) |
207 |
math-decls-cache))))) |
math-decls-cache))))) |
208 |
(error nil))))) |
(error nil))))) |
209 |
(setq math-decls-all (assq 'var-All math-decls-cache)))) |
(setq math-decls-all (assq 'var-All math-decls-cache))))) |
|
) |
|
210 |
|
|
211 |
(defvar math-super-types |
(defvar math-super-types |
212 |
'( ( int numint rat real number ) |
'((int numint rat real number) |
213 |
( numint real number ) |
(numint real number) |
214 |
( frac rat real number ) |
(frac rat real number) |
215 |
( rat real number ) |
(rat real number) |
216 |
( float real number ) |
(float real number) |
217 |
( real number ) |
(real number) |
218 |
( number ) |
(number) |
219 |
( scalar ) |
(scalar) |
220 |
( matrix vector ) |
(matrix vector) |
221 |
( vector ) |
(vector) |
222 |
( const ) |
(const))) |
|
)) |
|
|
|
|
223 |
|
|
224 |
(defun math-known-scalarp (a &optional assume-scalar) |
(defun math-known-scalarp (a &optional assume-scalar) |
225 |
(math-setup-declarations) |
(math-setup-declarations) |
227 |
(eq calc-matrix-mode 'scalar) |
(eq calc-matrix-mode 'scalar) |
228 |
assume-scalar) |
assume-scalar) |
229 |
(not (math-check-known-matrixp a)) |
(not (math-check-known-matrixp a)) |
230 |
(math-check-known-scalarp a)) |
(math-check-known-scalarp a))) |
|
) |
|
231 |
|
|
232 |
(defun math-known-matrixp (a) |
(defun math-known-matrixp (a) |
233 |
(and (not (Math-scalarp a)) |
(and (not (Math-scalarp a)) |
234 |
(not (math-known-scalarp a t))) |
(not (math-known-scalarp a t)))) |
|
) |
|
235 |
|
|
236 |
;;; Try to prove that A is a scalar (i.e., a non-vector). |
;;; Try to prove that A is a scalar (i.e., a non-vector). |
237 |
(defun math-check-known-scalarp (a) |
(defun math-check-known-scalarp (a) |
252 |
(or (assq (nth 2 a) math-decls-cache) |
(or (assq (nth 2 a) math-decls-cache) |
253 |
math-decls-all) |
math-decls-all) |
254 |
(assq (car a) math-decls-cache)))) |
(assq (car a) math-decls-cache)))) |
255 |
(memq 'scalar (nth 1 decl))))) |
(memq 'scalar (nth 1 decl)))))) |
|
) |
|
256 |
|
|
257 |
;;; Try to prove that A is *not* a scalar. |
;;; Try to prove that A is *not* a scalar. |
258 |
(defun math-check-known-matrixp (a) |
(defun math-check-known-matrixp (a) |
271 |
(or (assq (nth 2 a) math-decls-cache) |
(or (assq (nth 2 a) math-decls-cache) |
272 |
math-decls-all) |
math-decls-all) |
273 |
(assq (car a) math-decls-cache)))) |
(assq (car a) math-decls-cache)))) |
274 |
(memq 'vector (nth 1 decl))))) |
(memq 'vector (nth 1 decl)))))) |
|
) |
|
275 |
|
|
276 |
|
|
277 |
;;; Try to prove that A is a real (i.e., not complex). |
;;; Try to prove that A is a real (i.e., not complex). |
278 |
(defun math-known-realp (a) |
(defun math-known-realp (a) |
279 |
(< (math-possible-signs a) 8) |
(< (math-possible-signs a) 8)) |
|
) |
|
280 |
|
|
281 |
;;; Try to prove that A is real and positive. |
;;; Try to prove that A is real and positive. |
282 |
(defun math-known-posp (a) |
(defun math-known-posp (a) |
283 |
(eq (math-possible-signs a) 4) |
(eq (math-possible-signs a) 4)) |
|
) |
|
284 |
|
|
285 |
;;; Try to prove that A is real and negative. |
;;; Try to prove that A is real and negative. |
286 |
(defun math-known-negp (a) |
(defun math-known-negp (a) |
287 |
(eq (math-possible-signs a) 1) |
(eq (math-possible-signs a) 1)) |
|
) |
|
288 |
|
|
289 |
;;; Try to prove that A is real and nonnegative. |
;;; Try to prove that A is real and nonnegative. |
290 |
(defun math-known-nonnegp (a) |
(defun math-known-nonnegp (a) |
291 |
(memq (math-possible-signs a) '(2 4 6)) |
(memq (math-possible-signs a) '(2 4 6))) |
|
) |
|
292 |
|
|
293 |
;;; Try to prove that A is real and nonpositive. |
;;; Try to prove that A is real and nonpositive. |
294 |
(defun math-known-nonposp (a) |
(defun math-known-nonposp (a) |
295 |
(memq (math-possible-signs a) '(1 2 3)) |
(memq (math-possible-signs a) '(1 2 3))) |
|
) |
|
296 |
|
|
297 |
;;; Try to prove that A is nonzero. |
;;; Try to prove that A is nonzero. |
298 |
(defun math-known-nonzerop (a) |
(defun math-known-nonzerop (a) |
299 |
(memq (math-possible-signs a) '(1 4 5 8 9 12 13)) |
(memq (math-possible-signs a) '(1 4 5 8 9 12 13))) |
|
) |
|
300 |
|
|
301 |
;;; Return true if A is negative, or looks negative but we don't know. |
;;; Return true if A is negative, or looks negative but we don't know. |
302 |
(defun math-guess-if-neg (a) |
(defun math-guess-if-neg (a) |
305 |
t |
t |
306 |
(if (memq sgn '(2 4 6)) |
(if (memq sgn '(2 4 6)) |
307 |
nil |
nil |
308 |
(math-looks-negp a)))) |
(math-looks-negp a))))) |
|
) |
|
309 |
|
|
310 |
;;; Find the possible signs of A, assuming A is a number of some kind. |
;;; Find the possible signs of A, assuming A is a number of some kind. |
311 |
;;; Returns an integer with bits: 1 may be negative, |
;;; Returns an integer with bits: 1 may be negative, |
493 |
(math-possible-signs (nth 2 decl) origin) |
(math-possible-signs (nth 2 decl) origin) |
494 |
(if (memq 'real (nth 1 decl)) |
(if (memq 'real (nth 1 decl)) |
495 |
7 |
7 |
496 |
15))))))))) |
15)))))))))) |
|
) |
|
497 |
|
|
498 |
(defun math-neg-signs (s1) |
(defun math-neg-signs (s1) |
499 |
(if (>= s1 8) |
(if (>= s1 8) |
500 |
(+ 8 (math-neg-signs (- s1 8))) |
(+ 8 (math-neg-signs (- s1 8))) |
501 |
(+ (if (memq s1 '(1 3 5 7)) 4 0) |
(+ (if (memq s1 '(1 3 5 7)) 4 0) |
502 |
(if (memq s1 '(2 3 6 7)) 2 0) |
(if (memq s1 '(2 3 6 7)) 2 0) |
503 |
(if (memq s1 '(4 5 6 7)) 1 0))) |
(if (memq s1 '(4 5 6 7)) 1 0)))) |
|
) |
|
504 |
|
|
505 |
|
|
506 |
;;; Try to prove that A is an integer. |
;;; Try to prove that A is an integer. |
507 |
(defun math-known-integerp (a) |
(defun math-known-integerp (a) |
508 |
(eq (math-possible-types a) 1) |
(eq (math-possible-types a) 1)) |
|
) |
|
509 |
|
|
510 |
(defun math-known-num-integerp (a) |
(defun math-known-num-integerp (a) |
511 |
(<= (math-possible-types a t) 3) |
(<= (math-possible-types a t) 3)) |
|
) |
|
512 |
|
|
513 |
(defun math-known-imagp (a) |
(defun math-known-imagp (a) |
514 |
(= (math-possible-types a) 16) |
(= (math-possible-types a) 16)) |
|
) |
|
515 |
|
|
516 |
|
|
517 |
;;; Find the possible types of A. |
;;; Find the possible types of A. |
669 |
(math-possible-types (nth 2 decl))) |
(math-possible-types (nth 2 decl))) |
670 |
((memq 'real (nth 1 decl)) |
((memq 'real (nth 1 decl)) |
671 |
15) |
15) |
672 |
(t 63))))) |
(t 63)))))) |
|
) |
|
673 |
|
|
674 |
(defun math-known-evenp (a) |
(defun math-known-evenp (a) |
675 |
(cond ((Math-integerp a) |
(cond ((Math-integerp a) |
688 |
(and (math-known-oddp (nth 1 a)) |
(and (math-known-oddp (nth 1 a)) |
689 |
(math-known-oddp (nth 2 a))))) |
(math-known-oddp (nth 2 a))))) |
690 |
((eq (car a) 'neg) |
((eq (car a) 'neg) |
691 |
(math-known-evenp (nth 1 a)))) |
(math-known-evenp (nth 1 a))))) |
|
) |
|
692 |
|
|
693 |
(defun math-known-oddp (a) |
(defun math-known-oddp (a) |
694 |
(cond ((Math-integerp a) |
(cond ((Math-integerp a) |
702 |
(and (math-known-oddp (nth 1 a)) |
(and (math-known-oddp (nth 1 a)) |
703 |
(math-known-evenp (nth 2 a))))) |
(math-known-evenp (nth 2 a))))) |
704 |
((eq (car a) 'neg) |
((eq (car a) 'neg) |
705 |
(math-known-oddp (nth 1 a)))) |
(math-known-oddp (nth 1 a))))) |
|
) |
|
706 |
|
|
707 |
|
|
708 |
(defun calcFunc-dreal (expr) |
(defun calcFunc-dreal (expr) |
709 |
(let ((types (math-possible-types expr))) |
(let ((types (math-possible-types expr))) |
710 |
(if (< types 16) 1 |
(if (< types 16) 1 |
711 |
(if (= (logand types 15) 0) 0 |
(if (= (logand types 15) 0) 0 |
712 |
(math-reject-arg expr 'realp 'quiet)))) |
(math-reject-arg expr 'realp 'quiet))))) |
|
) |
|
713 |
|
|
714 |
(defun calcFunc-dimag (expr) |
(defun calcFunc-dimag (expr) |
715 |
(let ((types (math-possible-types expr))) |
(let ((types (math-possible-types expr))) |
716 |
(if (= types 16) 1 |
(if (= types 16) 1 |
717 |
(if (= (logand types 16) 0) 0 |
(if (= (logand types 16) 0) 0 |
718 |
(math-reject-arg expr "Expected an imaginary number")))) |
(math-reject-arg expr "Expected an imaginary number"))))) |
|
) |
|
719 |
|
|
720 |
(defun calcFunc-dpos (expr) |
(defun calcFunc-dpos (expr) |
721 |
(let ((signs (math-possible-signs expr))) |
(let ((signs (math-possible-signs expr))) |
722 |
(if (eq signs 4) 1 |
(if (eq signs 4) 1 |
723 |
(if (memq signs '(1 2 3)) 0 |
(if (memq signs '(1 2 3)) 0 |
724 |
(math-reject-arg expr 'posp 'quiet)))) |
(math-reject-arg expr 'posp 'quiet))))) |
|
) |
|
725 |
|
|
726 |
(defun calcFunc-dneg (expr) |
(defun calcFunc-dneg (expr) |
727 |
(let ((signs (math-possible-signs expr))) |
(let ((signs (math-possible-signs expr))) |
728 |
(if (eq signs 1) 1 |
(if (eq signs 1) 1 |
729 |
(if (memq signs '(2 4 6)) 0 |
(if (memq signs '(2 4 6)) 0 |
730 |
(math-reject-arg expr 'negp 'quiet)))) |
(math-reject-arg expr 'negp 'quiet))))) |
|
) |
|
731 |
|
|
732 |
(defun calcFunc-dnonneg (expr) |
(defun calcFunc-dnonneg (expr) |
733 |
(let ((signs (math-possible-signs expr))) |
(let ((signs (math-possible-signs expr))) |
734 |
(if (memq signs '(2 4 6)) 1 |
(if (memq signs '(2 4 6)) 1 |
735 |
(if (eq signs 1) 0 |
(if (eq signs 1) 0 |
736 |
(math-reject-arg expr 'posp 'quiet)))) |
(math-reject-arg expr 'posp 'quiet))))) |
|
) |
|
737 |
|
|
738 |
(defun calcFunc-dnonzero (expr) |
(defun calcFunc-dnonzero (expr) |
739 |
(let ((signs (math-possible-signs expr))) |
(let ((signs (math-possible-signs expr))) |
740 |
(if (memq signs '(1 4 5 8 9 12 13)) 1 |
(if (memq signs '(1 4 5 8 9 12 13)) 1 |
741 |
(if (eq signs 2) 0 |
(if (eq signs 2) 0 |
742 |
(math-reject-arg expr 'nonzerop 'quiet)))) |
(math-reject-arg expr 'nonzerop 'quiet))))) |
|
) |
|
743 |
|
|
744 |
(defun calcFunc-dint (expr) |
(defun calcFunc-dint (expr) |
745 |
(let ((types (math-possible-types expr))) |
(let ((types (math-possible-types expr))) |
746 |
(if (= types 1) 1 |
(if (= types 1) 1 |
747 |
(if (= (logand types 1) 0) 0 |
(if (= (logand types 1) 0) 0 |
748 |
(math-reject-arg expr 'integerp 'quiet)))) |
(math-reject-arg expr 'integerp 'quiet))))) |
|
) |
|
749 |
|
|
750 |
(defun calcFunc-dnumint (expr) |
(defun calcFunc-dnumint (expr) |
751 |
(let ((types (math-possible-types expr t))) |
(let ((types (math-possible-types expr t))) |
752 |
(if (<= types 3) 1 |
(if (<= types 3) 1 |
753 |
(if (= (logand types 3) 0) 0 |
(if (= (logand types 3) 0) 0 |
754 |
(math-reject-arg expr 'integerp 'quiet)))) |
(math-reject-arg expr 'integerp 'quiet))))) |
|
) |
|
755 |
|
|
756 |
(defun calcFunc-dnatnum (expr) |
(defun calcFunc-dnatnum (expr) |
757 |
(let ((res (calcFunc-dint expr))) |
(let ((res (calcFunc-dint expr))) |
758 |
(if (eq res 1) |
(if (eq res 1) |
759 |
(calcFunc-dnonneg expr) |
(calcFunc-dnonneg expr) |
760 |
res)) |
res))) |
|
) |
|
761 |
|
|
762 |
(defun calcFunc-deven (expr) |
(defun calcFunc-deven (expr) |
763 |
(if (math-known-evenp expr) |
(if (math-known-evenp expr) |
765 |
(if (or (math-known-oddp expr) |
(if (or (math-known-oddp expr) |
766 |
(= (logand (math-possible-types expr) 3) 0)) |
(= (logand (math-possible-types expr) 3) 0)) |
767 |
0 |
0 |
768 |
(math-reject-arg expr "Can't tell if expression is odd or even"))) |
(math-reject-arg expr "Can't tell if expression is odd or even")))) |
|
) |
|
769 |
|
|
770 |
(defun calcFunc-dodd (expr) |
(defun calcFunc-dodd (expr) |
771 |
(if (math-known-oddp expr) |
(if (math-known-oddp expr) |
773 |
(if (or (math-known-evenp expr) |
(if (or (math-known-evenp expr) |
774 |
(= (logand (math-possible-types expr) 3) 0)) |
(= (logand (math-possible-types expr) 3) 0)) |
775 |
0 |
0 |
776 |
(math-reject-arg expr "Can't tell if expression is odd or even"))) |
(math-reject-arg expr "Can't tell if expression is odd or even")))) |
|
) |
|
777 |
|
|
778 |
(defun calcFunc-drat (expr) |
(defun calcFunc-drat (expr) |
779 |
(let ((types (math-possible-types expr))) |
(let ((types (math-possible-types expr))) |
780 |
(if (memq types '(1 4 5)) 1 |
(if (memq types '(1 4 5)) 1 |
781 |
(if (= (logand types 5) 0) 0 |
(if (= (logand types 5) 0) 0 |
782 |
(math-reject-arg expr "Rational number expected")))) |
(math-reject-arg expr "Rational number expected"))))) |
|
) |
|
783 |
|
|
784 |
(defun calcFunc-drange (expr) |
(defun calcFunc-drange (expr) |
785 |
(math-setup-declarations) |
(math-setup-declarations) |
805 |
(intv 1 0 (var inf var-inf))) |
(intv 1 0 (var inf var-inf))) |
806 |
(intv 3 0 (var inf var-inf)) |
(intv 3 0 (var inf var-inf)) |
807 |
(intv 3 (neg (var inf var-inf)) (var inf var-inf))] range) |
(intv 3 (neg (var inf var-inf)) (var inf var-inf))] range) |
808 |
(math-reject-arg expr 'realp 'quiet)))))) |
(math-reject-arg expr 'realp 'quiet))))))) |
|
) |
|
809 |
|
|
810 |
(defun calcFunc-dscalar (a) |
(defun calcFunc-dscalar (a) |
811 |
(if (math-known-scalarp a) 1 |
(if (math-known-scalarp a) 1 |
812 |
(if (math-known-matrixp a) 0 |
(if (math-known-matrixp a) 0 |
813 |
(math-reject-arg a 'objectp 'quiet))) |
(math-reject-arg a 'objectp 'quiet)))) |
|
) |
|
814 |
|
|
815 |
|
|
816 |
;;; The following lists are not exhaustive. |
;;; The following lists are not exhaustive. |
818 |
calcFunc-cnorm calcFunc-rnorm |
calcFunc-cnorm calcFunc-rnorm |
819 |
calcFunc-vlen calcFunc-vcount |
calcFunc-vlen calcFunc-vcount |
820 |
calcFunc-vsum calcFunc-vprod |
calcFunc-vsum calcFunc-vprod |
821 |
calcFunc-vmin calcFunc-vmax |
calcFunc-vmin calcFunc-vmax)) |
|
)) |
|
822 |
|
|
823 |
(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag |
(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag |
824 |
calcFunc-cvec calcFunc-index |
calcFunc-cvec calcFunc-index |
825 |
calcFunc-trn |
calcFunc-trn |
826 |
| calcFunc-append |
| calcFunc-append |
827 |
calcFunc-cons calcFunc-rcons |
calcFunc-cons calcFunc-rcons |
828 |
calcFunc-tail calcFunc-rhead |
calcFunc-tail calcFunc-rhead)) |
|
)) |
|
829 |
|
|
830 |
(defvar math-scalar-if-args-functions '(+ - * / neg)) |
(defvar math-scalar-if-args-functions '(+ - * / neg)) |
831 |
|
|
836 |
calcFunc-rounde calcFunc-roundu |
calcFunc-rounde calcFunc-roundu |
837 |
calcFunc-ffloor calcFunc-fceil |
calcFunc-ffloor calcFunc-fceil |
838 |
calcFunc-ftrunc calcFunc-fround |
calcFunc-ftrunc calcFunc-fround |
839 |
calcFunc-frounde calcFunc-froundu |
calcFunc-frounde calcFunc-froundu)) |
|
)) |
|
840 |
|
|
841 |
(defvar math-positive-functions '( |
(defvar math-positive-functions '()) |
|
)) |
|
842 |
|
|
843 |
(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm |
(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm |
844 |
calcFunc-vlen calcFunc-vcount |
calcFunc-vlen calcFunc-vcount)) |
|
)) |
|
845 |
|
|
846 |
(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs |
(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs |
847 |
calcFunc-choose calcFunc-perm |
calcFunc-choose calcFunc-perm |
849 |
calcFunc-lt calcFunc-gt |
calcFunc-lt calcFunc-gt |
850 |
calcFunc-leq calcFunc-geq |
calcFunc-leq calcFunc-geq |
851 |
calcFunc-lnot |
calcFunc-lnot |
852 |
calcFunc-max calcFunc-min |
calcFunc-max calcFunc-min)) |
|
)) |
|
853 |
|
|
854 |
(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos |
(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos |
855 |
calcFunc-tan calcFunc-arctan |
calcFunc-tan calcFunc-arctan |
856 |
calcFunc-sinh calcFunc-cosh |
calcFunc-sinh calcFunc-cosh |
857 |
calcFunc-tanh calcFunc-exp |
calcFunc-tanh calcFunc-exp |
858 |
calcFunc-gamma calcFunc-fact |
calcFunc-gamma calcFunc-fact)) |
|
)) |
|
859 |
|
|
860 |
(defvar math-integer-functions '(calcFunc-idiv |
(defvar math-integer-functions '(calcFunc-idiv |
861 |
calcFunc-isqrt calcFunc-ilog |
calcFunc-isqrt calcFunc-ilog |
862 |
calcFunc-vlen calcFunc-vcount |
calcFunc-vlen calcFunc-vcount)) |
|
)) |
|
863 |
|
|
864 |
(defvar math-num-integer-functions '( |
(defvar math-num-integer-functions '()) |
|
)) |
|
865 |
|
|
866 |
(defvar math-rounding-functions '(calcFunc-floor |
(defvar math-rounding-functions '(calcFunc-floor |
867 |
calcFunc-ceil |
calcFunc-ceil |
868 |
calcFunc-round calcFunc-trunc |
calcFunc-round calcFunc-trunc |
869 |
calcFunc-rounde calcFunc-roundu |
calcFunc-rounde calcFunc-roundu)) |
|
)) |
|
870 |
|
|
871 |
(defvar math-float-rounding-functions '(calcFunc-ffloor |
(defvar math-float-rounding-functions '(calcFunc-ffloor |
872 |
calcFunc-fceil |
calcFunc-fceil |
873 |
calcFunc-fround calcFunc-ftrunc |
calcFunc-fround calcFunc-ftrunc |
874 |
calcFunc-frounde calcFunc-froundu |
calcFunc-frounde calcFunc-froundu)) |
|
)) |
|
875 |
|
|
876 |
(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs |
(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs |
877 |
calcFunc-min calcFunc-max |
calcFunc-min calcFunc-max |
878 |
calcFunc-choose calcFunc-perm |
calcFunc-choose calcFunc-perm)) |
|
)) |
|
879 |
|
|
880 |
|
|
881 |
;;;; Arithmetic. |
;;;; Arithmetic. |
882 |
|
|
883 |
(defun calcFunc-neg (a) |
(defun calcFunc-neg (a) |
884 |
(math-normalize (list 'neg a)) |
(math-normalize (list 'neg a))) |
|
) |
|
885 |
|
|
886 |
(defun math-neg-fancy (a) |
(defun math-neg-fancy (a) |
887 |
(cond ((eq (car a) 'polar) |
(cond ((eq (car a) 'polar) |
927 |
a) |
a) |
928 |
((eq (car a) 'neg) |
((eq (car a) 'neg) |
929 |
(nth 1 a)) |
(nth 1 a)) |
930 |
(t (list 'neg a))) |
(t (list 'neg a)))) |
|
) |
|
931 |
|
|
932 |
(defun math-okay-neg (a) |
(defun math-okay-neg (a) |
933 |
(or (math-looks-negp a) |
(or (math-looks-negp a) |
934 |
(eq (car-safe a) '-)) |
(eq (car-safe a) '-))) |
|
) |
|
935 |
|
|
936 |
(defun math-neg-float (a) |
(defun math-neg-float (a) |
937 |
(list 'float (Math-integer-neg (nth 1 a)) (nth 2 a)) |
(list 'float (Math-integer-neg (nth 1 a)) (nth 2 a))) |
|
) |
|
938 |
|
|
939 |
|
|
940 |
(defun calcFunc-add (&rest rest) |
(defun calcFunc-add (&rest rest) |
943 |
(while (setq rest (cdr rest)) |
(while (setq rest (cdr rest)) |
944 |
(setq a (list '+ a (car rest)))) |
(setq a (list '+ a (car rest)))) |
945 |
(math-normalize a)) |
(math-normalize a)) |
946 |
0) |
0)) |
|
) |
|
947 |
|
|
948 |
(defun calcFunc-sub (&rest rest) |
(defun calcFunc-sub (&rest rest) |
949 |
(if rest |
(if rest |
951 |
(while (setq rest (cdr rest)) |
(while (setq rest (cdr rest)) |
952 |
(setq a (list '- a (car rest)))) |
(setq a (list '- a (car rest)))) |
953 |
(math-normalize a)) |
(math-normalize a)) |
954 |
0) |
0)) |
|
) |
|
955 |
|
|
956 |
(defun math-add-objects-fancy (a b) |
(defun math-add-objects-fancy (a b) |
957 |
(cond ((and (Math-numberp a) (Math-numberp b)) |
(cond ((and (Math-numberp a) (Math-numberp b)) |
1059 |
(m (math-add (nth 2 a) (nth 2 b))) |
(m (math-add (nth 2 a) (nth 2 b))) |
1060 |
(h (math-add (nth 1 a) (nth 1 b)))) |
(h (math-add (nth 1 a) (nth 1 b)))) |
1061 |
(list 'hms h m s)))))) |
(list 'hms h m s)))))) |
1062 |
(t (calc-record-why "*Incompatible arguments for +" a b))) |
(t (calc-record-why "*Incompatible arguments for +" a b)))) |
|
) |
|
1063 |
|
|
1064 |
(defun math-add-symb-fancy (a b) |
(defun math-add-symb-fancy (a b) |
1065 |
(or (and math-simplify-only |
(or (and math-simplify-only |
1138 |
(math-add a (math-mimic-ident (nth 1 b) a))) |
(math-add a (math-mimic-ident (nth 1 b) a))) |
1139 |
(and (math-known-scalarp a) |
(and (math-known-scalarp a) |
1140 |
(math-add a (nth 1 b))))) |
(math-add a (nth 1 b))))) |
1141 |
(list '+ a b)) |
(list '+ a b))) |
|
) |
|
1142 |
|
|
1143 |
|
|
1144 |
(defun calcFunc-mul (&rest rest) |
(defun calcFunc-mul (&rest rest) |
1147 |
(while (setq rest (cdr rest)) |
(while (setq rest (cdr rest)) |
1148 |
(setq a (list '* a (car rest)))) |
(setq a (list '* a (car rest)))) |
1149 |
(math-normalize a)) |
(math-normalize a)) |
1150 |
1) |
1)) |
|
) |
|
1151 |
|
|
1152 |
(defun math-mul-objects-fancy (a b) |
(defun math-mul-objects-fancy (a b) |
1153 |
(cond ((and (Math-numberp a) (Math-numberp b)) |
(cond ((and (Math-numberp a) (Math-numberp b)) |
1246 |
(math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg))) |
(math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg))) |
1247 |
((and (eq (car-safe b) 'hms) (Math-realp a)) |
((and (eq (car-safe b) 'hms) (Math-realp a)) |
1248 |
(math-mul b a)) |
(math-mul b a)) |
1249 |
(t (calc-record-why "*Incompatible arguments for *" a b))) |
(t (calc-record-why "*Incompatible arguments for *" a b)))) |
|
) |
|
1250 |
|
|
1251 |
;;; Fast function to multiply floating-point numbers. |
;;; Fast function to multiply floating-point numbers. |
1252 |
(defun math-mul-float (a b) ; [F F F] |
(defun math-mul-float (a b) ; [F F F] |
1253 |
(math-make-float (math-mul (nth 1 a) (nth 1 b)) |
(math-make-float (math-mul (nth 1 a) (nth 1 b)) |
1254 |
(+ (nth 2 a) (nth 2 b))) |
(+ (nth 2 a) (nth 2 b)))) |
|
) |
|
1255 |
|
|
1256 |
(defun math-sqr-float (a) ; [F F] |
(defun math-sqr-float (a) ; [F F] |
1257 |
(math-make-float (math-mul (nth 1 a) (nth 1 a)) |
(math-make-float (math-mul (nth 1 a) (nth 1 a)) |
1258 |
(+ (nth 2 a) (nth 2 a))) |
(+ (nth 2 a) (nth 2 a)))) |
|
) |
|
1259 |
|
|
1260 |
(defun math-intv-constp (a &optional finite) |
(defun math-intv-constp (a &optional finite) |
1261 |
(and (or (Math-anglep (nth 2 a)) |
(and (or (Math-anglep (nth 2 a)) |
1265 |
(or (Math-anglep (nth 3 a)) |
(or (Math-anglep (nth 3 a)) |
1266 |
(and (equal (nth 3 a) '(var inf var-inf)) |
(and (equal (nth 3 a) '(var inf var-inf)) |
1267 |
(or (not finite) |
(or (not finite) |
1268 |
(memq (nth 1 a) '(0 2)))))) |
(memq (nth 1 a) '(0 2))))))) |
|
) |
|
1269 |
|
|
1270 |
(defun math-mul-zero (a b) |
(defun math-mul-zero (a b) |
1271 |
(if (math-known-matrixp b) |
(if (math-known-matrixp b) |
1293 |
(if (math-negp a) |
(if (math-negp a) |
1294 |
(math-neg (list 'intv 3 (or aa 0) (or bb 0))) |
(math-neg (list 'intv 3 (or aa 0) (or bb 0))) |
1295 |
'(var nan var-nan))) |
'(var nan var-nan))) |
1296 |
(if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0))))) |
(if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)))))) |
|
) |
|
1297 |
|
|
1298 |
|
|
1299 |
(defun math-mul-symb-fancy (a b) |
(defun math-mul-symb-fancy (a b) |
1405 |
(list '* (list 'polar 1 (nth 2 a)) b))))) |
(list '* (list 'polar 1 (nth 2 a)) b))))) |
1406 |
(and (equal a '(var inf var-inf)) |
(and (equal a '(var inf var-inf)) |
1407 |
(math-mul b a)) |
(math-mul b a)) |
1408 |
(list '* a b)) |
(list '* a b))) |
|
) |
|
1409 |
|
|
1410 |
|
|
1411 |
(defun calcFunc-div (a &rest rest) |
(defun calcFunc-div (a &rest rest) |
1412 |
(while rest |
(while rest |
1413 |
(setq a (list '/ a (car rest)) |
(setq a (list '/ a (car rest)) |
1414 |
rest (cdr rest))) |
rest (cdr rest))) |
1415 |
(math-normalize a) |
(math-normalize a)) |
|
) |
|
1416 |
|
|
1417 |
(defun math-div-objects-fancy (a b) |
(defun math-div-objects-fancy (a b) |
1418 |
(cond ((and (Math-numberp a) (Math-numberp b)) |
(cond ((and (Math-numberp a) (Math-numberp b)) |
1559 |
(math-from-hms b 'deg))) |
(math-from-hms b 'deg))) |
1560 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1561 |
(math-to-hms (math-div (math-from-hms a 'deg) b) 'deg)))) |
(math-to-hms (math-div (math-from-hms a 'deg) b) 'deg)))) |
1562 |
(t (calc-record-why "*Incompatible arguments for /" a b))) |
(t (calc-record-why "*Incompatible arguments for /" a b)))) |
|
) |
|
1563 |
|
|
1564 |
(defun math-div-by-zero (a b) |
(defun math-div-by-zero (a b) |
1565 |
(if (math-infinitep a) |
(if (math-infinitep a) |
1578 |
(if (eq (car-safe a) 'intv) |
(if (eq (car-safe a) 'intv) |
1579 |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
1580 |
'(var uinf var-uinf))))) |
'(var uinf var-uinf))))) |
1581 |
(math-reject-arg a "*Division by zero"))) |
(math-reject-arg a "*Division by zero")))) |
|
) |
|
1582 |
|
|
1583 |
(defun math-div-zero (a b) |
(defun math-div-zero (a b) |
1584 |
(if (math-known-matrixp b) |
(if (math-known-matrixp b) |
1598 |
(memq calc-infinite-mode '(1 -1))) |
(memq calc-infinite-mode '(1 -1))) |
1599 |
(nth 3 b) '(var inf var-inf))) |
(nth 3 b) '(var inf var-inf))) |
1600 |
(math-reject-arg b "*Division by zero")) |
(math-reject-arg b "*Division by zero")) |
1601 |
a))) |
a)))) |
|
) |
|
1602 |
|
|
1603 |
(defun math-div-symb-fancy (a b) |
(defun math-div-symb-fancy (a b) |
1604 |
(or (and math-simplify-only |
(or (and math-simplify-only |
1704 |
b |
b |
1705 |
(let ((calc-infinite-mode 1)) |
(let ((calc-infinite-mode 1)) |
1706 |
(math-mul-zero b a)))) |
(math-mul-zero b a)))) |
1707 |
(list '/ a b)) |
(list '/ a b))) |
|
) |
|
1708 |
|
|
1709 |
|
|
1710 |
(defun calcFunc-mod (a b) |
(defun calcFunc-mod (a b) |
1711 |
(math-normalize (list '% a b)) |
(math-normalize (list '% a b))) |
|
) |
|
1712 |
|
|
1713 |
(defun math-mod-fancy (a b) |
(defun math-mod-fancy (a b) |
1714 |
(cond ((equal b '(var inf var-inf)) |
(cond ((equal b '(var inf var-inf)) |
1729 |
(if (Math-anglep a) |
(if (Math-anglep a) |
1730 |
(calc-record-why 'anglep b) |
(calc-record-why 'anglep b) |
1731 |
(calc-record-why 'anglep a)) |
(calc-record-why 'anglep a)) |
1732 |
(list '% a b))) |
(list '% a b)))) |
|
) |
|
1733 |
|
|
1734 |
|
|
1735 |
(defun calcFunc-pow (a b) |
(defun calcFunc-pow (a b) |
1736 |
(math-normalize (list '^ a b)) |
(math-normalize (list '^ a b))) |
|
) |
|
1737 |
|
|
1738 |
(defun math-pow-of-zero (a b) |
(defun math-pow-of-zero (a b) |
1739 |
(if (Math-zerop b) |
(if (Math-zerop b) |
1752 |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
1753 |
(if (math-objectp b) |
(if (math-objectp b) |
1754 |
(list '^ a b) |
(list '^ a b) |
1755 |
a)))))) |
a))))))) |
|
) |
|
1756 |
|
|
1757 |
(defun math-pow-zero (a b) |
(defun math-pow-zero (a b) |
1758 |
(if (eq (car-safe a) 'mod) |
(if (eq (car-safe a) 'mod) |
1766 |
(not (math-intv-constp a t)))) |
(not (math-intv-constp a t)))) |
1767 |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
'(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
1768 |
(if (or (math-floatp a) (math-floatp b)) |
(if (or (math-floatp a) (math-floatp b)) |
1769 |
'(float 1 0) 1))))) |
'(float 1 0) 1)))))) |
|
) |
|
1770 |
|
|
1771 |
(defun math-pow-fancy (a b) |
(defun math-pow-fancy (a b) |
1772 |
(cond ((and (Math-numberp a) (Math-numberp b)) |
(cond ((and (Math-numberp a) (Math-numberp b)) |
1973 |
((not (Math-numberp a)) |
((not (Math-numberp a)) |
1974 |
(math-reject-arg a 'numberp)) |
(math-reject-arg a 'numberp)) |
1975 |
(t |
(t |
1976 |
(math-reject-arg b 'numberp))) |
(math-reject-arg b 'numberp)))) |
|
) |
|
1977 |
|
|
1978 |
(defun math-quarter-integer (x) |
(defun math-quarter-integer (x) |
1979 |
(if (Math-integerp x) |
(if (Math-integerp x) |
2001 |
(setq x (nth 1 x) |
(setq x (nth 1 x) |
2002 |
x (% (if (consp x) (nth 1 x) x) 100)) |
x (% (if (consp x) (nth 1 x) x) 100)) |
2003 |
(if (= x 25) 1 |
(if (= x 25) 1 |
2004 |
(if (= x 75) 3)))))))))) |
(if (= x 75) 3))))))))))) |
|
) |
|
2005 |
|
|
2006 |
;;; This assumes A < M and M > 0. |
;;; This assumes A < M and M > 0. |
2007 |
(defun math-pow-mod (a b m) ; [R R R R] |
(defun math-pow-mod (a b m) ; [R R R R] |
2011 |
(if (eq m 1) |
(if (eq m 1) |
2012 |
0 |
0 |
2013 |
(math-pow-mod-step a b m))) |
(math-pow-mod-step a b m))) |
2014 |
(math-mod (math-pow a b) m)) |
(math-mod (math-pow a b) m))) |
|
) |
|
2015 |
|
|
2016 |
(defun math-pow-mod-step (a n m) ; [I I I I] |
(defun math-pow-mod-step (a n m) ; [I I I I] |
2017 |
(math-working "pow" a) |
(math-working "pow" a) |
2027 |
rest |
rest |
2028 |
(math-mod (math-mul a rest) m))))))) |
(math-mod (math-mul a rest) m))))))) |
2029 |
(math-working "pow" val) |
(math-working "pow" val) |
2030 |
val) |
val)) |
|
) |
|
2031 |
|
|
2032 |
|
|
2033 |
;;; Compute the minimum of two real numbers. [R R R] [Public] |
;;; Compute the minimum of two real numbers. [R R R] [Public] |
2056 |
b |
b |
2057 |
(if (= res 2) |
(if (= res 2) |
2058 |
'(var nan var-nan) |
'(var nan var-nan) |
2059 |
a))))) |
a)))))) |
|
) |
|
2060 |
|
|
2061 |
(defun calcFunc-min (&optional a &rest b) |
(defun calcFunc-min (&optional a &rest b) |
2062 |
(if (not a) |
(if (not a) |
2065 |
(and (eq (car a) 'intv) (math-intv-constp a)) |
(and (eq (car a) 'intv) (math-intv-constp a)) |
2066 |
(math-infinitep a))) |
(math-infinitep a))) |
2067 |
(math-reject-arg a 'anglep)) |
(math-reject-arg a 'anglep)) |
2068 |
(math-min-list a b)) |
(math-min-list a b))) |
|
) |
|
2069 |
|
|
2070 |
(defun math-min-list (a b) |
(defun math-min-list (a b) |
2071 |
(if b |
(if b |
2074 |
(math-infinitep (car b))) |
(math-infinitep (car b))) |
2075 |
(math-min-list (math-min a (car b)) (cdr b)) |
(math-min-list (math-min a (car b)) (cdr b)) |
2076 |
(math-reject-arg (car b) 'anglep)) |
(math-reject-arg (car b) 'anglep)) |
2077 |
a) |
a)) |
|
) |
|
2078 |
|
|
2079 |
;;; Compute the maximum of two real numbers. [R R R] [Public] |
;;; Compute the maximum of two real numbers. [R R R] [Public] |
2080 |
(defun math-max (a b) |
(defun math-max (a b) |
2086 |
b |
b |
2087 |
(if (= res 2) |
(if (= res 2) |
2088 |
'(var nan var-nan) |
'(var nan var-nan) |
2089 |
a)))) |
a))))) |
|
) |
|
2090 |
|
|
2091 |
(defun calcFunc-max (&optional a &rest b) |
(defun calcFunc-max (&optional a &rest b) |
2092 |
(if (not a) |
(if (not a) |
2095 |
(and (eq (car a) 'intv) (math-intv-constp a)) |
(and (eq (car a) 'intv) (math-intv-constp a)) |
2096 |
(math-infinitep a))) |
(math-infinitep a))) |
2097 |
(math-reject-arg a 'anglep)) |
(math-reject-arg a 'anglep)) |
2098 |
(math-max-list a b)) |
(math-max-list a b))) |
|
) |
|
2099 |
|
|
2100 |
(defun math-max-list (a b) |
(defun math-max-list (a b) |
2101 |
(if b |
(if b |
2104 |
(math-infinitep (car b))) |
(math-infinitep (car b))) |
2105 |
(math-max-list (math-max a (car b)) (cdr b)) |
(math-max-list (math-max a (car b)) (cdr b)) |
2106 |
(math-reject-arg (car b) 'anglep)) |
(math-reject-arg (car b) 'anglep)) |
2107 |
a) |
a)) |
|
) |
|
2108 |
|
|
2109 |
|
|
2110 |
;;; Compute the absolute value of A. [O O; r r] [Public] |
;;; Compute the absolute value of A. [O O; r r] [Public] |
2150 |
inf |
inf |
2151 |
'(var inf var-inf))))) |
'(var inf var-inf))))) |
2152 |
(t (calc-record-why 'numvecp a) |
(t (calc-record-why 'numvecp a) |
2153 |
(list 'calcFunc-abs a))) |
(list 'calcFunc-abs a)))) |
|
) |
|
|
(fset 'calcFunc-abs (symbol-function 'math-abs)) |
|
2154 |
|
|
2155 |
|
(defalias 'calcFunc-abs 'math-abs) |
2156 |
|
|
2157 |
(defun math-float-fancy (a) |
(defun math-float-fancy (a) |
2158 |
(cond ((eq (car a) 'intv) |
(cond ((eq (car a) 'intv) |
2175 |
(calcFunc-rounde . calcFunc-frounde) |
(calcFunc-rounde . calcFunc-frounde) |
2176 |
(calcFunc-roundu . calcFunc-froundu))))) |
(calcFunc-roundu . calcFunc-froundu))))) |
2177 |
(and func (cons (cdr func) (cdr a))))) |
(and func (cons (cdr func) (cdr a))))) |
2178 |
(t (math-reject-arg a 'objectp))) |
(t (math-reject-arg a 'objectp)))) |
|
) |
|
|
(fset 'calcFunc-float (symbol-function 'math-float)) |
|
2179 |
|
|
2180 |
|
(defalias 'calcFunc-float 'math-float) |
2181 |
|
|
2182 |
(defun math-trunc-fancy (a) |
(defun math-trunc-fancy (a) |
2183 |
(cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) |
(cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) |
2214 |
a |
a |
2215 |
'(var nan var-nan))) |
'(var nan var-nan))) |
2216 |
((math-to-integer a)) |
((math-to-integer a)) |
2217 |
(t (math-reject-arg a 'numberp))) |
(t (math-reject-arg a 'numberp)))) |
|
) |
|
2218 |
|
|
2219 |
(defun math-trunc-special (a prec) |
(defun math-trunc-special (a prec) |
2220 |
(if (Math-messy-integerp prec) |
(if (Math-messy-integerp prec) |
2226 |
a |
a |
2227 |
(calcFunc-scf (math-trunc (let ((calc-prefer-frac t)) |
(calcFunc-scf (math-trunc (let ((calc-prefer-frac t)) |
2228 |
(calcFunc-scf a prec))) |
(calcFunc-scf a prec))) |
2229 |
(- prec))) |
(- prec)))) |
|
) |
|
2230 |
|
|
2231 |
(defun math-to-integer (a) |
(defun math-to-integer (a) |
2232 |
(let ((func (assq (car-safe a) '((calcFunc-ffloor . calcFunc-floor) |
(let ((func (assq (car-safe a) '((calcFunc-ffloor . calcFunc-floor) |
2236 |
(calcFunc-frounde . calcFunc-rounde) |
(calcFunc-frounde . calcFunc-rounde) |
2237 |
(calcFunc-froundu . calcFunc-roundu))))) |
(calcFunc-froundu . calcFunc-roundu))))) |
2238 |
(and func (= (length a) 2) |
(and func (= (length a) 2) |
2239 |
(cons (cdr func) (cdr a)))) |
(cons (cdr func) (cdr a))))) |
|
) |
|
2240 |
|
|
2241 |
(defun calcFunc-ftrunc (a &optional prec) |
(defun calcFunc-ftrunc (a &optional prec) |
2242 |
(if (and (Math-messy-integerp a) |
(if (and (Math-messy-integerp a) |
2243 |
(or (not prec) (and (integerp prec) |
(or (not prec) (and (integerp prec) |
2244 |
(<= prec 0)))) |
(<= prec 0)))) |
2245 |
a |
a |
2246 |
(math-float (math-trunc a prec))) |
(math-float (math-trunc a prec)))) |
|
) |
|
2247 |
|
|
2248 |
(defun math-floor-fancy (a) |
(defun math-floor-fancy (a) |
2249 |
(cond ((math-provably-integerp a) a) |
(cond ((math-provably-integerp a) a) |
2273 |
a |
a |
2274 |
'(var nan var-nan))) |
'(var nan var-nan))) |
2275 |
((math-to-integer a)) |
((math-to-integer a)) |
2276 |
(t (math-reject-arg a 'anglep))) |
(t (math-reject-arg a 'anglep)))) |
|
) |
|
2277 |
|
|
2278 |
(defun math-floor-special (a prec) |
(defun math-floor-special (a prec) |
2279 |
(if (Math-messy-integerp prec) |
(if (Math-messy-integerp prec) |
2285 |
a |
a |
2286 |
(calcFunc-scf (math-floor (let ((calc-prefer-frac t)) |
(calcFunc-scf (math-floor (let ((calc-prefer-frac t)) |
2287 |
(calcFunc-scf a prec))) |
(calcFunc-scf a prec))) |
2288 |
(- prec))) |
(- prec)))) |
|
) |
|
2289 |
|
|
2290 |
(defun calcFunc-ffloor (a &optional prec) |
(defun calcFunc-ffloor (a &optional prec) |
2291 |
(if (and (Math-messy-integerp a) |
(if (and (Math-messy-integerp a) |
2292 |
(or (not prec) (and (integerp prec) |
(or (not prec) (and (integerp prec) |
2293 |
(<= prec 0)))) |
(<= prec 0)))) |
2294 |
a |
a |
2295 |
(math-float (math-floor a prec))) |
(math-float (math-floor a prec)))) |
|
) |
|
2296 |
|
|
2297 |
;;; Coerce A to be an integer (by truncation toward plus infinity). [I N] |
;;; Coerce A to be an integer (by truncation toward plus infinity). [I N] |
2298 |
(defun math-ceiling (a &optional prec) ; [Public] |
(defun math-ceiling (a &optional prec) ; [Public] |
2340 |
a |
a |
2341 |
'(var nan var-nan))) |
'(var nan var-nan))) |
2342 |
((math-to-integer a)) |
((math-to-integer a)) |
2343 |
(t (math-reject-arg a 'anglep))) |
(t (math-reject-arg a 'anglep)))) |
2344 |
) |
|
2345 |
(fset 'calcFunc-ceil (symbol-function 'math-ceiling)) |
(defalias 'calcFunc-ceil 'math-ceiling) |
2346 |
|
|
2347 |
(defun calcFunc-fceil (a &optional prec) |
(defun calcFunc-fceil (a &optional prec) |
2348 |
(if (and (Math-messy-integerp a) |
(if (and (Math-messy-integerp a) |
2349 |
(or (not prec) (and (integerp prec) |
(or (not prec) (and (integerp prec) |
2350 |
(<= prec 0)))) |
(<= prec 0)))) |
2351 |
a |
a |
2352 |
(math-float (math-ceiling a prec))) |
(math-float (math-ceiling a prec)))) |
|
) |
|
2353 |
|
|
2354 |
(setq math-rounding-mode nil) |
(setq math-rounding-mode nil) |
2355 |
|
|
2393 |
a |
a |
2394 |
'(var nan var-nan))) |
'(var nan var-nan))) |
2395 |
((math-to-integer a)) |
((math-to-integer a)) |
2396 |
(t (math-reject-arg a 'anglep))) |
(t (math-reject-arg a 'anglep)))) |
|
) |
|
|
(fset 'calcFunc-round (symbol-function 'math-round)) |
|
2397 |
|
|
2398 |
(defun calcFunc-rounde (a &optional prec) |
(defalias 'calcFunc-round 'math-round) |
2399 |
|
|
2400 |
|
(defsubst calcFunc-rounde (a &optional prec) |
2401 |
(let ((math-rounding-mode 'even)) |
(let ((math-rounding-mode 'even)) |
2402 |
(math-round a prec)) |
(math-round a prec))) |
|
) |
|
2403 |
|
|
2404 |
(defun calcFunc-roundu (a &optional prec) |
(defsubst calcFunc-roundu (a &optional prec) |
2405 |
(let ((math-rounding-mode 'up)) |
(let ((math-rounding-mode 'up)) |
2406 |
(math-round a prec)) |
(math-round a prec))) |
|
) |
|
2407 |
|
|
2408 |
(defun calcFunc-fround (a &optional prec) |
(defun calcFunc-fround (a &optional prec) |
2409 |
(if (and (Math-messy-integerp a) |
(if (and (Math-messy-integerp a) |
2410 |
(or (not prec) (and (integerp prec) |
(or (not prec) (and (integerp prec) |
2411 |
(<= prec 0)))) |
(<= prec 0)))) |
2412 |
a |
a |
2413 |
(math-float (math-round a prec))) |
(math-float (math-round a prec)))) |
|
) |
|
2414 |
|
|
2415 |
(defun calcFunc-frounde (a &optional prec) |
(defsubst calcFunc-frounde (a &optional prec) |
2416 |
(let ((math-rounding-mode 'even)) |
(let ((math-rounding-mode 'even)) |
2417 |
(calcFunc-fround a prec)) |
(calcFunc-fround a prec))) |
|
) |
|
2418 |
|
|
2419 |
(defun calcFunc-froundu (a &optional prec) |
(defsubst calcFunc-froundu (a &optional prec) |
2420 |
(let ((math-rounding-mode 'up)) |
(let ((math-rounding-mode 'up)) |
2421 |
(calcFunc-fround a prec)) |
(calcFunc-fround a prec))) |
|
) |
|
|
|
|
2422 |
|
|
2423 |
;;; Pull floating-point values apart into mantissa and exponent. |
;;; Pull floating-point values apart into mantissa and exponent. |
2424 |
(defun calcFunc-mant (x) |
(defun calcFunc-mant (x) |
2428 |
x |
x |
2429 |
(list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x))))) |
(list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x))))) |
2430 |
(calc-record-why 'realp x) |
(calc-record-why 'realp x) |
2431 |
(list 'calcFunc-mant x)) |
(list 'calcFunc-mant x))) |
|
) |
|
2432 |
|
|
2433 |
(defun calcFunc-xpon (x) |
(defun calcFunc-xpon (x) |
2434 |
(if (Math-realp x) |
(if (Math-realp x) |
2437 |
0 |
0 |
2438 |
(math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) |
(math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) |
2439 |
(calc-record-why 'realp x) |
(calc-record-why 'realp x) |
2440 |
(list 'calcFunc-xpon x)) |
(list 'calcFunc-xpon x))) |
|
) |
|
2441 |
|
|
2442 |
(defun calcFunc-scf (x n) |
(defun calcFunc-scf (x n) |
2443 |
(if (integerp n) |
(if (integerp n) |
2483 |
(if (math-integerp n) |
(if (math-integerp n) |
2484 |
(math-overflow n) |
(math-overflow n) |
2485 |
(calc-record-why 'integerp n) |
(calc-record-why 'integerp n) |
2486 |
(list 'calcFunc-scf x n)))) |
(list 'calcFunc-scf x n))))) |
|
) |
|
2487 |
|
|
2488 |
|
|
2489 |
(defun calcFunc-incr (x &optional step relative-to) |
(defun calcFunc-incr (x &optional step relative-to) |
2507 |
(math-add x step) |
(math-add x step) |
2508 |
(math-add x (list 'hms 0 0 step)))) |
(math-add x (list 'hms 0 0 step)))) |
2509 |
(t |
(t |
2510 |
(math-reject-arg x 'realp))) |
(math-reject-arg x 'realp)))) |
|
) |
|
|
|
|
|
(defun calcFunc-decr (x &optional step relative-to) |
|
|
(calcFunc-incr x (math-neg (or step 1)) relative-to) |
|
|
) |
|
2511 |
|
|
2512 |
|
(defsubst calcFunc-decr (x &optional step relative-to) |
2513 |
|
(calcFunc-incr x (math-neg (or step 1)) relative-to)) |
2514 |
|
|
2515 |
(defun calcFunc-percent (x) |
(defun calcFunc-percent (x) |
2516 |
(if (math-objectp x) |
(if (math-objectp x) |
2517 |
(let ((calc-prefer-frac nil)) |
(let ((calc-prefer-frac nil)) |
2518 |
(math-div x 100)) |
(math-div x 100)) |
2519 |
(list 'calcFunc-percent x)) |
(list 'calcFunc-percent x))) |
|
) |
|
2520 |
|
|
2521 |
(defun calcFunc-relch (x y) |
(defun calcFunc-relch (x y) |
2522 |
(if (and (math-objectp x) (math-objectp y)) |
(if (and (math-objectp x) (math-objectp y)) |
2523 |
(math-div (math-sub y x) x) |
(math-div (math-sub y x) x) |
2524 |
(list 'calcFunc-relch x y)) |
(list 'calcFunc-relch x y))) |
|
) |
|
|
|
|
|
|
|
2525 |
|
|
2526 |
;;; Compute the absolute value squared of A. [F N] [Public] |
;;; Compute the absolute value squared of A. [F N] [Public] |
2527 |
(defun calcFunc-abssqr (a) |
(defun calcFunc-abssqr (a) |
2542 |
(and inf |
(and inf |
2543 |
(math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf)))) |
(math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf)))) |
2544 |
(t (calc-record-why 'numvecp a) |
(t (calc-record-why 'numvecp a) |
2545 |
(list 'calcFunc-abssqr a))) |
(list 'calcFunc-abssqr a)))) |
|
) |
|
|
(defun math-sqr (a) |
|
|
(math-mul a a) |
|
|
) |
|
2546 |
|
|
2547 |
|
(defsubst math-sqr (a) |
2548 |
|
(math-mul a a)) |
2549 |
|
|
2550 |
;;;; Number theory. |
;;;; Number theory. |
2551 |
|
|
2568 |
((or (math-infinitep a) |
((or (math-infinitep a) |
2569 |
(math-infinitep b)) |
(math-infinitep b)) |
2570 |
(math-div a b)) |
(math-div a b)) |
2571 |
(t (math-reject-arg a 'anglep))) |
(t (math-reject-arg a 'anglep)))) |
|
) |
|
2572 |
|
|
2573 |
|
|
2574 |
;;; Combine two terms being added, if possible. |
;;; Combine two terms being added, if possible. |
2611 |
(if nega (setq amult (math-neg amult))) |
(if nega (setq amult (math-neg amult))) |
2612 |
(if negb (setq bmult (math-neg bmult))) |
(if negb (setq bmult (math-neg bmult))) |
2613 |
(setq amult (math-add amult bmult)) |
(setq amult (math-add amult bmult)) |
2614 |
(math-mul amult a))))) |
(math-mul amult a)))))) |
|
) |
|
2615 |
|
|
2616 |
(defun math-add-or-sub (a b aneg bneg) |
(defun math-add-or-sub (a b aneg bneg) |
2617 |
(if aneg (setq a (math-neg a))) |
(if aneg (setq a (math-neg a))) |
2618 |
(if bneg (setq b (math-neg b))) |
(if bneg (setq b (math-neg b))) |
2619 |
(if (or (Math-vectorp a) (Math-vectorp b)) |
(if (or (Math-vectorp a) (Math-vectorp b)) |
2620 |
(math-normalize (list '+ a b)) |
(math-normalize (list '+ a b)) |
2621 |
(math-add a b)) |
(math-add a b))) |
|
) |
|
2622 |
|
|
2623 |
;;; The following is expanded out four ways for speed. |
;;; The following is expanded out four ways for speed. |
2624 |
(defun math-combine-prod (a b inva invb scalar-okay) |
(defun math-combine-prod (a b inva invb scalar-okay) |
2733 |
(setq a (math-mul a b)) |
(setq a (math-mul a b)) |
2734 |
(condition-case err |
(condition-case err |
2735 |
(math-pow a apow) |
(math-pow a apow) |
2736 |
(inexact-result (list '^ a apow)))))))))) |
(inexact-result (list '^ a apow))))))))))) |
|
) |
|
2737 |
(setq math-combine-prod-e '(var e var-e)) |
(setq math-combine-prod-e '(var e var-e)) |
2738 |
|
|
2739 |
(defun math-mul-or-div (a b ainv binv) |
(defun math-mul-or-div (a b ainv binv) |
2752 |
(math-div b a)) |
(math-div b a)) |
2753 |
(if binv |
(if binv |
2754 |
(math-div a b) |
(math-div a b) |
2755 |
(math-mul a b)))) |
(math-mul a b))))) |
|
) |
|
2756 |
|
|
2757 |
(defun math-commutative-equal (a b) |
(defun math-commutative-equal (a b) |
2758 |
(if (memq (car-safe a) '(+ -)) |
(if (memq (car-safe a) '(+ -)) |
2773 |
(setq bterms (delq (car p) bterms) |
(setq bterms (delq (car p) bterms) |
2774 |
aterms (cdr aterms))) |
aterms (cdr aterms))) |
2775 |
(not aterms))))) |
(not aterms))))) |
2776 |
(equal a b)) |
(equal a b))) |
|
) |
|
2777 |
|
|
2778 |
(defun math-commutative-collect (b neg) |
(defun math-commutative-collect (b neg) |
2779 |
(if (eq (car-safe b) '+) |
(if (eq (car-safe b) '+) |
2784 |
(progn |
(progn |
2785 |
(math-commutative-collect (nth 1 b) neg) |
(math-commutative-collect (nth 1 b) neg) |
2786 |
(math-commutative-collect (nth 2 b) (not neg))) |
(math-commutative-collect (nth 2 b) (not neg))) |
2787 |
(setq bterms (cons (if neg (math-neg b) b) bterms)))) |
(setq bterms (cons (if neg (math-neg b) b) bterms))))) |
|
) |
|
|
|
|
2788 |
|
|
2789 |
|
;;; calc-arith.el ends here |