HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge from emacs-24; up to 2012-12-25T15:07:59Z!dmantipov@yandex.ru
[bpt/emacs.git] / lisp / calc / calc-alg.el
CommitLineData
a1506d29 1;;; calc-alg.el --- algebraic functions for Calc
3132f345 2
ab422c4d 3;; Copyright (C) 1990-1993, 2001-2013 Free Software Foundation, Inc.
3132f345
CW		 4
5;; Author: David Gillespie <daveg@synaptics.com>
e8fff8ed 6;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
136211a9
EZ		 7
8;; This file is part of GNU Emacs.
9
662c9c64 10;; GNU Emacs is free software: you can redistribute it and/or modify
7c671b23 11;; it under the terms of the GNU General Public License as published by
662c9c64
GM		 12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
7c671b23 14
136211a9 15;; GNU Emacs is distributed in the hope that it will be useful,
7c671b23
GM		 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
662c9c64 21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
136211a9 22
3132f345 23;;; Commentary:
136211a9 24
3132f345 25;;; Code:
136211a9
EZ		 26
27;; This file is autoloaded from calc-ext.el.
136211a9 28
41cf648d 29(require 'calc-ext)
136211a9
EZ		 30(require 'calc-macs)
31
136211a9
EZ		 32;;; Algebra commands.
33
34(defun calc-alg-evaluate (arg)
35 (interactive "p")
36 (calc-slow-wrapper
37 (calc-with-default-simplification
38 (let ((math-simplify-only nil))
39 (calc-modify-simplify-mode arg)
d3896480 40 (calc-enter-result 1 "dsmp" (calc-top 1))))))
136211a9
EZ		 41
42(defun calc-modify-simplify-mode (arg)
43 (if (= (math-abs arg) 2)
44 (setq calc-simplify-mode 'alg)
45 (if (>= (math-abs arg) 3)
46 (setq calc-simplify-mode 'ext)))
47 (if (< arg 0)
d3896480 48 (setq calc-simplify-mode (list calc-simplify-mode))))
136211a9
EZ		 49
50(defun calc-simplify ()
51 (interactive)
52 (calc-slow-wrapper
42110eaf
JB		 53 (let ((top (calc-top-n 1)))
54 (if (calc-is-inverse)
f3445fab 55 (setq top
42110eaf
JB		 56 (let ((calc-simplify-mode nil))
57 (math-normalize (math-trig-rewrite top)))))
58 (if (calc-is-hyperbolic)
f3445fab 59 (setq top
42110eaf
JB		 60 (let ((calc-simplify-mode nil))
61 (math-normalize (math-hyperbolic-trig-rewrite top)))))
62 (calc-with-default-simplification
63 (calc-enter-result 1 "simp" (math-simplify top))))))
136211a9
EZ		 64
65(defun calc-simplify-extended ()
66 (interactive)
67 (calc-slow-wrapper
68 (calc-with-default-simplification
d3896480 69 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
136211a9
EZ		 70
71(defun calc-expand-formula (arg)
72 (interactive "p")
73 (calc-slow-wrapper
74 (calc-with-default-simplification
75 (let ((math-simplify-only nil))
76 (calc-modify-simplify-mode arg)
a1506d29 77 (calc-enter-result 1 "expf"
136211a9
EZ		 78 (if (> arg 0)
79 (let ((math-expand-formulas t))
80 (calc-top-n 1))
81 (let ((top (calc-top-n 1)))
82 (or (math-expand-formula top)
d3896480 83 top))))))))
136211a9
EZ		 84
85(defun calc-factor (arg)
86 (interactive "P")
87 (calc-slow-wrapper
88 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
89 'calcFunc-factors 'calcFunc-factor)
d3896480 90 arg)))
136211a9
EZ		 91
92(defun calc-expand (n)
93 (interactive "P")
94 (calc-slow-wrapper
95 (calc-enter-result 1 "expa"
96 (append (list 'calcFunc-expand
97 (calc-top-n 1))
d3896480 98 (and n (list (prefix-numeric-value n)))))))
136211a9 99
93e7f889 100;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
c431c730
JB		 101(defun calcFunc-powerexpand (expr)
102 (math-normalize (math-map-tree 'math-powerexpand expr)))
93e7f889 103
c431c730 104(defun math-powerexpand (expr)
93e7f889 105 (if (eq (car-safe expr) '^)
c431c730
JB		 106 (let ((n (nth 2 expr)))
107 (cond ((and (integerp n)
108 (> n 0))
109 (let ((i 1)
110 (a (nth 1 expr))
111 (prod (nth 1 expr)))
112 (while (< i n)
113 (setq prod (math-mul prod a))
114 (setq i (1+ i)))
115 prod))
116 ((and (integerp n)
117 (< n 0))
118 (let ((i -1)
119 (a (math-pow (nth 1 expr) -1))
120 (prod (math-pow (nth 1 expr) -1)))
121 (while (> i n)
122 (setq prod (math-mul a prod))
123 (setq i (1- i)))
124 prod))
125 (t
126 expr)))
93e7f889
JB		 127 expr))
128
c431c730 129(defun calc-powerexpand ()
93e7f889
JB		 130 (interactive)
131 (calc-slow-wrapper
c431c730
JB		 132 (calc-enter-result 1 "pexp"
133 (calcFunc-powerexpand (calc-top-n 1)))))
93e7f889 134
136211a9
EZ		 135(defun calc-collect (&optional var)
136 (interactive "sCollect terms involving: ")
137 (calc-slow-wrapper
138 (if (or (equal var "") (equal var "$") (null var))
139 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
140 (calc-top-list-n 2)))
141 (let ((var (math-read-expr var)))
142 (if (eq (car-safe var) 'error)
143 (error "Bad format in expression: %s" (nth 1 var)))
144 (calc-enter-result 1 "clct" (list 'calcFunc-collect
145 (calc-top-n 1)
d3896480 146 var))))))
136211a9
EZ		 147
148(defun calc-apart (arg)
149 (interactive "P")
150 (calc-slow-wrapper
d3896480 151 (calc-unary-op "aprt" 'calcFunc-apart arg)))
136211a9
EZ		 152
153(defun calc-normalize-rat (arg)
154 (interactive "P")
155 (calc-slow-wrapper
d3896480 156 (calc-unary-op "nrat" 'calcFunc-nrat arg)))
136211a9
EZ		 157
158(defun calc-poly-gcd (arg)
159 (interactive "P")
160 (calc-slow-wrapper
d3896480 161 (calc-binary-op "pgcd" 'calcFunc-pgcd arg)))
136211a9 162
0c908945 163
136211a9
EZ		 164(defun calc-poly-div (arg)
165 (interactive "P")
166 (calc-slow-wrapper
0c908945
JB		 167 (let ((calc-poly-div-remainder nil))
168 (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
169 (if (and calc-poly-div-remainder (null arg))
170 (progn
171 (calc-clear-command-flag 'clear-message)
172 (calc-record calc-poly-div-remainder "prem")
173 (if (not (Math-zerop calc-poly-div-remainder))
174 (message "(Remainder was %s)"
175 (math-format-flat-expr calc-poly-div-remainder 0))
176 (message "(No remainder)")))))))
136211a9
EZ		 177
178(defun calc-poly-rem (arg)
179 (interactive "P")
180 (calc-slow-wrapper
d3896480 181 (calc-binary-op "prem" 'calcFunc-prem arg)))
136211a9
EZ		 182
183(defun calc-poly-div-rem (arg)
184 (interactive "P")
185 (calc-slow-wrapper
186 (if (calc-is-hyperbolic)
187 (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
d3896480 188 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))))
136211a9
EZ		 189
190(defun calc-substitute (&optional oldname newname)
191 (interactive "sSubstitute old: ")
192 (calc-slow-wrapper
193 (let (old new (num 1) expr)
194 (if (or (equal oldname "") (equal oldname "$") (null oldname))
195 (setq new (calc-top-n 1)
196 old (calc-top-n 2)
197 expr (calc-top-n 3)
198 num 3)
199 (or newname
200 (progn (calc-unread-command ?\C-a)
201 (setq newname (read-string (concat "Substitute old: "
202 oldname
203 ", new: ")
204 oldname))))
205 (if (or (equal newname "") (equal newname "$") (null newname))
206 (setq new (calc-top-n 1)
207 expr (calc-top-n 2)
208 num 2)
209 (setq new (if (stringp newname) (math-read-expr newname) newname))
210 (if (eq (car-safe new) 'error)
211 (error "Bad format in expression: %s" (nth 1 new)))
212 (setq expr (calc-top-n 1)))
213 (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
214 (if (eq (car-safe old) 'error)
215 (error "Bad format in expression: %s" (nth 1 old)))
216 (or (math-expr-contains expr old)
3132f345 217 (error "No occurrences found")))
d3896480 218 (calc-enter-result num "sbst" (math-expr-subst expr old new)))))
136211a9
EZ		 219
220
221(defun calc-has-rules (name)
222 (setq name (calc-var-value name))
223 (and (consp name)
224 (memq (car name) '(vec calcFunc-assign calcFunc-condition))
d3896480 225 name))
136211a9 226
0c908945
JB		 227;; math-eval-rules-cache and math-eval-rules-cache-other are
228;; declared in calc.el, but are used here by math-recompile-eval-rules.
229(defvar math-eval-rules-cache)
230(defvar math-eval-rules-cache-other)
231
136211a9
EZ		 232(defun math-recompile-eval-rules ()
233 (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
234 (math-compile-rewrites
235 '(var EvalRules var-EvalRules)))
236 math-eval-rules-cache-other (assq nil math-eval-rules-cache)
d3896480 237 math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)))
136211a9
EZ		 238
239
240;;; Try to expand a formula according to its definition.
241(defun math-expand-formula (expr)
242 (and (consp expr)
243 (symbolp (car expr))
244 (or (get (car expr) 'calc-user-defn)
245 (get (car expr) 'math-expandable))
246 (let ((res (let ((math-expand-formulas t))
247 (apply (car expr) (cdr expr)))))
248 (and (not (eq (car-safe res) (car expr)))
d3896480 249 res))))
136211a9
EZ		 250
251
252
253
254;;; True if A comes before B in a canonical ordering of expressions. [P X X]
255(defun math-beforep (a b) ; [Public]
256 (cond ((and (Math-realp a) (Math-realp b))
257 (let ((comp (math-compare a b)))
258 (or (eq comp -1)
259 (and (eq comp 0)
260 (not (equal a b))
261 (> (length (memq (car-safe a)
262 '(bigneg nil bigpos frac float)))
263 (length (memq (car-safe b)
264 '(bigneg nil bigpos frac float))))))))
265 ((equal b '(neg (var inf var-inf))) nil)
266 ((equal a '(neg (var inf var-inf))) t)
267 ((equal a '(var inf var-inf)) nil)
268 ((equal b '(var inf var-inf)) t)
269 ((Math-realp a)
270 (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
271 (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
272 t
273 nil)
274 t))
275 ((Math-realp b)
276 (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
277 (if (math-beforep (nth 2 a) b)
278 t
279 nil)
280 nil))
281 ((and (eq (car a) 'intv) (eq (car b) 'intv)
282 (math-intv-constp a) (math-intv-constp b))
283 (let ((comp (math-compare (nth 2 a) (nth 2 b))))
284 (cond ((eq comp -1) t)
285 ((eq comp 1) nil)
286 ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
287 ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
288 ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
289 ((eq comp 1) nil)
290 ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
291 (t nil))))
292 ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
293 (Math-objectp a))
294 ((eq (car a) 'var)
295 (if (eq (car b) 'var)
296 (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
297 (not (Math-numberp b))))
298 ((eq (car b) 'var) (Math-numberp a))
299 ((eq (car a) (car b))
300 (while (and (setq a (cdr a) b (cdr b)) a
301 (equal (car a) (car b))))
302 (and b
303 (or (null a)
304 (math-beforep (car a) (car b)))))
d3896480 305 (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))))
136211a9
EZ		 306
307
d3896480 308(defsubst math-simplify-extended (a)
136211a9 309 (let ((math-living-dangerously t))
d3896480
CW		 310 (math-simplify a)))
311
312(defalias 'calcFunc-esimplify 'math-simplify-extended)
136211a9 313
42110eaf
JB		 314;;; Rewrite the trig functions in a form easier to simplify.
315(defun math-trig-rewrite (fn)
316 "Rewrite trigonometric functions in terms of sines and cosines."
317 (cond
318 ((not (consp fn))
319 fn)
320 ((eq (car-safe fn) 'calcFunc-sec)
321 (list '/ 1 (cons 'calcFunc-cos (math-trig-rewrite (cdr fn)))))
322 ((eq (car-safe fn) 'calcFunc-csc)
323 (list '/ 1 (cons 'calcFunc-sin (math-trig-rewrite (cdr fn)))))
324 ((eq (car-safe fn) 'calcFunc-tan)
325 (let ((newfn (math-trig-rewrite (cdr fn))))
326 (list '/ (cons 'calcFunc-sin newfn)
327 (cons 'calcFunc-cos newfn))))
328 ((eq (car-safe fn) 'calcFunc-cot)
329 (let ((newfn (math-trig-rewrite (cdr fn))))
330 (list '/ (cons 'calcFunc-cos newfn)
331 (cons 'calcFunc-sin newfn))))
332 (t
333 (mapcar 'math-trig-rewrite fn))))
334
335(defun math-hyperbolic-trig-rewrite (fn)
336 "Rewrite hyperbolic functions in terms of sinhs and coshs."
337 (cond
338 ((not (consp fn))
339 fn)
340 ((eq (car-safe fn) 'calcFunc-sech)
341 (list '/ 1 (cons 'calcFunc-cosh (math-hyperbolic-trig-rewrite (cdr fn)))))
342 ((eq (car-safe fn) 'calcFunc-csch)
343 (list '/ 1 (cons 'calcFunc-sinh (math-hyperbolic-trig-rewrite (cdr fn)))))
344 ((eq (car-safe fn) 'calcFunc-tanh)
345 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
346 (list '/ (cons 'calcFunc-sinh newfn)
347 (cons 'calcFunc-cosh newfn))))
348 ((eq (car-safe fn) 'calcFunc-coth)
349 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
350 (list '/ (cons 'calcFunc-cosh newfn)
351 (cons 'calcFunc-sinh newfn))))
352 (t
353 (mapcar 'math-hyperbolic-trig-rewrite fn))))
354
f3445fab 355;; math-top-only is local to math-simplify, but is used by
0c908945
JB		 356;; math-simplify-step, which is called by math-simplify.
357(defvar math-top-only)
358
9052f9f0
JB		 359;; math-normalize-error is declared in calc.el.
360(defvar math-normalize-error)
136211a9
EZ		 361(defun math-simplify (top-expr)
362 (let ((math-simplifying t)
0c908945 363 (math-top-only (consp calc-simplify-mode))
136211a9
EZ		 364 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
365 '((var AlgSimpRules var-AlgSimpRules)))
366 (and math-living-dangerously
367 (calc-has-rules 'var-ExtSimpRules)
368 '((var ExtSimpRules var-ExtSimpRules)))
369 (and math-simplifying-units
370 (calc-has-rules 'var-UnitSimpRules)
371 '((var UnitSimpRules var-UnitSimpRules)))
372 (and math-integrating
373 (calc-has-rules 'var-IntegSimpRules)
374 '((var IntegSimpRules var-IntegSimpRules)))))
375 res)
0c908945 376 (if math-top-only
136211a9
EZ		 377 (let ((r simp-rules))
378 (setq res (math-simplify-step (math-normalize top-expr))
379 calc-simplify-mode '(nil)
380 top-expr (math-normalize res))
381 (while r
382 (setq top-expr (math-rewrite top-expr (car r)
383 '(neg (var inf var-inf)))
384 r (cdr r))))
385 (calc-with-default-simplification
386 (while (let ((r simp-rules))
387 (setq res (math-normalize top-expr))
9052f9f0
JB		 388 (if (not math-normalize-error)
389 (progn
390 (while r
391 (setq res (math-rewrite res (car r))
392 r (cdr r)))
393 (not (equal top-expr (setq res (math-simplify-step res)))))))
136211a9 394 (setq top-expr res)))))
d3896480
CW		 395 top-expr)
396
397(defalias 'calcFunc-simplify 'math-simplify)
136211a9
EZ		 398
399;;; The following has a "bug" in that if any recursive simplifications
400;;; occur only the first handler will be tried; this doesn't really
401;;; matter, since math-simplify-step is iterated to a fixed point anyway.
402(defun math-simplify-step (a)
403 (if (Math-primp a)
404 a
0c908945 405 (let ((aa (if (or math-top-only
136211a9
EZ		 406 (memq (car a) '(calcFunc-quote calcFunc-condition
407 calcFunc-evalto)))
408 a
409 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
410 (and (symbolp (car aa))
411 (let ((handler (get (car aa) 'math-simplify)))
412 (and handler
413 (while (and handler
414 (equal (setq aa (or (funcall (car handler) aa)
415 aa))
416 a))
417 (setq handler (cdr handler))))))
d3896480 418 aa)))
136211a9
EZ		 419
420
41cf648d 421(defmacro math-defsimplify (funcs &rest code)
4f91a816
SM		 422 (cons 'progn
423 (mapcar #'(lambda (func)
424 `(put ',func 'math-simplify
425 (nconc
426 (get ',func 'math-simplify)
427 (list
428 #'(lambda (math-simplify-expr) ,@code)))))
429 (if (symbolp funcs) (list funcs) funcs))))
41cf648d 430(put 'math-defsimplify 'lisp-indent-hook 1)
136211a9 431
0c908945
JB		 432;; The function created by math-defsimplify uses the variable
433;; math-simplify-expr, and so is used by functions in math-defsimplify
434(defvar math-simplify-expr)
435
136211a9
EZ		 436(math-defsimplify (+ -)
437 (math-simplify-plus))
438
439(defun math-simplify-plus ()
0c908945
JB		 440 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
441 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
442 (not (Math-numberp (nth 2 math-simplify-expr))))
443 (let ((x (nth 2 math-simplify-expr))
444 (op (car math-simplify-expr)))
445 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
446 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
447 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
448 (setcar (nth 1 math-simplify-expr) op)))
449 ((and (eq (car math-simplify-expr) '+)
450 (Math-numberp (nth 1 math-simplify-expr))
451 (not (Math-numberp (nth 2 math-simplify-expr))))
452 (let ((x (nth 2 math-simplify-expr)))
453 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
454 (setcar (cdr math-simplify-expr) x))))
455 (let ((aa math-simplify-expr)
136211a9
EZ		 456 aaa temp)
457 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
0c908945 458 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
f3445fab 459 (eq (car aaa) '-)
0c908945 460 (eq (car math-simplify-expr) '-) t))
136211a9 461 (progn
0c908945
JB		 462 (setcar (cdr (cdr math-simplify-expr)) temp)
463 (setcar math-simplify-expr '+)
136211a9
EZ		 464 (setcar (cdr (cdr aaa)) 0)))
465 (setq aa (nth 1 aa)))
0c908945
JB		 466 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
467 nil (eq (car math-simplify-expr) '-) t))
136211a9 468 (progn
0c908945
JB		 469 (setcar (cdr (cdr math-simplify-expr)) temp)
470 (setcar math-simplify-expr '+)
136211a9 471 (setcar (cdr aa) 0)))
0c908945 472 math-simplify-expr))
136211a9
EZ		 473
474(math-defsimplify *
475 (math-simplify-times))
476
477(defun math-simplify-times ()
0c908945
JB		 478 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
479 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
480 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
481 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
482 (let ((x (nth 1 math-simplify-expr)))
483 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
484 (setcar (cdr (nth 2 math-simplify-expr)) x)))
485 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
486 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
487 (math-known-scalarp (nth 2 math-simplify-expr) t))
488 (let ((x (nth 2 math-simplify-expr)))
489 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
490 (setcar (cdr math-simplify-expr) x))))
491 (let ((aa math-simplify-expr)
136211a9 492 aaa temp
0c908945
JB		 493 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
494 (if (and (Math-ratp (nth 1 math-simplify-expr))
495 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
136211a9 496 (progn
0c908945
JB		 497 (setcar (cdr (cdr math-simplify-expr))
498 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
499 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
136211a9
EZ		 500 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
501 safe)
f3445fab 502 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
0c908945 503 (nth 1 aaa) nil nil t))
136211a9 504 (progn
0c908945 505 (setcar (cdr math-simplify-expr) temp)
136211a9
EZ		 506 (setcar (cdr aaa) 1)))
507 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
508 aa (nth 2 aa)))
0c908945 509 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
136211a9
EZ		 510 safe)
511 (progn
0c908945 512 (setcar (cdr math-simplify-expr) temp)
136211a9 513 (setcar (cdr (cdr aa)) 1)))
0c908945
JB		 514 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
515 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
f3445fab 516 (math-div (math-mul (nth 2 math-simplify-expr)
0c908945
JB		 517 (nth 1 (nth 1 math-simplify-expr)))
518 (nth 2 (nth 1 math-simplify-expr)))
519 math-simplify-expr)))
136211a9
EZ		 520
521(math-defsimplify /
522 (math-simplify-divide))
523
524(defun math-simplify-divide ()
0c908945 525 (let ((np (cdr math-simplify-expr))
136211a9 526 (nover nil)
f3445fab 527 (nn (and (or (eq (car math-simplify-expr) '/)
0c908945
JB		 528 (not (Math-realp (nth 2 math-simplify-expr))))
529 (math-common-constant-factor (nth 2 math-simplify-expr))))
136211a9
EZ		 530 n op)
531 (if nn
532 (progn
f3445fab 533 (setq n (and (or (eq (car math-simplify-expr) '/)
0c908945
JB		 534 (not (Math-realp (nth 1 math-simplify-expr))))
535 (math-common-constant-factor (nth 1 math-simplify-expr))))
136211a9 536 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
3cc5a3a8
JB		 537 (unless (and (eq (car-safe math-simplify-expr) 'calcFunc-eq)
538 (eq (car-safe (nth 1 math-simplify-expr)) 'var)
539 (not (math-expr-contains (nth 2 math-simplify-expr)
540 (nth 1 math-simplify-expr))))
f3445fab 541 (setcar (cdr math-simplify-expr)
0c908945
JB		 542 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
543 (setcar (cdr (cdr math-simplify-expr))
544 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
136211a9 545 (if (and (math-negp nn)
0c908945
JB		 546 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
547 (setcar math-simplify-expr (nth 1 op))))
136211a9
EZ		 548 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
549 (progn
0c908945
JB		 550 (setcar (cdr math-simplify-expr)
551 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
552 (setcar (cdr (cdr math-simplify-expr))
553 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
136211a9 554 (if (and (math-negp n)
f3445fab 555 (setq op (assq (car math-simplify-expr)
0c908945
JB		 556 calc-tweak-eqn-table)))
557 (setcar math-simplify-expr (nth 1 op))))))))
136211a9 558 (if (and (eq (car-safe (car np)) '/)
0c908945 559 (math-known-scalarp (nth 2 math-simplify-expr) t))
136211a9 560 (progn
0c908945 561 (setq np (cdr (nth 1 math-simplify-expr)))
136211a9
EZ		 562 (while (eq (car-safe (setq n (car np))) '*)
563 (and (math-known-scalarp (nth 2 n) t)
0c908945 564 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
136211a9 565 (setq np (cdr (cdr n))))
0c908945 566 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
136211a9 567 (setq nover t
0c908945 568 np (cdr (cdr (nth 1 math-simplify-expr))))))
136211a9
EZ		 569 (while (eq (car-safe (setq n (car np))) '*)
570 (and (math-known-scalarp (nth 2 n) t)
0c908945 571 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
136211a9 572 (setq np (cdr (cdr n))))
0c908945
JB		 573 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
574 math-simplify-expr))
575
576;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
577;; are local variables for math-simplify-divisor, but are used by
578;; math-simplify-one-divisor.
579(defvar math-simplify-divisor-nover)
580(defvar math-simplify-divisor-dover)
136211a9 581
f3445fab 582(defun math-simplify-divisor (np dp math-simplify-divisor-nover
0c908945 583 math-simplify-divisor-dover)
136211a9 584 (cond ((eq (car-safe (car dp)) '/)
f3445fab
GM		 585 (math-simplify-divisor np (cdr (car dp))
586 math-simplify-divisor-nover
0c908945 587 math-simplify-divisor-dover)
136211a9
EZ		 588 (and (math-known-scalarp (nth 1 (car dp)) t)
589 (math-simplify-divisor np (cdr (cdr (car dp)))
f3445fab 590 math-simplify-divisor-nover
0c908945
JB		 591 (not math-simplify-divisor-dover))))
592 ((or (or (eq (car math-simplify-expr) '/)
136211a9
EZ		 593 (let ((signs (math-possible-signs (car np))))
594 (or (memq signs '(1 4))
0c908945 595 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
136211a9
EZ		 596 (eq signs 5))
597 math-living-dangerously)))
598 (math-numberp (car np)))
358c90f4 599 (let (d
f3445fab 600 (safe t)
358c90f4 601 (scalar (math-known-scalarp (car np))))
136211a9
EZ		 602 (while (and (eq (car-safe (setq d (car dp))) '*)
603 safe)
604 (math-simplify-one-divisor np (cdr d))
605 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
606 dp (cdr (cdr d))))
607 (if safe
d3896480 608 (math-simplify-one-divisor np dp))))))
136211a9
EZ		 609
610(defun math-simplify-one-divisor (np dp)
f3445fab 611 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
0c908945
JB		 612 math-simplify-divisor-dover t))
613 op)
f3445fab 614 (if temp
0c908945
JB		 615 (progn
616 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
617 (math-known-negp (car dp))
618 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
619 (setcar math-simplify-expr (nth 1 op)))
620 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
621 (setcar dp 1))
f3445fab 622 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
0c908945
JB		 623 (eq (car math-simplify-expr) '/)
624 (eq (car-safe (car dp)) 'calcFunc-sqrt)
625 (Math-integerp (nth 1 (car dp)))
626 (progn
627 (setcar np (math-mul (car np)
628 (list 'calcFunc-sqrt (nth 1 (car dp)))))
629 (setcar dp (nth 1 (car dp))))))))
136211a9
EZ		 630
631(defun math-common-constant-factor (expr)
632 (if (Math-realp expr)
633 (if (Math-ratp expr)
634 (and (not (memq expr '(0 1 -1)))
635 (math-abs expr))
636 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
637 (math-common-constant-factor expr)))
638 (if (memq (car expr) '(+ - cplx sdev))
639 (let ((f1 (math-common-constant-factor (nth 1 expr)))
640 (f2 (math-common-constant-factor (nth 2 expr))))
641 (and f1 f2
642 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
643 f1))
644 (if (memq (car expr) '(* polar))
645 (math-common-constant-factor (nth 1 expr))
646 (if (eq (car expr) '/)
647 (or (math-common-constant-factor (nth 1 expr))
648 (and (Math-integerp (nth 2 expr))
d3896480 649 (list 'frac 1 (math-abs (nth 2 expr))))))))))
136211a9
EZ		 650
651(defun math-cancel-common-factor (expr val)
652 (if (memq (car-safe expr) '(+ - cplx sdev))
653 (progn
654 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
655 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
656 expr)
657 (if (eq (car-safe expr) '*)
658 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
d3896480 659 (math-div expr val))))
136211a9
EZ		 660
661(defun math-frac-gcd (a b)
662 (if (Math-zerop a)
663 b
664 (if (Math-zerop b)
665 a
666 (if (and (Math-integerp a)
667 (Math-integerp b))
668 (math-gcd a b)
669 (and (Math-integerp a) (setq a (list 'frac a 1)))
670 (and (Math-integerp b) (setq b (list 'frac b 1)))
671 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
d3896480 672 (math-gcd (nth 2 a) (nth 2 b)))))))
136211a9
EZ		 673
674(math-defsimplify %
675 (math-simplify-mod))
676
677(defun math-simplify-mod ()
0c908945
JB		 678 (and (Math-realp (nth 2 math-simplify-expr))
679 (Math-posp (nth 2 math-simplify-expr))
680 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
136211a9
EZ		 681 t1 t2 t3)
682 (or (and lin
683 (or (math-negp (car lin))
0c908945 684 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
136211a9
EZ		 685 (list '%
686 (list '+
687 (math-mul (nth 1 lin) (nth 2 lin))
0c908945
JB		 688 (math-mod (car lin) (nth 2 math-simplify-expr)))
689 (nth 2 math-simplify-expr)))
136211a9
EZ		 690 (and lin
691 (not (math-equal-int (nth 1 lin) 1))
692 (math-num-integerp (nth 1 lin))
0c908945
JB		 693 (math-num-integerp (nth 2 math-simplify-expr))
694 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
136211a9
EZ		 695 (not (math-equal-int t1 1))
696 (list '*
697 t1
698 (list '%
699 (list '+
700 (math-mul (math-div (nth 1 lin) t1)
701 (nth 2 lin))
702 (let ((calc-prefer-frac t))
703 (math-div (car lin) t1)))
0c908945
JB		 704 (math-div (nth 2 math-simplify-expr) t1))))
705 (and (math-equal-int (nth 2 math-simplify-expr) 1)
136211a9
EZ		 706 (math-known-integerp (if lin
707 (math-mul (nth 1 lin) (nth 2 lin))
0c908945 708 (nth 1 math-simplify-expr)))
d3896480 709 (if lin (math-mod (car lin) 1) 0))))))
136211a9
EZ		 710
711(math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
712 calcFunc-gt calcFunc-leq calcFunc-geq)
0c908945 713 (if (= (length math-simplify-expr) 3)
136211a9
EZ		 714 (math-simplify-ineq)))
715
716(defun math-simplify-ineq ()
0c908945 717 (let ((np (cdr math-simplify-expr))
136211a9
EZ		 718 n)
719 (while (memq (car-safe (setq n (car np))) '(+ -))
0c908945 720 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
136211a9
EZ		 721 (eq (car n) '-) nil)
722 (setq np (cdr n)))
f3445fab 723 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
0c908945 724 (eq np (cdr math-simplify-expr)))
136211a9 725 (math-simplify-divide)
0c908945
JB		 726 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
727 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
136211a9
EZ		 728 (or (and (eq signs 2) 1)
729 (and (memq signs '(1 4 5)) 0)))
0c908945 730 ((eq (car math-simplify-expr) 'calcFunc-neq)
136211a9
EZ		 731 (or (and (eq signs 2) 0)
732 (and (memq signs '(1 4 5)) 1)))
0c908945 733 ((eq (car math-simplify-expr) 'calcFunc-lt)
136211a9
EZ		 734 (or (and (eq signs 1) 1)
735 (and (memq signs '(2 4 6)) 0)))
0c908945 736 ((eq (car math-simplify-expr) 'calcFunc-gt)
136211a9
EZ		 737 (or (and (eq signs 4) 1)
738 (and (memq signs '(1 2 3)) 0)))
0c908945 739 ((eq (car math-simplify-expr) 'calcFunc-leq)
136211a9
EZ		 740 (or (and (eq signs 4) 0)
741 (and (memq signs '(1 2 3)) 1)))
0c908945 742 ((eq (car math-simplify-expr) 'calcFunc-geq)
136211a9
EZ		 743 (or (and (eq signs 1) 0)
744 (and (memq signs '(2 4 6)) 1))))
0c908945 745 math-simplify-expr))))
136211a9
EZ		 746
747(defun math-simplify-add-term (np dp minus lplain)
748 (or (math-vectorp (car np))
749 (let ((rplain t)
750 n d dd temp)
751 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
752 (setq rplain nil)
753 (if (setq temp (math-combine-sum n (nth 2 d)
754 minus (eq (car d) '+) t))
755 (if (or lplain (eq (math-looks-negp temp) minus))
756 (progn
757 (setcar np (setq n (if minus (math-neg temp) temp)))
758 (setcar (cdr (cdr d)) 0))
759 (progn
760 (setcar np 0)
761 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
762 (math-neg temp)
763 temp))))))
764 (setq dp (cdr d)))
765 (if (setq temp (math-combine-sum n d minus t t))
766 (if (or lplain
767 (and (not rplain)
768 (eq (math-looks-negp temp) minus)))
769 (progn
770 (setcar np (setq n (if minus (math-neg temp) temp)))
771 (setcar dp 0))
772 (progn
773 (setcar np 0)
d3896480 774 (setcar dp (setq n (math-neg temp)))))))))
136211a9
EZ		 775
776(math-defsimplify calcFunc-sin
0c908945
JB		 777 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
778 (nth 1 (nth 1 math-simplify-expr)))
779 (and (math-looks-negp (nth 1 math-simplify-expr))
780 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
136211a9 781 (and (eq calc-angle-mode 'rad)
0c908945 782 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 783 (and n
784 (math-known-sin (car n) (nth 1 n) 120 0))))
785 (and (eq calc-angle-mode 'deg)
0c908945 786 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 787 (and n
788 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
0c908945 789 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 790 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
0c908945
JB		 791 (nth 1 (nth 1 math-simplify-expr))))))
792 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
793 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 794 (list 'calcFunc-sqrt
f3445fab 795 (math-add 1 (math-sqr
0c908945
JB		 796 (nth 1 (nth 1 math-simplify-expr)))))))
797 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 798 (and m (integerp (car m))
799 (let ((n (car m)) (a (nth 1 m)))
800 (list '+
801 (list '* (list 'calcFunc-sin (list '* (1- n) a))
802 (list 'calcFunc-cos a))
803 (list '* (list 'calcFunc-cos (list '* (1- n) a))
d3896480 804 (list 'calcFunc-sin a))))))))
136211a9
EZ		 805
806(math-defsimplify calcFunc-cos
0c908945
JB		 807 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
808 (nth 1 (nth 1 math-simplify-expr)))
809 (and (math-looks-negp (nth 1 math-simplify-expr))
810 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
136211a9 811 (and (eq calc-angle-mode 'rad)
0c908945 812 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 813 (and n
814 (math-known-sin (car n) (nth 1 n) 120 300))))
815 (and (eq calc-angle-mode 'deg)
0c908945 816 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 817 (and n
818 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
0c908945 819 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
f3445fab 820 (list 'calcFunc-sqrt
0c908945
JB		 821 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
822 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
136211a9
EZ		 823 (math-div 1
824 (list 'calcFunc-sqrt
f3445fab 825 (math-add 1
0c908945
JB		 826 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
827 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 828 (and m (integerp (car m))
829 (let ((n (car m)) (a (nth 1 m)))
830 (list '-
831 (list '* (list 'calcFunc-cos (list '* (1- n) a))
832 (list 'calcFunc-cos a))
833 (list '* (list 'calcFunc-sin (list '* (1- n) a))
d3896480 834 (list 'calcFunc-sin a))))))))
136211a9 835
6a5412e4
JB		 836(math-defsimplify calcFunc-sec
837 (or (and (math-looks-negp (nth 1 math-simplify-expr))
838 (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
839 (and (eq calc-angle-mode 'rad)
840 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
841 (and n
842 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
843 (and (eq calc-angle-mode 'deg)
844 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
845 (and n
846 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
847 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
f3445fab 848 (math-div
6a5412e4 849 1
f3445fab 850 (list 'calcFunc-sqrt
6a5412e4
JB		 851 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
852 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 853 (math-div
6a5412e4
JB		 854 1
855 (nth 1 (nth 1 math-simplify-expr))))
856 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
857 (list 'calcFunc-sqrt
f3445fab 858 (math-add 1
6a5412e4
JB		 859 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
860
861(math-defsimplify calcFunc-csc
862 (or (and (math-looks-negp (nth 1 math-simplify-expr))
863 (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
864 (and (eq calc-angle-mode 'rad)
865 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
866 (and n
867 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
868 (and (eq calc-angle-mode 'deg)
869 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
870 (and n
871 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
872 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
873 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
874 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 875 (math-div
6a5412e4 876 1
f3445fab 877 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
6a5412e4
JB		 878 (nth 1 (nth 1 math-simplify-expr)))))))
879 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
880 (math-div (list 'calcFunc-sqrt
f3445fab 881 (math-add 1 (math-sqr
6a5412e4
JB		 882 (nth 1 (nth 1 math-simplify-expr)))))
883 (nth 1 (nth 1 math-simplify-expr))))))
884
136211a9
EZ		 885(defun math-should-expand-trig (x &optional hyperbolic)
886 (let ((m (math-is-multiple x)))
887 (and math-living-dangerously
888 m (or (and (integerp (car m)) (> (car m) 1))
889 (equal (car m) '(frac 1 2)))
890 (or math-integrating
891 (memq (car-safe (nth 1 m))
892 (if hyperbolic
893 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
894 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
895 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
896 (eq hyperbolic 'exp)))
d3896480 897 m)))
136211a9
EZ		 898
899(defun math-known-sin (plus n mul off)
900 (setq n (math-mul n mul))
901 (and (math-num-integerp n)
902 (setq n (math-mod (math-add (math-trunc n) off) 240))
903 (if (>= n 120)
904 (and (setq n (math-known-sin plus (- n 120) 1 0))
905 (math-neg n))
906 (if (> n 60)
907 (setq n (- 120 n)))
908 (if (math-zerop plus)
909 (and (or calc-symbolic-mode
910 (memq n '(0 20 60)))
911 (cdr (assq n
912 '( (0 . 0)
913 (10 . (/ (calcFunc-sqrt
914 (- 2 (calcFunc-sqrt 3))) 2))
915 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
916 (15 . (/ (calcFunc-sqrt
917 (- 2 (calcFunc-sqrt 2))) 2))
918 (20 . (/ 1 2))
919 (24 . (* (^ (/ 1 2) (/ 3 2))
920 (calcFunc-sqrt
921 (- 5 (calcFunc-sqrt 5)))))
922 (30 . (/ (calcFunc-sqrt 2) 2))
923 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
924 (40 . (/ (calcFunc-sqrt 3) 2))
925 (45 . (/ (calcFunc-sqrt
926 (+ 2 (calcFunc-sqrt 2))) 2))
927 (48 . (* (^ (/ 1 2) (/ 3 2))
928 (calcFunc-sqrt
929 (+ 5 (calcFunc-sqrt 5)))))
930 (50 . (/ (calcFunc-sqrt
931 (+ 2 (calcFunc-sqrt 3))) 2))
932 (60 . 1)))))
933 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
934 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
d3896480 935 (t nil))))))
136211a9
EZ		 936
937(math-defsimplify calcFunc-tan
0c908945
JB		 938 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
939 (nth 1 (nth 1 math-simplify-expr)))
940 (and (math-looks-negp (nth 1 math-simplify-expr))
941 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
136211a9 942 (and (eq calc-angle-mode 'rad)
0c908945 943 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 944 (and n
945 (math-known-tan (car n) (nth 1 n) 120))))
946 (and (eq calc-angle-mode 'deg)
0c908945 947 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 948 (and n
949 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
0c908945
JB		 950 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
951 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 952 (list 'calcFunc-sqrt
0c908945
JB		 953 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
954 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
136211a9 955 (math-div (list 'calcFunc-sqrt
0c908945
JB		 956 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
957 (nth 1 (nth 1 math-simplify-expr))))
958 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 959 (and m
960 (if (equal (car m) '(frac 1 2))
961 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
962 (list 'calcFunc-sin (nth 1 m)))
0c908945
JB		 963 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
964 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
136211a9 965
6a5412e4
JB		 966(math-defsimplify calcFunc-cot
967 (or (and (math-looks-negp (nth 1 math-simplify-expr))
968 (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
969 (and (eq calc-angle-mode 'rad)
970 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
971 (and n
972 (math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
973 (and (eq calc-angle-mode 'deg)
974 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
975 (and n
976 (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
977 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
978 (math-div (list 'calcFunc-sqrt
979 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
980 (nth 1 (nth 1 math-simplify-expr))))
981 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
982 (math-div (nth 1 (nth 1 math-simplify-expr))
983 (list 'calcFunc-sqrt
984 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
985 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
986 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
987
136211a9
EZ		 988(defun math-known-tan (plus n mul)
989 (setq n (math-mul n mul))
990 (and (math-num-integerp n)
991 (setq n (math-mod (math-trunc n) 120))
992 (if (> n 60)
993 (and (setq n (math-known-tan plus (- 120 n) 1))
994 (math-neg n))
995 (if (math-zerop plus)
996 (and (or calc-symbolic-mode
997 (memq n '(0 30 60)))
998 (cdr (assq n '( (0 . 0)
999 (10 . (- 2 (calcFunc-sqrt 3)))
1000 (12 . (calcFunc-sqrt
1001 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1002 (15 . (- (calcFunc-sqrt 2) 1))
1003 (20 . (/ (calcFunc-sqrt 3) 3))
1004 (24 . (calcFunc-sqrt
1005 (- 5 (* 2 (calcFunc-sqrt 5)))))
1006 (30 . 1)
1007 (36 . (calcFunc-sqrt
1008 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1009 (40 . (calcFunc-sqrt 3))
1010 (45 . (+ (calcFunc-sqrt 2) 1))
1011 (48 . (calcFunc-sqrt
1012 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1013 (50 . (+ 2 (calcFunc-sqrt 3)))
1014 (60 . (var uinf var-uinf))))))
1015 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
1016 ((eq n 60) (math-normalize (list '/ -1
1017 (list 'calcFunc-tan plus))))
d3896480 1018 (t nil))))))
136211a9
EZ		 1019
1020(math-defsimplify calcFunc-sinh
0c908945
JB		 1021 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1022 (nth 1 (nth 1 math-simplify-expr)))
1023 (and (math-looks-negp (nth 1 math-simplify-expr))
1024 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
1025 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
136211a9 1026 math-living-dangerously
f3445fab 1027 (list 'calcFunc-sqrt
0c908945
JB		 1028 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1029 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
136211a9 1030 math-living-dangerously
0c908945 1031 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 1032 (list 'calcFunc-sqrt
0c908945
JB		 1033 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1034 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1035 (and m (integerp (car m))
1036 (let ((n (car m)) (a (nth 1 m)))
1037 (if (> n 1)
1038 (list '+
1039 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1040 (list 'calcFunc-cosh a))
1041 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
d3896480 1042 (list 'calcFunc-sinh a)))))))))
136211a9
EZ		 1043
1044(math-defsimplify calcFunc-cosh
0c908945
JB		 1045 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1046 (nth 1 (nth 1 math-simplify-expr)))
1047 (and (math-looks-negp (nth 1 math-simplify-expr))
1048 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
1049 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
136211a9 1050 math-living-dangerously
f3445fab 1051 (list 'calcFunc-sqrt
0c908945
JB		 1052 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1053 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
136211a9
EZ		 1054 math-living-dangerously
1055 (math-div 1
1056 (list 'calcFunc-sqrt
0c908945
JB		 1057 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1058 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1059 (and m (integerp (car m))
1060 (let ((n (car m)) (a (nth 1 m)))
1061 (if (> n 1)
1062 (list '+
1063 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1064 (list 'calcFunc-cosh a))
1065 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
d3896480 1066 (list 'calcFunc-sinh a)))))))))
136211a9
EZ		 1067
1068(math-defsimplify calcFunc-tanh
0c908945
JB		 1069 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1070 (nth 1 (nth 1 math-simplify-expr)))
1071 (and (math-looks-negp (nth 1 math-simplify-expr))
1072 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
1073 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
136211a9 1074 math-living-dangerously
0c908945 1075 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 1076 (list 'calcFunc-sqrt
0c908945
JB		 1077 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1078 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
136211a9
EZ		 1079 math-living-dangerously
1080 (math-div (list 'calcFunc-sqrt
0c908945
JB		 1081 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1082 (nth 1 (nth 1 math-simplify-expr))))
1083 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1084 (and m
1085 (if (equal (car m) '(frac 1 2))
1086 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
1087 (list 'calcFunc-sinh (nth 1 m)))
0c908945
JB		 1088 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
1089 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
136211a9 1090
6a5412e4
JB		 1091(math-defsimplify calcFunc-sech
1092 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1093 (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
1094 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1095 math-living-dangerously
f3445fab 1096 (math-div
6a5412e4 1097 1
f3445fab 1098 (list 'calcFunc-sqrt
6a5412e4
JB		 1099 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1100 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1101 math-living-dangerously
1102 (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
1103 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1104 math-living-dangerously
1105 (list 'calcFunc-sqrt
1106 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
1107
1108(math-defsimplify calcFunc-csch
1109 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1110 (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
1111 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1112 math-living-dangerously
1113 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
1114 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1115 math-living-dangerously
f3445fab 1116 (math-div
6a5412e4 1117 1
f3445fab 1118 (list 'calcFunc-sqrt
6a5412e4
JB		 1119 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1120 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1121 math-living-dangerously
1122 (math-div (list 'calcFunc-sqrt
1123 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
1124 (nth 1 (nth 1 math-simplify-expr))))))
1125
1126(math-defsimplify calcFunc-coth
1127 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1128 (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
1129 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1130 math-living-dangerously
1131 (math-div (list 'calcFunc-sqrt
1132 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1133 (nth 1 (nth 1 math-simplify-expr))))
1134 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1135 math-living-dangerously
1136 (math-div (nth 1 (nth 1 math-simplify-expr))
1137 (list 'calcFunc-sqrt
1138 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1139 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1140 math-living-dangerously
1141 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
1142
136211a9 1143(math-defsimplify calcFunc-arcsin
0c908945
JB		 1144 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1145 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
1146 (and (eq (nth 1 math-simplify-expr) 1)
136211a9 1147 (math-quarter-circle t))
0c908945 1148 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
136211a9
EZ		 1149 (math-div (math-half-circle t) 6))
1150 (and math-living-dangerously
0c908945
JB		 1151 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1152 (nth 1 (nth 1 math-simplify-expr)))
136211a9 1153 (and math-living-dangerously
0c908945 1154 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
136211a9 1155 (math-sub (math-quarter-circle t)
0c908945 1156 (nth 1 (nth 1 math-simplify-expr))))))
136211a9
EZ		 1157
1158(math-defsimplify calcFunc-arccos
0c908945 1159 (or (and (eq (nth 1 math-simplify-expr) 0)
136211a9 1160 (math-quarter-circle t))
0c908945 1161 (and (eq (nth 1 math-simplify-expr) -1)
136211a9 1162 (math-half-circle t))
0c908945 1163 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
136211a9 1164 (math-div (math-half-circle t) 3))
0c908945 1165 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
136211a9
EZ		 1166 (math-div (math-mul (math-half-circle t) 2) 3))
1167 (and math-living-dangerously
0c908945
JB		 1168 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1169 (nth 1 (nth 1 math-simplify-expr)))
136211a9 1170 (and math-living-dangerously
0c908945 1171 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
136211a9 1172 (math-sub (math-quarter-circle t)
0c908945 1173 (nth 1 (nth 1 math-simplify-expr))))))
136211a9
EZ		 1174
1175(math-defsimplify calcFunc-arctan
0c908945
JB		 1176 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1177 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
1178 (and (eq (nth 1 math-simplify-expr) 1)
136211a9
EZ		 1179 (math-div (math-half-circle t) 4))
1180 (and math-living-dangerously
0c908945
JB		 1181 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
1182 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1183
1184(math-defsimplify calcFunc-arcsinh
0c908945
JB		 1185 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1186 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
1187 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
136211a9 1188 (or math-living-dangerously
0c908945
JB		 1189 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1190 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1191
1192(math-defsimplify calcFunc-arccosh
0c908945 1193 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
136211a9 1194 (or math-living-dangerously
0c908945
JB		 1195 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1196 (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1197
1198(math-defsimplify calcFunc-arctanh
0c908945
JB		 1199 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1200 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
1201 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
136211a9 1202 (or math-living-dangerously
0c908945
JB		 1203 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1204 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1205
1206(math-defsimplify calcFunc-sqrt
d3896480 1207 (math-simplify-sqrt))
136211a9
EZ		 1208
1209(defun math-simplify-sqrt ()
0c908945 1210 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
f3445fab 1211 (math-div (list 'calcFunc-sqrt
0c908945
JB		 1212 (math-mul (nth 1 (nth 1 math-simplify-expr))
1213 (nth 2 (nth 1 math-simplify-expr))))
1214 (nth 2 (nth 1 math-simplify-expr))))
1215 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1216 (math-squared-factor (nth 1 math-simplify-expr))
1217 (math-common-constant-factor (nth 1 math-simplify-expr)))))
136211a9
EZ		 1218 (and fac (not (eq fac 1))
1219 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1220 (math-normalize
1221 (list 'calcFunc-sqrt
f3445fab 1222 (math-cancel-common-factor
0c908945 1223 (nth 1 math-simplify-expr) fac))))))
136211a9 1224 (and math-living-dangerously
0c908945
JB		 1225 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1226 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1227 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1228 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1229 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1230 'calcFunc-sin)
1231 (list 'calcFunc-cos
0c908945
JB		 1232 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1233 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1234 'calcFunc-cos)
1235 (list 'calcFunc-sin
f3445fab 1236 (nth 1 (nth 1 (nth 2
0c908945
JB		 1237 (nth 1 math-simplify-expr))))))))
1238 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1239 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1240 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1241 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1242 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1243 'calcFunc-cosh)
1244 (list 'calcFunc-sinh
0c908945
JB		 1245 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1246 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1247 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1248 (b (nth 2 (nth 1 math-simplify-expr))))
136211a9 1249 (and (or (and (math-equal-int a 1)
0c908945 1250 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1251 (math-equal-int b 1))
1252 (eq (car-safe a) '^)
1253 (math-equal-int (nth 2 a) 2)
1254 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1255 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
6a5412e4
JB		 1256 (and (eq (car-safe (nth 1 a)) 'calcFunc-csch)
1257 (list 'calcFunc-coth (nth 1 (nth 1 a))))
136211a9
EZ		 1258 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1259 (list '/ 1 (list 'calcFunc-cos
6a5412e4
JB		 1260 (nth 1 (nth 1 a)))))
1261 (and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
1262 (list '/ 1 (list 'calcFunc-sin
136211a9 1263 (nth 1 (nth 1 a)))))))))
0c908945 1264 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
136211a9 1265 (list '^
0c908945
JB		 1266 (nth 1 (nth 1 math-simplify-expr))
1267 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1268 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1269 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1270 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1271 (list (car (nth 1 math-simplify-expr))
1272 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1273 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1274 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1275 (not (math-any-floats (nth 1 math-simplify-expr)))
136211a9 1276 (let ((f (calcFunc-factors (calcFunc-expand
0c908945 1277 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1278 (and (math-vectorp f)
1279 (or (> (length f) 2)
1280 (> (nth 2 (nth 1 f)) 1))
1281 (let ((out 1) (rest 1) (sums 1) fac pow)
1282 (while (setq f (cdr f))
1283 (setq fac (nth 1 (car f))
1284 pow (nth 2 (car f)))
1285 (if (> pow 1)
1286 (setq out (math-mul out (math-pow
1287 fac (/ pow 2)))
1288 pow (% pow 2)))
1289 (if (> pow 0)
1290 (if (memq (car-safe fac) '(+ -))
1291 (setq sums (math-mul-thru sums fac))
1292 (setq rest (math-mul rest fac)))))
1293 (and (not (and (eq out 1) (memq rest '(1 -1))))
1294 (math-mul
1295 out
1296 (list 'calcFunc-sqrt
d3896480 1297 (math-mul sums rest))))))))))))
136211a9
EZ		 1298
1299;;; Rather than factoring x into primes, just check for the first ten primes.
1300(defun math-squared-factor (x)
1301 (if (Math-integerp x)
1302 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1303 (fac 1)
1304 res)
1305 (while prsqr
1306 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1307 (setq x (car res)
1308 fac (math-mul fac (car prsqr)))
1309 (setq prsqr (cdr prsqr))))
d3896480 1310 fac)))
136211a9
EZ		 1311
1312(math-defsimplify calcFunc-exp
0c908945 1313 (math-simplify-exp (nth 1 math-simplify-expr)))
136211a9
EZ		 1314
1315(defun math-simplify-exp (x)
1316 (or (and (eq (car-safe x) 'calcFunc-ln)
1317 (nth 1 x))
1318 (and math-living-dangerously
1319 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1320 (math-add (nth 1 x)
1321 (list 'calcFunc-sqrt
1322 (math-add (math-sqr (nth 1 x)) 1))))
1323 (and (eq (car-safe x) 'calcFunc-arccosh)
1324 (math-add (nth 1 x)
1325 (list 'calcFunc-sqrt
1326 (math-sub (math-sqr (nth 1 x)) 1))))
1327 (and (eq (car-safe x) 'calcFunc-arctanh)
1328 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1329 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1330 (let ((m (math-should-expand-trig x 'exp)))
1331 (and m (integerp (car m))
1332 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1333 (and calc-symbolic-mode
1334 (math-known-imagp x)
1335 (let* ((ip (calcFunc-im x))
1336 (n (math-linear-in ip '(var pi var-pi)))
1337 s c)
1338 (and n
1339 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1340 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
d3896480 1341 (list '+ c (list '* s '(var i var-i))))))))
136211a9
EZ		 1342
1343(math-defsimplify calcFunc-ln
0c908945 1344 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
136211a9 1345 (or math-living-dangerously
0c908945
JB		 1346 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1347 (nth 1 (nth 1 math-simplify-expr)))
1348 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1349 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
136211a9 1350 (or math-living-dangerously
0c908945
JB		 1351 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1352 (nth 2 (nth 1 math-simplify-expr)))
136211a9 1353 (and calc-symbolic-mode
0c908945
JB		 1354 (math-known-negp (nth 1 math-simplify-expr))
1355 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
2c6dfebb 1356 '(* (var pi var-pi) (var i var-i))))
136211a9 1357 (and calc-symbolic-mode
0c908945
JB		 1358 (math-known-imagp (nth 1 math-simplify-expr))
1359 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
136211a9
EZ		 1360 (ips (math-possible-signs ip)))
1361 (or (and (memq ips '(4 6))
1362 (math-add (list 'calcFunc-ln ip)
1363 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1364 (and (memq ips '(1 3))
1365 (math-sub (list 'calcFunc-ln (math-neg ip))
d3896480 1366 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
136211a9
EZ		 1367
1368(math-defsimplify ^
1369 (math-simplify-pow))
1370
1371(defun math-simplify-pow ()
1372 (or (and math-living-dangerously
0c908945 1373 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
136211a9 1374 (list '^
0c908945 1375 (nth 1 (nth 1 math-simplify-expr))
f3445fab 1376 (math-mul (nth 2 math-simplify-expr)
0c908945
JB		 1377 (nth 2 (nth 1 math-simplify-expr)))))
1378 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
136211a9 1379 (list '^
0c908945
JB		 1380 (nth 1 (nth 1 math-simplify-expr))
1381 (math-div (nth 2 math-simplify-expr) 2)))
1382 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1383 (list (car (nth 1 math-simplify-expr))
f3445fab 1384 (list '^ (nth 1 (nth 1 math-simplify-expr))
0c908945 1385 (nth 2 math-simplify-expr))
f3445fab 1386 (list '^ (nth 2 (nth 1 math-simplify-expr))
0c908945
JB		 1387 (nth 2 math-simplify-expr))))))
1388 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1389 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1390 (nth 1 (nth 2 math-simplify-expr)))
1391 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1392 (math-simplify-exp (nth 2 math-simplify-expr)))
1393 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
136211a9 1394 (not math-integrating)
f3445fab 1395 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
0c908945
JB		 1396 (nth 2 math-simplify-expr))))
1397 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
136211a9 1398 (math-imaginary-i)
0c908945
JB		 1399 (math-num-integerp (nth 2 math-simplify-expr))
1400 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
136211a9 1401 (cond ((eq x 0) 1)
0c908945 1402 ((eq x 1) (nth 1 math-simplify-expr))
136211a9 1403 ((eq x 2) -1)
0c908945 1404 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
136211a9 1405 (and math-integrating
0c908945
JB		 1406 (integerp (nth 2 math-simplify-expr))
1407 (>= (nth 2 math-simplify-expr) 2)
1408 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
f3445fab 1409 (math-mul (math-pow (nth 1 math-simplify-expr)
0c908945 1410 (- (nth 2 math-simplify-expr) 2))
136211a9
EZ		 1411 (math-sub 1
1412 (math-sqr
1413 (list 'calcFunc-sin
0c908945
JB		 1414 (nth 1 (nth 1 math-simplify-expr)))))))
1415 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
f3445fab 1416 (math-mul (math-pow (nth 1 math-simplify-expr)
0c908945 1417 (- (nth 2 math-simplify-expr) 2))
136211a9
EZ		 1418 (math-add 1
1419 (math-sqr
1420 (list 'calcFunc-sinh
0c908945
JB		 1421 (nth 1 (nth 1 math-simplify-expr)))))))))
1422 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1423 (Math-ratp (nth 1 math-simplify-expr))
1424 (Math-posp (nth 1 math-simplify-expr))
1425 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1426 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1427 (let ((flr (math-floor (nth 2 math-simplify-expr))))
136211a9 1428 (and (not (Math-zerop flr))
0c908945
JB		 1429 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1430 (list '^ (nth 1 math-simplify-expr)
1431 (math-sub (nth 2 math-simplify-expr) flr)))))))
1432 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
136211a9
EZ		 1433 (let ((temp (math-simplify-sqrt)))
1434 (and temp
0c908945 1435 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
136211a9
EZ		 1436
1437(math-defsimplify calcFunc-log10
0c908945
JB		 1438 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1439 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
136211a9 1440 (or math-living-dangerously
0c908945
JB		 1441 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1442 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1443
1444
1445(math-defsimplify calcFunc-erf
0c908945
JB		 1446 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1447 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1448 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
f3445fab 1449 (list 'calcFunc-conj
0c908945 1450 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
136211a9
EZ		 1451
1452(math-defsimplify calcFunc-erfc
0c908945
JB		 1453 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1454 (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
1455 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
f3445fab 1456 (list 'calcFunc-conj
0c908945 1457 (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
136211a9
EZ		 1458
1459
1460(defun math-linear-in (expr term &optional always)
1461 (if (math-expr-contains expr term)
1462 (let* ((calc-prefer-frac t)
1463 (p (math-is-polynomial expr term 1)))
1464 (and (cdr p)
1465 p))
d3896480 1466 (and always (list expr 0))))
136211a9
EZ		 1467
1468(defun math-multiple-of (expr term)
1469 (let ((p (math-linear-in expr term)))
1470 (and p
1471 (math-zerop (car p))
d3896480 1472 (nth 1 p))))
136211a9 1473
d3896480 1474; not perfect, but it'll do
136211a9
EZ		 1475(defun math-integer-plus (expr)
1476 (cond ((Math-integerp expr)
1477 (list 0 expr))
1478 ((and (memq (car expr) '(+ -))
1479 (Math-integerp (nth 1 expr)))
1480 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1481 (nth 1 expr)))
1482 ((and (memq (car expr) '(+ -))
1483 (Math-integerp (nth 2 expr)))
1484 (list (nth 1 expr)
1485 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
d3896480 1486 (t nil)))
136211a9
EZ		 1487
1488(defun math-is-linear (expr &optional always)
1489 (let ((offset nil)
1490 (coef nil))
1491 (if (eq (car-safe expr) '+)
1492 (if (Math-objectp (nth 1 expr))
1493 (setq offset (nth 1 expr)
1494 expr (nth 2 expr))
1495 (if (Math-objectp (nth 2 expr))
1496 (setq offset (nth 2 expr)
1497 expr (nth 1 expr))))
1498 (if (eq (car-safe expr) '-)
1499 (if (Math-objectp (nth 1 expr))
1500 (setq offset (nth 1 expr)
1501 expr (math-neg (nth 2 expr)))
1502 (if (Math-objectp (nth 2 expr))
1503 (setq offset (math-neg (nth 2 expr))
1504 expr (nth 1 expr))))))
1505 (setq coef (math-is-multiple expr always))
1506 (if offset
1507 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1508 (if coef
d3896480 1509 (cons 0 coef)))))
136211a9
EZ		 1510
1511(defun math-is-multiple (expr &optional always)
1512 (or (if (eq (car-safe expr) '*)
1513 (if (Math-objectp (nth 1 expr))
1514 (list (nth 1 expr) (nth 2 expr)))
1515 (if (eq (car-safe expr) '/)
1516 (if (and (Math-objectp (nth 1 expr))
1517 (not (math-equal-int (nth 1 expr) 1)))
1518 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1519 (if (Math-objectp (nth 2 expr))
1520 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1521 (let ((res (math-is-multiple (nth 1 expr))))
1522 (if res
1523 (list (car res)
1524 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1525 (setq res (math-is-multiple (nth 2 expr)))
1526 (if res
1527 (list (math-div 1 (car res))
1528 (math-div (nth 1 expr)
1529 (nth 2 (nth 2 expr)))))))))
1530 (if (eq (car-safe expr) 'neg)
1531 (list -1 (nth 1 expr)))))
1532 (if (Math-objvecp expr)
1533 (and (eq always 1)
1534 (list expr 1))
a1506d29 1535 (and always
d3896480 1536 (list 1 expr)))))
136211a9
EZ		 1537
1538(defun calcFunc-lin (expr &optional var)
1539 (if var
1540 (let ((res (math-linear-in expr var t)))
1541 (or res (math-reject-arg expr "Linear term expected"))
1542 (list 'vec (car res) (nth 1 res) var))
1543 (let ((res (math-is-linear expr t)))
1544 (or res (math-reject-arg expr "Linear term expected"))
d3896480 1545 (cons 'vec res))))
136211a9
EZ		 1546
1547(defun calcFunc-linnt (expr &optional var)
1548 (if var
1549 (let ((res (math-linear-in expr var)))
1550 (or res (math-reject-arg expr "Linear term expected"))
1551 (list 'vec (car res) (nth 1 res) var))
1552 (let ((res (math-is-linear expr)))
1553 (or res (math-reject-arg expr "Linear term expected"))
d3896480 1554 (cons 'vec res))))
136211a9
EZ		 1555
1556(defun calcFunc-islin (expr &optional var)
1557 (if (and (Math-objvecp expr) (not var))
1558 0
1559 (calcFunc-lin expr var)
d3896480 1560 1))
136211a9
EZ		 1561
1562(defun calcFunc-islinnt (expr &optional var)
1563 (if (Math-objvecp expr)
1564 0
1565 (calcFunc-linnt expr var)
d3896480 1566 1))
136211a9
EZ		 1567
1568
1569
1570
1571;;; Simple operations on expressions.
1572
6f826971 1573;;; Return number of occurrences of thing in expr, or nil if none.
136211a9
EZ		 1574(defun math-expr-contains-count (expr thing)
1575 (cond ((equal expr thing) 1)
1576 ((Math-primp expr) nil)
1577 (t
1578 (let ((num 0))
1579 (while (setq expr (cdr expr))
1580 (setq num (+ num (or (math-expr-contains-count
1581 (car expr) thing) 0))))
1582 (and (> num 0)
d3896480 1583 num)))))
136211a9
EZ		 1584
1585(defun math-expr-contains (expr thing)
1586 (cond ((equal expr thing) 1)
1587 ((Math-primp expr) nil)
1588 (t
1589 (while (and (setq expr (cdr expr))
1590 (not (math-expr-contains (car expr) thing))))
d3896480 1591 expr)))
136211a9
EZ		 1592
1593;;; Return non-nil if any variable of thing occurs in expr.
1594(defun math-expr-depends (expr thing)
1595 (if (Math-primp thing)
1596 (and (eq (car-safe thing) 'var)
1597 (math-expr-contains expr thing))
1598 (while (and (setq thing (cdr thing))
1599 (not (math-expr-depends expr (car thing)))))
d3896480 1600 thing))
136211a9
EZ		 1601
1602;;; Substitute all occurrences of old for new in expr (non-destructive).
0c908945
JB		 1603
1604;; The variables math-expr-subst-old and math-expr-subst-new are local
1605;; for math-expr-subst, but used by math-expr-subst-rec.
1606(defvar math-expr-subst-old)
1607(defvar math-expr-subst-new)
1608
1609(defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
d3896480
CW		 1610 (math-expr-subst-rec expr))
1611
1612(defalias 'calcFunc-subst 'math-expr-subst)
136211a9
EZ		 1613
1614(defun math-expr-subst-rec (expr)
0c908945 1615 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
136211a9
EZ		 1616 ((Math-primp expr) expr)
1617 ((memq (car expr) '(calcFunc-deriv
1618 calcFunc-tderiv))
1619 (if (= (length expr) 2)
0c908945
JB		 1620 (if (equal (nth 1 expr) math-expr-subst-old)
1621 (append expr (list math-expr-subst-new))
136211a9
EZ		 1622 expr)
1623 (list (car expr) (nth 1 expr)
1624 (math-expr-subst-rec (nth 2 expr)))))
1625 (t
1626 (cons (car expr)
d3896480 1627 (mapcar 'math-expr-subst-rec (cdr expr))))))
136211a9
EZ		 1628
1629;;; Various measures of the size of an expression.
1630(defun math-expr-weight (expr)
1631 (if (Math-primp expr)
1632 1
1633 (let ((w 1))
1634 (while (setq expr (cdr expr))
1635 (setq w (+ w (math-expr-weight (car expr)))))
d3896480 1636 w)))
136211a9
EZ		 1637
1638(defun math-expr-height (expr)
1639 (if (Math-primp expr)
1640 0
1641 (let ((h 0))
1642 (while (setq expr (cdr expr))
1643 (setq h (max h (math-expr-height (car expr)))))
d3896480 1644 (1+ h))))
136211a9
EZ		 1645
1646
1647
1648
1649;;; Polynomial operations (to support the integrator and solve-for).
1650
1651(defun calcFunc-collect (expr base)
1652 (let ((p (math-is-polynomial expr base 50 t)))
1653 (if (cdr p)
9f6a59d1 1654 (math-build-polynomial-expr (mapcar 'math-normalize p) base)
df802986 1655 (car p))))
136211a9
EZ		 1656
1657;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
f3445fab 1658;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
0c908945
JB		 1659;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1660
f3445fab
GM		 1661;; These variables are local to math-is-polynomial, but are used by
1662;; math-is-poly-rec.
0c908945
JB		 1663(defvar math-is-poly-degree)
1664(defvar math-is-poly-loose)
a974dcf2 1665(defvar math-var)
0c908945 1666
a974dcf2 1667(defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose)
0c908945 1668 (let* ((math-poly-base-variable (if math-is-poly-loose
a974dcf2 1669 (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX))
136211a9
EZ		 1670 math-poly-base-variable))
1671 (poly (math-is-poly-rec expr math-poly-neg-powers)))
0c908945
JB		 1672 (and (or (null math-is-poly-degree)
1673 (<= (length poly) (1+ math-is-poly-degree)))
d3896480 1674 poly)))
136211a9
EZ		 1675
1676(defun math-is-poly-rec (expr negpow)
1677 (math-poly-simplify
a974dcf2 1678 (or (cond ((or (equal expr math-var)
136211a9
EZ		 1679 (eq (car-safe expr) '^))
1680 (let ((pow 1)
1681 (expr expr))
a974dcf2 1682 (or (equal expr math-var)
136211a9
EZ		 1683 (setq pow (nth 2 expr)
1684 expr (nth 1 expr)))
1685 (or (eq math-poly-mult-powers 1)
1686 (setq pow (let ((m (math-is-multiple pow 1)))
1687 (and (eq (car-safe (car m)) 'cplx)
1688 (Math-zerop (nth 1 (car m)))
1689 (setq m (list (nth 2 (car m))
1690 (math-mul (nth 1 m)
1691 '(var i var-i)))))
1692 (and (if math-poly-mult-powers
1693 (equal math-poly-mult-powers
1694 (nth 1 m))
1695 (setq math-poly-mult-powers (nth 1 m)))
a974dcf2 1696 (or (equal expr math-var)
136211a9
EZ		 1697 (eq math-poly-mult-powers 1))
1698 (car m)))))
1699 (if (consp pow)
1700 (progn
1701 (setq pow (math-to-simple-fraction pow))
1702 (and (eq (car-safe pow) 'frac)
1703 math-poly-frac-powers
a974dcf2 1704 (equal expr math-var)
136211a9
EZ		 1705 (setq math-poly-frac-powers
1706 (calcFunc-lcm math-poly-frac-powers
1707 (nth 2 pow))))))
1708 (or (memq math-poly-frac-powers '(1 nil))
1709 (setq pow (math-mul pow math-poly-frac-powers)))
1710 (if (integerp pow)
1711 (if (and (= pow 1)
a974dcf2 1712 (equal expr math-var))
136211a9
EZ		 1713 (list 0 1)
1714 (if (natnump pow)
a974dcf2 1715 (let ((p1 (if (equal expr math-var)
136211a9
EZ		 1716 (list 0 1)
1717 (math-is-poly-rec expr nil)))
1718 (n pow)
1719 (accum (list 1)))
1720 (and p1
0c908945
JB		 1721 (or (null math-is-poly-degree)
1722 (<= (* (1- (length p1)) n) math-is-poly-degree))
136211a9
EZ		 1723 (progn
1724 (while (>= n 1)
1725 (setq accum (math-poly-mul accum p1)
1726 n (1- n)))
1727 accum)))
1728 (and negpow
1729 (math-is-poly-rec expr nil)
1730 (setq math-poly-neg-powers
1731 (cons (math-pow expr (- pow))
1732 math-poly-neg-powers))
1733 (list (list '^ expr pow))))))))
1734 ((Math-objectp expr)
1735 (list expr))
1736 ((memq (car expr) '(+ -))
1737 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1738 (and p1
1739 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1740 (and p2
1741 (math-poly-mix p1 1 p2
1742 (if (eq (car expr) '+) 1 -1)))))))
1743 ((eq (car expr) 'neg)
1744 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1745 ((eq (car expr) '*)
1746 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1747 (and p1
1748 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1749 (and p2
0c908945 1750 (or (null math-is-poly-degree)
f3445fab 1751 (<= (- (+ (length p1) (length p2)) 2)
0c908945 1752 math-is-poly-degree))
136211a9
EZ		 1753 (math-poly-mul p1 p2))))))
1754 ((eq (car expr) '/)
a974dcf2 1755 (and (or (not (math-poly-depends (nth 2 expr) math-var))
136211a9
EZ		 1756 (and negpow
1757 (math-is-poly-rec (nth 2 expr) nil)
1758 (setq math-poly-neg-powers
1759 (cons (nth 2 expr) math-poly-neg-powers))))
1760 (not (Math-zerop (nth 2 expr)))
1761 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1762 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1763 p1))))
1764 ((and (eq (car expr) 'calcFunc-exp)
a974dcf2
JB		 1765 (equal math-var '(var e var-e)))
1766 (math-is-poly-rec (list '^ math-var (nth 1 expr)) negpow))
136211a9
EZ		 1767 ((and (eq (car expr) 'calcFunc-sqrt)
1768 math-poly-frac-powers)
1769 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1770 (t nil))
a974dcf2 1771 (and (or (not (math-poly-depends expr math-var))
0c908945 1772 math-is-poly-loose)
136211a9 1773 (not (eq (car expr) 'vec))
d3896480 1774 (list expr)))))
136211a9
EZ		 1775
1776;;; Check if expr is a polynomial in var; if so, return its degree.
1777(defun math-polynomial-p (expr var)
1778 (cond ((equal expr var) 1)
1779 ((Math-primp expr) 0)
1780 ((memq (car expr) '(+ -))
1781 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1782 p2)
1783 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1784 (max p1 p2))))
1785 ((eq (car expr) '*)
1786 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1787 p2)
1788 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1789 (+ p1 p2))))
1790 ((eq (car expr) 'neg)
1791 (math-polynomial-p (nth 1 expr) var))
1792 ((and (eq (car expr) '/)
1793 (not (math-poly-depends (nth 2 expr) var)))
1794 (math-polynomial-p (nth 1 expr) var))
1795 ((and (eq (car expr) '^)
1796 (natnump (nth 2 expr)))
1797 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1798 (and p1 (* p1 (nth 2 expr)))))
1799 ((math-poly-depends expr var) nil)
d3896480 1800 (t 0)))
136211a9
EZ		 1801
1802(defun math-poly-depends (expr var)
1803 (if math-poly-base-variable
1804 (math-expr-contains expr math-poly-base-variable)
d3896480 1805 (math-expr-depends expr var)))
136211a9
EZ		 1806
1807;;; Find the variable (or sub-expression) which is the base of polynomial expr.
0c908945
JB		 1808;; The variables math-poly-base-const-ok and math-poly-base-pred are
1809;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1810(defvar math-poly-base-const-ok)
1811(defvar math-poly-base-pred)
1812
885e6671
JB		 1813;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1814;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1815;; by math-polynomial-base.
1816
1817(defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
0c908945
JB		 1818 (or math-poly-base-pred
1819 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
885e6671 1820 math-poly-base-top-expr base)))))
0c908945 1821 (or (let ((math-poly-base-const-ok nil))
885e6671 1822 (math-polynomial-base-rec math-poly-base-top-expr))
0c908945 1823 (let ((math-poly-base-const-ok t))
885e6671 1824 (math-polynomial-base-rec math-poly-base-top-expr))))
136211a9
EZ		 1825
1826(defun math-polynomial-base-rec (mpb-expr)
1827 (and (not (Math-objvecp mpb-expr))
1828 (or (and (memq (car mpb-expr) '(+ - *))
1829 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1830 (math-polynomial-base-rec (nth 2 mpb-expr))))
1831 (and (memq (car mpb-expr) '(/ neg))
1832 (math-polynomial-base-rec (nth 1 mpb-expr)))
1833 (and (eq (car mpb-expr) '^)
1834 (math-polynomial-base-rec (nth 1 mpb-expr)))
1835 (and (eq (car mpb-expr) 'calcFunc-exp)
1836 (math-polynomial-base-rec '(var e var-e)))
0c908945
JB		 1837 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1838 (funcall math-poly-base-pred mpb-expr)
d3896480 1839 mpb-expr))))
136211a9
EZ		 1840
1841;;; Return non-nil if expr refers to any variables.
1842(defun math-expr-contains-vars (expr)
1843 (or (eq (car-safe expr) 'var)
1844 (and (not (Math-primp expr))
1845 (progn
1846 (while (and (setq expr (cdr expr))
1847 (not (math-expr-contains-vars (car expr)))))
d3896480 1848 expr))))
136211a9
EZ		 1849
1850;;; Simplify a polynomial in list form by stripping off high-end zeros.
6196cffe 1851;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
136211a9
EZ		 1852(defun math-poly-simplify (p)
1853 (and p
1854 (if (Math-zerop (nth (1- (length p)) p))
1855 (let ((pp (copy-sequence p)))
1856 (while (and (cdr pp)
1857 (Math-zerop (nth (1- (length pp)) pp)))
1858 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1859 pp)
d3896480 1860 p)))
136211a9
EZ		 1861
1862;;; Compute ac*a + bc*b for polynomials in list form a, b and
1863;;; coefficients ac, bc. Result may be unsimplified.
1864(defun math-poly-mix (a ac b bc)
1865 (and (or a b)
1866 (cons (math-add (math-mul (or (car a) 0) ac)
1867 (math-mul (or (car b) 0) bc))
d3896480 1868 (math-poly-mix (cdr a) ac (cdr b) bc))))
136211a9
EZ		 1869
1870(defun math-poly-zerop (a)
1871 (or (null a)
d3896480 1872 (and (null (cdr a)) (Math-zerop (car a)))))
136211a9
EZ		 1873
1874;;; Multiply two polynomials in list form.
1875(defun math-poly-mul (a b)
1876 (and a b
1877 (math-poly-mix b (car a)
d3896480 1878 (math-poly-mul (cdr a) (cons 0 b)) 1)))
136211a9
EZ		 1879
1880;;; Build an expression from a polynomial list.
1881(defun math-build-polynomial-expr (p var)
1882 (if p
1883 (if (Math-numberp var)
1884 (math-with-extra-prec 1
1885 (let* ((rp (reverse p))
1886 (accum (car rp)))
1887 (while (setq rp (cdr rp))
1888 (setq accum (math-add (car rp) (math-mul accum var))))
1889 accum))
1890 (let* ((rp (reverse p))
1891 (n (1- (length rp)))
1892 (accum (math-mul (car rp) (math-pow var n)))
1893 term)
1894 (while (setq rp (cdr rp))
1895 (setq n (1- n))
1896 (or (math-zerop (car rp))
1897 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1898 accum
1899 (math-mul (if (math-looks-negp (car rp))
1900 (math-neg (car rp))
1901 (car rp))
1902 (math-pow var n))))))
1903 accum))
d3896480 1904 0))
136211a9
EZ		 1905
1906
1907(defun math-to-simple-fraction (f)
1908 (or (and (eq (car-safe f) 'float)
1909 (or (and (>= (nth 2 f) 0)
1910 (math-scale-int (nth 1 f) (nth 2 f)))
1911 (and (integerp (nth 1 f))
1912 (> (nth 1 f) -1000)
1913 (< (nth 1 f) 1000)
1914 (math-make-frac (nth 1 f)
1915 (math-scale-int 1 (- (nth 2 f)))))))
d3896480 1916 f))
136211a9 1917
41cf648d
JB		 1918(provide 'calc-alg)
1919
d3896480 1920;;; calc-alg.el ends here
Unnamed repository; edit this file 'description' to name the repository.