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