calc-arith.el

Revision 4220, 94.8 kB (checked in by miyoshi, 9 months ago)
Sync up with Emacs22.2.

Line
1	;;; calc-arith.el --- arithmetic functions for Calc
2
3	;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6	;; Author: David Gillespie <daveg@synaptics.com>
7	;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8
9	;; This file is part of GNU Emacs.
10
11	;; GNU Emacs is free software; you can redistribute it and/or modify
12	;; it under the terms of the GNU General Public License as published by
13	;; the Free Software Foundation; either version 3, or (at your option)
14	;; any later version.
15
16	;; GNU Emacs is distributed in the hope that it will be useful,
17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19	;; GNU General Public License for more details.
20
21	;; You should have received a copy of the GNU General Public License
22	;; along with GNU Emacs; see the file COPYING. If not, write to the
23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24	;; Boston, MA 02110-1301, USA.
25
26	;;; Commentary:
27
28	;;; Code:
29
30	;; This file is autoloaded from calc-ext.el.
31
32	(require 'calc-ext)
33	(require 'calc-macs)
34
35	;;; The following lists are not exhaustive.
36	(defvar math-scalar-functions '(calcFunc-det
37	calcFunc-cnorm calcFunc-rnorm
38	calcFunc-vlen calcFunc-vcount
39	calcFunc-vsum calcFunc-vprod
40	calcFunc-vmin calcFunc-vmax))
41
42	(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag
43	calcFunc-cvec calcFunc-index
44	calcFunc-trn
45	\| calcFunc-append
46	calcFunc-cons calcFunc-rcons
47	calcFunc-tail calcFunc-rhead))
48
49	(defvar math-scalar-if-args-functions '(+ - * / neg))
50
51	(defvar math-real-functions '(calcFunc-arg
52	calcFunc-re calcFunc-im
53	calcFunc-floor calcFunc-ceil
54	calcFunc-trunc calcFunc-round
55	calcFunc-rounde calcFunc-roundu
56	calcFunc-ffloor calcFunc-fceil
57	calcFunc-ftrunc calcFunc-fround
58	calcFunc-frounde calcFunc-froundu))
59
60	(defvar math-positive-functions '())
61
62	(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm
63	calcFunc-vlen calcFunc-vcount))
64
65	(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs
66	calcFunc-choose calcFunc-perm
67	calcFunc-eq calcFunc-neq
68	calcFunc-lt calcFunc-gt
69	calcFunc-leq calcFunc-geq
70	calcFunc-lnot
71	calcFunc-max calcFunc-min))
72
73	(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos
74	calcFunc-tan calcFunc-sec
75	calcFunc-csc calcFunc-cot
76	calcFunc-arctan
77	calcFunc-sinh calcFunc-cosh
78	calcFunc-tanh calcFunc-sech
79	calcFunc-csch calcFunc-coth
80	calcFunc-exp
81	calcFunc-gamma calcFunc-fact))
82
83	(defvar math-integer-functions '(calcFunc-idiv
84	calcFunc-isqrt calcFunc-ilog
85	calcFunc-vlen calcFunc-vcount))
86
87	(defvar math-num-integer-functions '())
88
89	(defvar math-rounding-functions '(calcFunc-floor
90	calcFunc-ceil
91	calcFunc-round calcFunc-trunc
92	calcFunc-rounde calcFunc-roundu))
93
94	(defvar math-float-rounding-functions '(calcFunc-ffloor
95	calcFunc-fceil
96	calcFunc-fround calcFunc-ftrunc
97	calcFunc-frounde calcFunc-froundu))
98
99	(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs
100	calcFunc-min calcFunc-max
101	calcFunc-choose calcFunc-perm))
102
103
104	;;; Arithmetic.
105
106	(defun calc-min (arg)
107	(interactive "P")
108	(calc-slow-wrapper
109	(calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf))))
110
111	(defun calc-max (arg)
112	(interactive "P")
113	(calc-slow-wrapper
114	(calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf)))))
115
116	(defun calc-abs (arg)
117	(interactive "P")
118	(calc-slow-wrapper
119	(calc-unary-op "abs" 'calcFunc-abs arg)))
120
121
122	(defun calc-idiv (arg)
123	(interactive "P")
124	(calc-slow-wrapper
125	(calc-binary-op "\\" 'calcFunc-idiv arg 1)))
126
127
128	(defun calc-floor (arg)
129	(interactive "P")
130	(calc-slow-wrapper
131	(if (calc-is-inverse)
132	(if (calc-is-hyperbolic)
133	(calc-unary-op "ceil" 'calcFunc-fceil arg)
134	(calc-unary-op "ceil" 'calcFunc-ceil arg))
135	(if (calc-is-hyperbolic)
136	(calc-unary-op "flor" 'calcFunc-ffloor arg)
137	(calc-unary-op "flor" 'calcFunc-floor arg)))))
138
139	(defun calc-ceiling (arg)
140	(interactive "P")
141	(calc-invert-func)
142	(calc-floor arg))
143
144	(defun calc-round (arg)
145	(interactive "P")
146	(calc-slow-wrapper
147	(if (calc-is-inverse)
148	(if (calc-is-hyperbolic)
149	(calc-unary-op "trnc" 'calcFunc-ftrunc arg)
150	(calc-unary-op "trnc" 'calcFunc-trunc arg))
151	(if (calc-is-hyperbolic)
152	(calc-unary-op "rond" 'calcFunc-fround arg)
153	(calc-unary-op "rond" 'calcFunc-round arg)))))
154
155	(defun calc-trunc (arg)
156	(interactive "P")
157	(calc-invert-func)
158	(calc-round arg))
159
160	(defun calc-mant-part (arg)
161	(interactive "P")
162	(calc-slow-wrapper
163	(calc-unary-op "mant" 'calcFunc-mant arg)))
164
165	(defun calc-xpon-part (arg)
166	(interactive "P")
167	(calc-slow-wrapper
168	(calc-unary-op "xpon" 'calcFunc-xpon arg)))
169
170	(defun calc-scale-float (arg)
171	(interactive "P")
172	(calc-slow-wrapper
173	(calc-binary-op "scal" 'calcFunc-scf arg)))
174
175	(defun calc-abssqr (arg)
176	(interactive "P")
177	(calc-slow-wrapper
178	(calc-unary-op "absq" 'calcFunc-abssqr arg)))
179
180	(defun calc-sign (arg)
181	(interactive "P")
182	(calc-slow-wrapper
183	(calc-unary-op "sign" 'calcFunc-sign arg)))
184
185	(defun calc-increment (arg)
186	(interactive "p")
187	(calc-wrapper
188	(calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg))))
189
190	(defun calc-decrement (arg)
191	(interactive "p")
192	(calc-wrapper
193	(calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg))))
194
195
196	(defun math-abs-approx (a)
197	(cond ((Math-negp a)
198	(math-neg a))
199	((Math-anglep a)
200	a)
201	((eq (car a) 'cplx)
202	(math-add (math-abs (nth 1 a)) (math-abs (nth 2 a))))
203	((eq (car a) 'polar)
204	(nth 1 a))
205	((eq (car a) 'sdev)
206	(math-abs-approx (nth 1 a)))
207	((eq (car a) 'intv)
208	(math-max (math-abs (nth 2 a)) (math-abs (nth 3 a))))
209	((eq (car a) 'date)
210	a)
211	((eq (car a) 'vec)
212	(math-reduce-vec 'math-add-abs-approx a))
213	((eq (car a) 'calcFunc-abs)
214	(car a))
215	(t a)))
216
217	(defun math-add-abs-approx (a b)
218	(math-add (math-abs-approx a) (math-abs-approx b)))
219
220
221	;;;; Declarations.
222
223	(defvar math-decls-cache-tag nil)
224	(defvar math-decls-cache nil)
225	(defvar math-decls-all nil)
226
227	;;; Math-decls-cache is an a-list where each entry is a list of the form:
228	;;; (VAR TYPES RANGE)
229	;;; where VAR is a variable name (with var- prefix) or function name;
230	;;; TYPES is a list of type symbols (any, int, frac, ...)
231	;;; RANGE is a sorted vector of intervals describing the range.
232
233	(defvar math-super-types
234	'((int numint rat real number)
235	(numint real number)
236	(frac rat real number)
237	(rat real number)
238	(float real number)
239	(real number)
240	(number)
241	(scalar)
242	(sqmatrix matrix vector)
243	(matrix vector)
244	(vector)
245	(const)))
246
247	(defun math-setup-declarations ()
248	(or (eq math-decls-cache-tag (calc-var-value 'var-Decls))
249	(let ((p (calc-var-value 'var-Decls))
250	vec type range)
251	(setq math-decls-cache-tag p
252	math-decls-cache nil)
253	(and (eq (car-safe p) 'vec)
254	(while (setq p (cdr p))
255	(and (eq (car-safe (car p)) 'vec)
256	(setq vec (nth 2 (car p)))
257	(condition-case err
258	(let ((v (nth 1 (car p))))
259	(setq type nil range nil)
260	(or (eq (car-safe vec) 'vec)
261	(setq vec (list 'vec vec)))
262	(while (and (setq vec (cdr vec))
263	(not (Math-objectp (car vec))))
264	(and (eq (car-safe (car vec)) 'var)
265	(let ((st (assq (nth 1 (car vec))
266	math-super-types)))
267	(cond (st (setq type (append type st)))
268	((eq (nth 1 (car vec)) 'pos)
269	(setq type (append type
270	'(real number))
271	range
272	'(intv 1 0 (var inf var-inf))))
273	((eq (nth 1 (car vec)) 'nonneg)
274	(setq type (append type
275	'(real number))
276	range
277	'(intv 3 0
278	(var inf var-inf))))))))
279	(if vec
280	(setq type (append type '(real number))
281	range (math-prepare-set (cons 'vec vec))))
282	(setq type (list type range))
283	(or (eq (car-safe v) 'vec)
284	(setq v (list 'vec v)))
285	(while (setq v (cdr v))
286	(if (or (eq (car-safe (car v)) 'var)
287	(not (Math-primp (car v))))
288	(setq math-decls-cache
289	(cons (cons (if (eq (car (car v)) 'var)
290	(nth 2 (car v))
291	(car (car v)))
292	type)
293	math-decls-cache)))))
294	(error nil)))))
295	(setq math-decls-all (assq 'var-All math-decls-cache)))))
296
297	(defun math-known-scalarp (a &optional assume-scalar)
298	(math-setup-declarations)
299	(if (if calc-matrix-mode
300	(eq calc-matrix-mode 'scalar)
301	assume-scalar)
302	(not (math-check-known-matrixp a))
303	(math-check-known-scalarp a)))
304
305	(defun math-known-matrixp (a)
306	(and (not (Math-scalarp a))
307	(not (math-known-scalarp a t))))
308
309	(defun math-known-square-matrixp (a)
310	(and (math-known-matrixp a)
311	(math-check-known-square-matrixp a)))
312
313	;;; Try to prove that A is a scalar (i.e., a non-vector).
314	(defun math-check-known-scalarp (a)
315	(cond ((Math-objectp a) t)
316	((memq (car a) math-scalar-functions)
317	t)
318	((memq (car a) math-real-scalar-functions)
319	t)
320	((memq (car a) math-scalar-if-args-functions)
321	(while (and (setq a (cdr a))
322	(math-check-known-scalarp (car a))))
323	(null a))
324	((eq (car a) '^)
325	(math-check-known-scalarp (nth 1 a)))
326	((math-const-var a) t)
327	(t
328	(let ((decl (if (eq (car a) 'var)
329	(or (assq (nth 2 a) math-decls-cache)
330	math-decls-all)
331	(assq (car a) math-decls-cache)))
332	val)
333	(cond
334	((memq 'scalar (nth 1 decl))
335	t)
336	((and (eq (car a) 'var)
337	(symbolp (nth 2 a))
338	(boundp (nth 2 a))
339	(setq val (symbol-value (nth 2 a))))
340	(math-check-known-scalarp val))
341	(t
342	nil))))))
343
344	;;; Try to prove that A is not* a scalar.*
345	(defun math-check-known-matrixp (a)
346	(cond ((Math-objectp a) nil)
347	((memq (car a) math-nonscalar-functions)
348	t)
349	((memq (car a) math-scalar-if-args-functions)
350	(while (and (setq a (cdr a))
351	(not (math-check-known-matrixp (car a)))))
352	a)
353	((eq (car a) '^)
354	(math-check-known-matrixp (nth 1 a)))
355	((math-const-var a) nil)
356	(t
357	(let ((decl (if (eq (car a) 'var)
358	(or (assq (nth 2 a) math-decls-cache)
359	math-decls-all)
360	(assq (car a) math-decls-cache)))
361	val)
362	(cond
363	((memq 'matrix (nth 1 decl))
364	t)
365	((and (eq (car a) 'var)
366	(symbolp (nth 2 a))
367	(boundp (nth 2 a))
368	(setq val (symbol-value (nth 2 a))))
369	(math-check-known-matrixp val))
370	(t
371	nil))))))
372
373	;;; Given that A is a matrix, try to prove that it is a square matrix.
374	(defun math-check-known-square-matrixp (a)
375	(cond ((math-square-matrixp a)
376	t)
377	((eq (car-safe a) '^)
378	(math-check-known-square-matrixp (nth 1 a)))
379	((or
380	(eq (car-safe a) '*)
381	(eq (car-safe a) '+)
382	(eq (car-safe a) '-))
383	(and
384	(math-check-known-square-matrixp (nth 1 a))
385	(math-check-known-square-matrixp (nth 2 a))))
386	(t
387	(let ((decl (if (eq (car a) 'var)
388	(or (assq (nth 2 a) math-decls-cache)
389	math-decls-all)
390	(assq (car a) math-decls-cache)))
391	val)
392	(cond
393	((memq 'sqmatrix (nth 1 decl))
394	t)
395	((and (eq (car a) 'var)
396	(boundp (nth 2 a))
397	(setq val (symbol-value (nth 2 a))))
398	(math-check-known-square-matrixp val))
399	((and (or
400	(integerp calc-matrix-mode)
401	(eq calc-matrix-mode 'sqmatrix))
402	(eq (car-safe a) 'var))
403	t)
404	((memq 'matrix (nth 1 decl))
405	nil)
406	(t
407	nil))))))
408
409	;;; Try to prove that A is a real (i.e., not complex).
410	(defun math-known-realp (a)
411	(< (math-possible-signs a) 8))
412
413	;;; Try to prove that A is real and positive.
414	(defun math-known-posp (a)
415	(eq (math-possible-signs a) 4))
416
417	;;; Try to prove that A is real and negative.
418	(defun math-known-negp (a)
419	(eq (math-possible-signs a) 1))
420
421	;;; Try to prove that A is real and nonnegative.
422	(defun math-known-nonnegp (a)
423	(memq (math-possible-signs a) '(2 4 6)))
424
425	;;; Try to prove that A is real and nonpositive.
426	(defun math-known-nonposp (a)
427	(memq (math-possible-signs a) '(1 2 3)))
428
429	;;; Try to prove that A is nonzero.
430	(defun math-known-nonzerop (a)
431	(memq (math-possible-signs a) '(1 4 5 8 9 12 13)))
432
433	;;; Return true if A is negative, or looks negative but we don't know.
434	(defun math-guess-if-neg (a)
435	(let ((sgn (math-possible-signs a)))
436	(if (memq sgn '(1 3))
437	t
438	(if (memq sgn '(2 4 6))
439	nil
440	(math-looks-negp a)))))
441
442	;;; Find the possible signs of A, assuming A is a number of some kind.
443	;;; Returns an integer with bits: 1 may be negative,
444	;;; 2 may be zero,
445	;;; 4 may be positive,
446	;;; 8 may be nonreal.
447
448	(defun math-possible-signs (a &optional origin)
449	(cond ((Math-objectp a)
450	(if origin (setq a (math-sub a origin)))
451	(cond ((Math-posp a) 4)
452	((Math-negp a) 1)
453	((Math-zerop a) 2)
454	((eq (car a) 'intv)
455	(cond
456	((math-known-posp (nth 2 a)) 4)
457	((math-known-negp (nth 3 a)) 1)
458	((Math-zerop (nth 2 a)) 6)
459	((Math-zerop (nth 3 a)) 3)
460	(t 7)))
461	((eq (car a) 'sdev)
462	(if (math-known-realp (nth 1 a)) 7 15))
463	(t 8)))
464	((memq (car a) '(+ -))
465	(cond ((Math-realp (nth 1 a))
466	(if (eq (car a) '-)
467	(math-neg-signs
468	(math-possible-signs (nth 2 a)
469	(if origin
470	(math-add origin (nth 1 a))
471	(nth 1 a))))
472	(math-possible-signs (nth 2 a)
473	(if origin
474	(math-sub origin (nth 1 a))
475	(math-neg (nth 1 a))))))
476	((Math-realp (nth 2 a))
477	(let ((org (if (eq (car a) '-)
478	(nth 2 a)
479	(math-neg (nth 2 a)))))
480	(math-possible-signs (nth 1 a)
481	(if origin
482	(math-add origin org)
483	org))))
484	(t
485	(let ((s1 (math-possible-signs (nth 1 a) origin))
486	(s2 (math-possible-signs (nth 2 a))))
487	(if (eq (car a) '-) (setq s2 (math-neg-signs s2)))
488	(cond ((eq s1 s2) s1)
489	((eq s1 2) s2)
490	((eq s2 2) s1)
491	((>= s1 8) 15)
492	((>= s2 8) 15)
493	((and (eq s1 4) (eq s2 6)) 4)
494	((and (eq s2 4) (eq s1 6)) 4)
495	((and (eq s1 1) (eq s2 3)) 1)
496	((and (eq s2 1) (eq s1 3)) 1)
497	(t 7))))))
498	((eq (car a) 'neg)
499	(math-neg-signs (math-possible-signs
500	(nth 1 a)
501	(and origin (math-neg origin)))))
502	((and origin (Math-zerop origin) (setq origin nil)
503	nil))
504	((and (or (eq (car a) '*)
505	(and (eq (car a) '/) origin))
506	(Math-realp (nth 1 a)))
507	(let ((s (if (eq (car a) '*)
508	(if (Math-zerop (nth 1 a))
509	(math-possible-signs 0 origin)
510	(math-possible-signs (nth 2 a)
511	(math-div (or origin 0)
512	(nth 1 a))))
513	(math-neg-signs
514	(math-possible-signs (nth 2 a)
515	(math-div (nth 1 a)
516	origin))))))
517	(if (Math-negp (nth 1 a)) (math-neg-signs s) s)))
518	((and (memq (car a) '(* /)) (Math-realp (nth 2 a)))
519	(let ((s (math-possible-signs (nth 1 a)
520	(if (eq (car a) '*)
521	(math-mul (or origin 0) (nth 2 a))
522	(math-div (or origin 0) (nth 2 a))))))
523	(if (Math-negp (nth 2 a)) (math-neg-signs s) s)))
524	((eq (car a) 'vec)
525	(let ((signs 0))
526	(while (and (setq a (cdr a)) (< signs 15))
527	(setq signs (logior signs (math-possible-signs
528	(car a) origin))))
529	signs))
530	(t (let ((sign
531	(cond
532	((memq (car a) '(* /))
533	(let ((s1 (math-possible-signs (nth 1 a)))
534	(s2 (math-possible-signs (nth 2 a))))
535	(cond ((>= s1 8) 15)
536	((>= s2 8) 15)
537	((and (eq (car a) '/) (memq s2 '(2 3 6 7))) 15)
538	(t
539	(logior (if (memq s1 '(4 5 6 7)) s2 0)
540	(if (memq s1 '(2 3 6 7)) 2 0)
541	(if (memq s1 '(1 3 5 7))
542	(math-neg-signs s2) 0))))))
543	((eq (car a) '^)
544	(let ((s1 (math-possible-signs (nth 1 a)))
545	(s2 (math-possible-signs (nth 2 a))))
546	(cond ((>= s1 8) 15)
547	((>= s2 8) 15)
548	((eq s1 4) 4)
549	((eq s1 2) (if (eq s2 4) 2 15))
550	((eq s2 2) (if (memq s1 '(1 5)) 2 15))
551	((Math-integerp (nth 2 a))
552	(if (math-evenp (nth 2 a))
553	(if (memq s1 '(3 6 7)) 6 4)
554	s1))
555	((eq s1 6) (if (eq s2 4) 6 15))
556	(t 7))))
557	((eq (car a) '%)
558	(let ((s2 (math-possible-signs (nth 2 a))))
559	(cond ((>= s2 8) 7)
560	((eq s2 2) 2)
561	((memq s2 '(4 6)) 6)
562	((memq s2 '(1 3)) 3)
563	(t 7))))
564	((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
565	(= (length a) 2))
566	(let ((s1 (math-possible-signs (nth 1 a))))
567	(cond ((eq s1 2) 2)
568	((memq s1 '(1 4 5)) 4)
569	(t 6))))
570	((and (eq (car a) 'calcFunc-exp) (= (length a) 2))
571	(let ((s1 (math-possible-signs (nth 1 a))))
572	(if (>= s1 8)
573	15
574	(if (or (not origin) (math-negp origin))
575	4
576	(setq origin (math-sub (or origin 0) 1))
577	(if (Math-zerop origin) (setq origin nil))
578	s1))))
579	((or (and (memq (car a) '(calcFunc-ln calcFunc-log10))
580	(= (length a) 2))
581	(and (eq (car a) 'calcFunc-log)
582	(= (length a) 3)
583	(math-known-posp (nth 2 a))))
584	(if (math-known-nonnegp (nth 1 a))
585	(math-possible-signs (nth 1 a) 1)
586	15))
587	((and (eq (car a) 'calcFunc-sqrt) (= (length a) 2))
588	(let ((s1 (math-possible-signs (nth 1 a))))
589	(if (memq s1 '(2 4 6)) s1 15)))
590	((memq (car a) math-nonnegative-functions) 6)
591	((memq (car a) math-positive-functions) 4)
592	((memq (car a) math-real-functions) 7)
593	((memq (car a) math-real-scalar-functions) 7)
594	((and (memq (car a) math-real-if-arg-functions)
595	(= (length a) 2))
596	(if (math-known-realp (nth 1 a)) 7 15)))))
597	(cond (sign
598	(if origin
599	(+ (logand sign 8)
600	(if (Math-posp origin)
601	(if (memq sign '(1 2 3 8 9 10 11)) 1 7)
602	(if (memq sign '(2 4 6 8 10 12 14)) 4 7)))
603	sign))
604	((math-const-var a)
605	(cond ((eq (nth 2 a) 'var-pi)
606	(if origin
607	(math-possible-signs (math-pi) origin)
608	4))
609	((eq (nth 2 a) 'var-e)
610	(if origin
611	(math-possible-signs (math-e) origin)
612	4))
613	((eq (nth 2 a) 'var-inf) 4)
614	((eq (nth 2 a) 'var-uinf) 13)
615	((eq (nth 2 a) 'var-i) 8)
616	(t 15)))
617	(t
618	(math-setup-declarations)
619	(let ((decl (if (eq (car a) 'var)
620	(or (assq (nth 2 a) math-decls-cache)
621	math-decls-all)
622	(assq (car a) math-decls-cache))))
623	(if (and origin
624	(memq 'int (nth 1 decl))
625	(not (Math-num-integerp origin)))
626	5
627	(if (nth 2 decl)
628	(math-possible-signs (nth 2 decl) origin)
629	(if (memq 'real (nth 1 decl))
630	7
631	15))))))))))
632
633	(defun math-neg-signs (s1)
634	(if (>= s1 8)
635	(+ 8 (math-neg-signs (- s1 8)))
636	(+ (if (memq s1 '(1 3 5 7)) 4 0)
637	(if (memq s1 '(2 3 6 7)) 2 0)
638	(if (memq s1 '(4 5 6 7)) 1 0))))
639
640
641	;;; Try to prove that A is an integer.
642	(defun math-known-integerp (a)
643	(eq (math-possible-types a) 1))
644
645	(defun math-known-num-integerp (a)
646	(<= (math-possible-types a t) 3))
647
648	(defun math-known-imagp (a)
649	(= (math-possible-types a) 16))
650
651
652	;;; Find the possible types of A.
653	;;; Returns an integer with bits: 1 may be integer.
654	;;; 2 may be integer-valued float.
655	;;; 4 may be fraction.
656	;;; 8 may be non-integer-valued float.
657	;;; 16 may be imaginary.
658	;;; 32 may be non-real, non-imaginary.
659	;;; Real infinities count as integers for the purposes of this function.
660	(defun math-possible-types (a &optional num)
661	(cond ((Math-objectp a)
662	(cond ((Math-integerp a) (if num 3 1))
663	((Math-messy-integerp a) (if num 3 2))
664	((eq (car a) 'frac) (if num 12 4))
665	((eq (car a) 'float) (if num 12 8))
666	((eq (car a) 'intv)
667	(if (equal (nth 2 a) (nth 3 a))
668	(math-possible-types (nth 2 a))
669	15))
670	((eq (car a) 'sdev)
671	(if (math-known-realp (nth 1 a)) 15 63))
672	((eq (car a) 'cplx)
673	(if (math-zerop (nth 1 a)) 16 32))
674	((eq (car a) 'polar)
675	(if (or (Math-equal (nth 2 a) (math-quarter-circle nil))
676	(Math-equal (nth 2 a)
677	(math-neg (math-quarter-circle nil))))
678	16 48))
679	(t 63)))
680	((eq (car a) '/)
681	(let* ((t1 (math-possible-types (nth 1 a) num))
682	(t2 (math-possible-types (nth 2 a) num))
683	(t12 (logior t1 t2)))
684	(if (< t12 16)
685	(if (> (logand t12 10) 0)
686	10
687	(if (or (= t1 4) (= t2 4) calc-prefer-frac)
688	5
689	15))
690	(if (< t12 32)
691	(if (= t1 16)
692	(if (= t2 16) 15
693	(if (< t2 16) 16 31))
694	(if (= t2 16)
695	(if (< t1 16) 16 31)
696	31))
697	63))))
698	((memq (car a) '(+ - * %))
699	(let* ((t1 (math-possible-types (nth 1 a) num))
700	(t2 (math-possible-types (nth 2 a) num))
701	(t12 (logior t1 t2)))
702	(if (eq (car a) '%)
703	(setq t1 (logand t1 15) t2 (logand t2 15) t12 (logand t12 15)))
704	(if (< t12 16)
705	(let ((mask (if (<= t12 3)
706	1
707	(if (and (or (and (<= t1 3) (= (logand t2 3) 0))
708	(and (<= t2 3) (= (logand t1 3) 0)))
709	(memq (car a) '(+ -)))
710	4
711	5))))
712	(if num
713	(* mask 3)
714	(logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
715	mask 0)
716	(if (> (logand t12 10) 0)
717	(* mask 2) 0))))
718	(if (< t12 32)
719	(if (eq (car a) '*)
720	(if (= t1 16)
721	(if (= t2 16) 15
722	(if (< t2 16) 16 31))
723	(if (= t2 16)
724	(if (< t1 16) 16 31)
725	31))
726	(if (= t12 16) 16
727	(if (or (and (= t1 16) (< t2 16))
728	(and (= t2 16) (< t1 16))) 32 63)))
729	63))))
730	((eq (car a) 'neg)
731	(math-possible-types (nth 1 a)))
732	((eq (car a) '^)
733	(let* ((t1 (math-possible-types (nth 1 a) num))
734	(t2 (math-possible-types (nth 2 a) num))
735	(t12 (logior t1 t2)))
736	(if (and (<= t2 3) (math-known-nonnegp (nth 2 a)) (< t1 16))
737	(let ((mask (logior (if (> (logand t1 3) 0) 1 0)
738	(logand t1 4)
739	(if (> (logand t1 12) 0) 5 0))))
740	(if num
741	(* mask 3)
742	(logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
743	mask 0)
744	(if (> (logand t12 10) 0)
745	(* mask 2) 0))))
746	(if (and (math-known-nonnegp (nth 1 a))
747	(math-known-posp (nth 2 a)))
748	15
749	63))))
750	((eq (car a) 'calcFunc-sqrt)
751	(let ((t1 (math-possible-signs (nth 1 a))))
752	(logior (if (> (logand t1 2) 0) 3 0)
753	(if (> (logand t1 1) 0) 16 0)
754	(if (> (logand t1 4) 0) 15 0)
755	(if (> (logand t1 8) 0) 32 0))))
756	((eq (car a) 'vec)
757	(let ((types 0))
758	(while (and (setq a (cdr a)) (< types 63))
759	(setq types (logior types (math-possible-types (car a) t))))
760	types))
761	((or (memq (car a) math-integer-functions)
762	(and (memq (car a) math-rounding-functions)
763	(math-known-nonnegp (or (nth 2 a) 0))))
764	1)
765	((or (memq (car a) math-num-integer-functions)
766	(and (memq (car a) math-float-rounding-functions)
767	(math-known-nonnegp (or (nth 2 a) 0))))
768	2)
769	((eq (car a) 'calcFunc-frac)
770	5)
771	((