/[emacs]/emacs/lisp/calc/calc-arith.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-arith.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:01:07 2001 UTC
# Line 1  Line 1 
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.
# Line 34  Line 34 
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)
# Line 66  Line 62 
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")
# Line 84  Line 78 
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)
# Line 155  Line 140 
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.
# Line 223  Line 206 
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)
# Line 247  Line 227 
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)
# Line 274  Line 252 
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)
# Line 294  Line 271 
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)
# Line 335  Line 305 
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,
# Line 524  Line 493 
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.
# Line 705  Line 669 
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)
# Line 725  Line 688 
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)
# Line 740  Line 702 
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)
# Line 813  Line 765 
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)
# Line 822  Line 773 
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)
# Line 856  Line 805 
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.
# Line 871  Line 818 
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    
# Line 891  Line 836 
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
# Line 907  Line 849 
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)
# Line 993  Line 927 
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)
# Line 1012  Line 943 
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
# Line 1021  Line 951 
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))
# Line 1130  Line 1059 
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
# Line 1210  Line 1138 
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)
# Line 1220  Line 1147 
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))
# Line 1320  Line 1246 
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))
# Line 1342  Line 1265 
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)
# Line 1371  Line 1293 
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)
# Line 1484  Line 1405 
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))
# Line 1640  Line 1559 
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)
# Line 1660  Line 1578 
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)
# Line 1681  Line 1598 
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
# Line 1788  Line 1704 
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))
# Line 1815  Line 1729 
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)
# Line 1840  Line 1752 
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)
# Line 1855  Line 1766 
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))
# Line 2063  Line 1973 
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)
# Line 2092  Line 2001 
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]
# Line 2103  Line 2011 
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)
# Line 2120  Line 2027 
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]
# Line 2150  Line 2056 
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)
# Line 2160  Line 2065 
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
# Line 2170  Line 2074 
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)
# Line 2183  Line 2086 
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)
# Line 2193  Line 2095 
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
# Line 2203  Line 2104 
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]
# Line 2250  Line 2150 
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)
# Line 2276  Line 2175 
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)))
# Line 2316  Line 2214 
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)
# Line 2329  Line 2226 
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)
# Line 2340  Line 2236 
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)
# Line 2379  Line 2273 
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)
# Line 2392  Line 2285 
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]
# Line 2449  Line 2340 
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    
# Line 2503  Line 2393 
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)
# Line 2544  Line 2428 
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)
# Line 2554  Line 2437 
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)
# Line 2601  Line 2483 
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)
# Line 2626  Line 2507 
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)
# Line 2668  Line 2542 
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    
# Line 2696  Line 2568 
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.
# Line 2740  Line 2611 
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)
# Line 2864  Line 2733 
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)
# Line 2884  Line 2752 
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) '(+ -))
# Line 2906  Line 2773 
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) '+)
# Line 2918  Line 2784 
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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26