HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Spelling fixes.
[bpt/emacs.git] / lisp / calc / calc-alg.el
CommitLineData
a1506d29 1;;; calc-alg.el --- algebraic functions for Calc
3132f345 2
73b0cd50 3;; Copyright (C) 1990-1993, 2001-2011 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
136211a9
EZ		 359(defun math-simplify (top-expr)
360 (let ((math-simplifying t)
0c908945 361 (math-top-only (consp calc-simplify-mode))
136211a9
EZ		 362 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
363 '((var AlgSimpRules var-AlgSimpRules)))
364 (and math-living-dangerously
365 (calc-has-rules 'var-ExtSimpRules)
366 '((var ExtSimpRules var-ExtSimpRules)))
367 (and math-simplifying-units
368 (calc-has-rules 'var-UnitSimpRules)
369 '((var UnitSimpRules var-UnitSimpRules)))
370 (and math-integrating
371 (calc-has-rules 'var-IntegSimpRules)
372 '((var IntegSimpRules var-IntegSimpRules)))))
373 res)
0c908945 374 (if math-top-only
136211a9
EZ		 375 (let ((r simp-rules))
376 (setq res (math-simplify-step (math-normalize top-expr))
377 calc-simplify-mode '(nil)
378 top-expr (math-normalize res))
379 (while r
380 (setq top-expr (math-rewrite top-expr (car r)
381 '(neg (var inf var-inf)))
382 r (cdr r))))
383 (calc-with-default-simplification
384 (while (let ((r simp-rules))
385 (setq res (math-normalize top-expr))
386 (while r
387 (setq res (math-rewrite res (car r))
388 r (cdr r)))
389 (not (equal top-expr (setq res (math-simplify-step res)))))
390 (setq top-expr res)))))
d3896480
CW		 391 top-expr)
392
393(defalias 'calcFunc-simplify 'math-simplify)
136211a9
EZ		 394
395;;; The following has a "bug" in that if any recursive simplifications
396;;; occur only the first handler will be tried; this doesn't really
397;;; matter, since math-simplify-step is iterated to a fixed point anyway.
398(defun math-simplify-step (a)
399 (if (Math-primp a)
400 a
0c908945 401 (let ((aa (if (or math-top-only
136211a9
EZ		 402 (memq (car a) '(calcFunc-quote calcFunc-condition
403 calcFunc-evalto)))
404 a
405 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
406 (and (symbolp (car aa))
407 (let ((handler (get (car aa) 'math-simplify)))
408 (and handler
409 (while (and handler
410 (equal (setq aa (or (funcall (car handler) aa)
411 aa))
412 a))
413 (setq handler (cdr handler))))))
d3896480 414 aa)))
136211a9
EZ		 415
416
41cf648d 417(defmacro math-defsimplify (funcs &rest code)
4f91a816
SM		 418 (cons 'progn
419 (mapcar #'(lambda (func)
420 `(put ',func 'math-simplify
421 (nconc
422 (get ',func 'math-simplify)
423 (list
424 #'(lambda (math-simplify-expr) ,@code)))))
425 (if (symbolp funcs) (list funcs) funcs))))
41cf648d 426(put 'math-defsimplify 'lisp-indent-hook 1)
136211a9 427
0c908945
JB		 428;; The function created by math-defsimplify uses the variable
429;; math-simplify-expr, and so is used by functions in math-defsimplify
430(defvar math-simplify-expr)
431
136211a9
EZ		 432(math-defsimplify (+ -)
433 (math-simplify-plus))
434
435(defun math-simplify-plus ()
0c908945
JB		 436 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
437 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
438 (not (Math-numberp (nth 2 math-simplify-expr))))
439 (let ((x (nth 2 math-simplify-expr))
440 (op (car math-simplify-expr)))
441 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
442 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
443 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
444 (setcar (nth 1 math-simplify-expr) op)))
445 ((and (eq (car math-simplify-expr) '+)
446 (Math-numberp (nth 1 math-simplify-expr))
447 (not (Math-numberp (nth 2 math-simplify-expr))))
448 (let ((x (nth 2 math-simplify-expr)))
449 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
450 (setcar (cdr math-simplify-expr) x))))
451 (let ((aa math-simplify-expr)
136211a9
EZ		 452 aaa temp)
453 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
0c908945 454 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
f3445fab 455 (eq (car aaa) '-)
0c908945 456 (eq (car math-simplify-expr) '-) t))
136211a9 457 (progn
0c908945
JB		 458 (setcar (cdr (cdr math-simplify-expr)) temp)
459 (setcar math-simplify-expr '+)
136211a9
EZ		 460 (setcar (cdr (cdr aaa)) 0)))
461 (setq aa (nth 1 aa)))
0c908945
JB		 462 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
463 nil (eq (car math-simplify-expr) '-) t))
136211a9 464 (progn
0c908945
JB		 465 (setcar (cdr (cdr math-simplify-expr)) temp)
466 (setcar math-simplify-expr '+)
136211a9 467 (setcar (cdr aa) 0)))
0c908945 468 math-simplify-expr))
136211a9
EZ		 469
470(math-defsimplify *
471 (math-simplify-times))
472
473(defun math-simplify-times ()
0c908945
JB		 474 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
475 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
476 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
477 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
478 (let ((x (nth 1 math-simplify-expr)))
479 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
480 (setcar (cdr (nth 2 math-simplify-expr)) x)))
481 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
482 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
483 (math-known-scalarp (nth 2 math-simplify-expr) t))
484 (let ((x (nth 2 math-simplify-expr)))
485 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
486 (setcar (cdr math-simplify-expr) x))))
487 (let ((aa math-simplify-expr)
136211a9 488 aaa temp
0c908945
JB		 489 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
490 (if (and (Math-ratp (nth 1 math-simplify-expr))
491 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
136211a9 492 (progn
0c908945
JB		 493 (setcar (cdr (cdr math-simplify-expr))
494 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
495 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
136211a9
EZ		 496 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
497 safe)
f3445fab 498 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
0c908945 499 (nth 1 aaa) nil nil t))
136211a9 500 (progn
0c908945 501 (setcar (cdr math-simplify-expr) temp)
136211a9
EZ		 502 (setcar (cdr aaa) 1)))
503 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
504 aa (nth 2 aa)))
0c908945 505 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
136211a9
EZ		 506 safe)
507 (progn
0c908945 508 (setcar (cdr math-simplify-expr) temp)
136211a9 509 (setcar (cdr (cdr aa)) 1)))
0c908945
JB		 510 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
511 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
f3445fab 512 (math-div (math-mul (nth 2 math-simplify-expr)
0c908945
JB		 513 (nth 1 (nth 1 math-simplify-expr)))
514 (nth 2 (nth 1 math-simplify-expr)))
515 math-simplify-expr)))
136211a9
EZ		 516
517(math-defsimplify /
518 (math-simplify-divide))
519
520(defun math-simplify-divide ()
0c908945 521 (let ((np (cdr math-simplify-expr))
136211a9 522 (nover nil)
f3445fab 523 (nn (and (or (eq (car math-simplify-expr) '/)
0c908945
JB		 524 (not (Math-realp (nth 2 math-simplify-expr))))
525 (math-common-constant-factor (nth 2 math-simplify-expr))))
136211a9
EZ		 526 n op)
527 (if nn
528 (progn
f3445fab 529 (setq n (and (or (eq (car math-simplify-expr) '/)
0c908945
JB		 530 (not (Math-realp (nth 1 math-simplify-expr))))
531 (math-common-constant-factor (nth 1 math-simplify-expr))))
136211a9
EZ		 532 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
533 (progn
f3445fab 534 (setcar (cdr math-simplify-expr)
0c908945
JB		 535 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
536 (setcar (cdr (cdr math-simplify-expr))
537 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
136211a9 538 (if (and (math-negp nn)
0c908945
JB		 539 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
540 (setcar math-simplify-expr (nth 1 op))))
136211a9
EZ		 541 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
542 (progn
0c908945
JB		 543 (setcar (cdr math-simplify-expr)
544 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
545 (setcar (cdr (cdr math-simplify-expr))
546 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
136211a9 547 (if (and (math-negp n)
f3445fab 548 (setq op (assq (car math-simplify-expr)
0c908945
JB		 549 calc-tweak-eqn-table)))
550 (setcar math-simplify-expr (nth 1 op))))))))
136211a9 551 (if (and (eq (car-safe (car np)) '/)
0c908945 552 (math-known-scalarp (nth 2 math-simplify-expr) t))
136211a9 553 (progn
0c908945 554 (setq np (cdr (nth 1 math-simplify-expr)))
136211a9
EZ		 555 (while (eq (car-safe (setq n (car np))) '*)
556 (and (math-known-scalarp (nth 2 n) t)
0c908945 557 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
136211a9 558 (setq np (cdr (cdr n))))
0c908945 559 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
136211a9 560 (setq nover t
0c908945 561 np (cdr (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)) nover t))
136211a9 565 (setq np (cdr (cdr n))))
0c908945
JB		 566 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
567 math-simplify-expr))
568
569;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
570;; are local variables for math-simplify-divisor, but are used by
571;; math-simplify-one-divisor.
572(defvar math-simplify-divisor-nover)
573(defvar math-simplify-divisor-dover)
136211a9 574
f3445fab 575(defun math-simplify-divisor (np dp math-simplify-divisor-nover
0c908945 576 math-simplify-divisor-dover)
136211a9 577 (cond ((eq (car-safe (car dp)) '/)
f3445fab
GM		 578 (math-simplify-divisor np (cdr (car dp))
579 math-simplify-divisor-nover
0c908945 580 math-simplify-divisor-dover)
136211a9
EZ		 581 (and (math-known-scalarp (nth 1 (car dp)) t)
582 (math-simplify-divisor np (cdr (cdr (car dp)))
f3445fab 583 math-simplify-divisor-nover
0c908945
JB		 584 (not math-simplify-divisor-dover))))
585 ((or (or (eq (car math-simplify-expr) '/)
136211a9
EZ		 586 (let ((signs (math-possible-signs (car np))))
587 (or (memq signs '(1 4))
0c908945 588 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
136211a9
EZ		 589 (eq signs 5))
590 math-living-dangerously)))
591 (math-numberp (car np)))
358c90f4 592 (let (d
f3445fab 593 (safe t)
358c90f4 594 (scalar (math-known-scalarp (car np))))
136211a9
EZ		 595 (while (and (eq (car-safe (setq d (car dp))) '*)
596 safe)
597 (math-simplify-one-divisor np (cdr d))
598 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
599 dp (cdr (cdr d))))
600 (if safe
d3896480 601 (math-simplify-one-divisor np dp))))))
136211a9
EZ		 602
603(defun math-simplify-one-divisor (np dp)
f3445fab 604 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
0c908945
JB		 605 math-simplify-divisor-dover t))
606 op)
f3445fab 607 (if temp
0c908945
JB		 608 (progn
609 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
610 (math-known-negp (car dp))
611 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
612 (setcar math-simplify-expr (nth 1 op)))
613 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
614 (setcar dp 1))
f3445fab 615 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
0c908945
JB		 616 (eq (car math-simplify-expr) '/)
617 (eq (car-safe (car dp)) 'calcFunc-sqrt)
618 (Math-integerp (nth 1 (car dp)))
619 (progn
620 (setcar np (math-mul (car np)
621 (list 'calcFunc-sqrt (nth 1 (car dp)))))
622 (setcar dp (nth 1 (car dp))))))))
136211a9
EZ		 623
624(defun math-common-constant-factor (expr)
625 (if (Math-realp expr)
626 (if (Math-ratp expr)
627 (and (not (memq expr '(0 1 -1)))
628 (math-abs expr))
629 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
630 (math-common-constant-factor expr)))
631 (if (memq (car expr) '(+ - cplx sdev))
632 (let ((f1 (math-common-constant-factor (nth 1 expr)))
633 (f2 (math-common-constant-factor (nth 2 expr))))
634 (and f1 f2
635 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
636 f1))
637 (if (memq (car expr) '(* polar))
638 (math-common-constant-factor (nth 1 expr))
639 (if (eq (car expr) '/)
640 (or (math-common-constant-factor (nth 1 expr))
641 (and (Math-integerp (nth 2 expr))
d3896480 642 (list 'frac 1 (math-abs (nth 2 expr))))))))))
136211a9
EZ		 643
644(defun math-cancel-common-factor (expr val)
645 (if (memq (car-safe expr) '(+ - cplx sdev))
646 (progn
647 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
648 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
649 expr)
650 (if (eq (car-safe expr) '*)
651 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
d3896480 652 (math-div expr val))))
136211a9
EZ		 653
654(defun math-frac-gcd (a b)
655 (if (Math-zerop a)
656 b
657 (if (Math-zerop b)
658 a
659 (if (and (Math-integerp a)
660 (Math-integerp b))
661 (math-gcd a b)
662 (and (Math-integerp a) (setq a (list 'frac a 1)))
663 (and (Math-integerp b) (setq b (list 'frac b 1)))
664 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
d3896480 665 (math-gcd (nth 2 a) (nth 2 b)))))))
136211a9
EZ		 666
667(math-defsimplify %
668 (math-simplify-mod))
669
670(defun math-simplify-mod ()
0c908945
JB		 671 (and (Math-realp (nth 2 math-simplify-expr))
672 (Math-posp (nth 2 math-simplify-expr))
673 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
136211a9
EZ		 674 t1 t2 t3)
675 (or (and lin
676 (or (math-negp (car lin))
0c908945 677 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
136211a9
EZ		 678 (list '%
679 (list '+
680 (math-mul (nth 1 lin) (nth 2 lin))
0c908945
JB		 681 (math-mod (car lin) (nth 2 math-simplify-expr)))
682 (nth 2 math-simplify-expr)))
136211a9
EZ		 683 (and lin
684 (not (math-equal-int (nth 1 lin) 1))
685 (math-num-integerp (nth 1 lin))
0c908945
JB		 686 (math-num-integerp (nth 2 math-simplify-expr))
687 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
136211a9
EZ		 688 (not (math-equal-int t1 1))
689 (list '*
690 t1
691 (list '%
692 (list '+
693 (math-mul (math-div (nth 1 lin) t1)
694 (nth 2 lin))
695 (let ((calc-prefer-frac t))
696 (math-div (car lin) t1)))
0c908945
JB		 697 (math-div (nth 2 math-simplify-expr) t1))))
698 (and (math-equal-int (nth 2 math-simplify-expr) 1)
136211a9
EZ		 699 (math-known-integerp (if lin
700 (math-mul (nth 1 lin) (nth 2 lin))
0c908945 701 (nth 1 math-simplify-expr)))
d3896480 702 (if lin (math-mod (car lin) 1) 0))))))
136211a9
EZ		 703
704(math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
705 calcFunc-gt calcFunc-leq calcFunc-geq)
0c908945 706 (if (= (length math-simplify-expr) 3)
136211a9
EZ		 707 (math-simplify-ineq)))
708
709(defun math-simplify-ineq ()
0c908945 710 (let ((np (cdr math-simplify-expr))
136211a9
EZ		 711 n)
712 (while (memq (car-safe (setq n (car np))) '(+ -))
0c908945 713 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
136211a9
EZ		 714 (eq (car n) '-) nil)
715 (setq np (cdr n)))
f3445fab 716 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
0c908945 717 (eq np (cdr math-simplify-expr)))
136211a9 718 (math-simplify-divide)
0c908945
JB		 719 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
720 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
136211a9
EZ		 721 (or (and (eq signs 2) 1)
722 (and (memq signs '(1 4 5)) 0)))
0c908945 723 ((eq (car math-simplify-expr) 'calcFunc-neq)
136211a9
EZ		 724 (or (and (eq signs 2) 0)
725 (and (memq signs '(1 4 5)) 1)))
0c908945 726 ((eq (car math-simplify-expr) 'calcFunc-lt)
136211a9
EZ		 727 (or (and (eq signs 1) 1)
728 (and (memq signs '(2 4 6)) 0)))
0c908945 729 ((eq (car math-simplify-expr) 'calcFunc-gt)
136211a9
EZ		 730 (or (and (eq signs 4) 1)
731 (and (memq signs '(1 2 3)) 0)))
0c908945 732 ((eq (car math-simplify-expr) 'calcFunc-leq)
136211a9
EZ		 733 (or (and (eq signs 4) 0)
734 (and (memq signs '(1 2 3)) 1)))
0c908945 735 ((eq (car math-simplify-expr) 'calcFunc-geq)
136211a9
EZ		 736 (or (and (eq signs 1) 0)
737 (and (memq signs '(2 4 6)) 1))))
0c908945 738 math-simplify-expr))))
136211a9
EZ		 739
740(defun math-simplify-add-term (np dp minus lplain)
741 (or (math-vectorp (car np))
742 (let ((rplain t)
743 n d dd temp)
744 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
745 (setq rplain nil)
746 (if (setq temp (math-combine-sum n (nth 2 d)
747 minus (eq (car d) '+) t))
748 (if (or lplain (eq (math-looks-negp temp) minus))
749 (progn
750 (setcar np (setq n (if minus (math-neg temp) temp)))
751 (setcar (cdr (cdr d)) 0))
752 (progn
753 (setcar np 0)
754 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
755 (math-neg temp)
756 temp))))))
757 (setq dp (cdr d)))
758 (if (setq temp (math-combine-sum n d minus t t))
759 (if (or lplain
760 (and (not rplain)
761 (eq (math-looks-negp temp) minus)))
762 (progn
763 (setcar np (setq n (if minus (math-neg temp) temp)))
764 (setcar dp 0))
765 (progn
766 (setcar np 0)
d3896480 767 (setcar dp (setq n (math-neg temp)))))))))
136211a9
EZ		 768
769(math-defsimplify calcFunc-sin
0c908945
JB		 770 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
771 (nth 1 (nth 1 math-simplify-expr)))
772 (and (math-looks-negp (nth 1 math-simplify-expr))
773 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
136211a9 774 (and (eq calc-angle-mode 'rad)
0c908945 775 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 776 (and n
777 (math-known-sin (car n) (nth 1 n) 120 0))))
778 (and (eq calc-angle-mode 'deg)
0c908945 779 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 780 (and n
781 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
0c908945 782 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 783 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
0c908945
JB		 784 (nth 1 (nth 1 math-simplify-expr))))))
785 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
786 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 787 (list 'calcFunc-sqrt
f3445fab 788 (math-add 1 (math-sqr
0c908945
JB		 789 (nth 1 (nth 1 math-simplify-expr)))))))
790 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 791 (and m (integerp (car m))
792 (let ((n (car m)) (a (nth 1 m)))
793 (list '+
794 (list '* (list 'calcFunc-sin (list '* (1- n) a))
795 (list 'calcFunc-cos a))
796 (list '* (list 'calcFunc-cos (list '* (1- n) a))
d3896480 797 (list 'calcFunc-sin a))))))))
136211a9
EZ		 798
799(math-defsimplify calcFunc-cos
0c908945
JB		 800 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
801 (nth 1 (nth 1 math-simplify-expr)))
802 (and (math-looks-negp (nth 1 math-simplify-expr))
803 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
136211a9 804 (and (eq calc-angle-mode 'rad)
0c908945 805 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 806 (and n
807 (math-known-sin (car n) (nth 1 n) 120 300))))
808 (and (eq calc-angle-mode 'deg)
0c908945 809 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 810 (and n
811 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
0c908945 812 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
f3445fab 813 (list 'calcFunc-sqrt
0c908945
JB		 814 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
815 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
136211a9
EZ		 816 (math-div 1
817 (list 'calcFunc-sqrt
f3445fab 818 (math-add 1
0c908945
JB		 819 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
820 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 821 (and m (integerp (car m))
822 (let ((n (car m)) (a (nth 1 m)))
823 (list '-
824 (list '* (list 'calcFunc-cos (list '* (1- n) a))
825 (list 'calcFunc-cos a))
826 (list '* (list 'calcFunc-sin (list '* (1- n) a))
d3896480 827 (list 'calcFunc-sin a))))))))
136211a9 828
6a5412e4
JB		 829(math-defsimplify calcFunc-sec
830 (or (and (math-looks-negp (nth 1 math-simplify-expr))
831 (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
832 (and (eq calc-angle-mode 'rad)
833 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
834 (and n
835 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
836 (and (eq calc-angle-mode 'deg)
837 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
838 (and n
839 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
840 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
f3445fab 841 (math-div
6a5412e4 842 1
f3445fab 843 (list 'calcFunc-sqrt
6a5412e4
JB		 844 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
845 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 846 (math-div
6a5412e4
JB		 847 1
848 (nth 1 (nth 1 math-simplify-expr))))
849 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
850 (list 'calcFunc-sqrt
f3445fab 851 (math-add 1
6a5412e4
JB		 852 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
853
854(math-defsimplify calcFunc-csc
855 (or (and (math-looks-negp (nth 1 math-simplify-expr))
856 (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
857 (and (eq calc-angle-mode 'rad)
858 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
859 (and n
860 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
861 (and (eq calc-angle-mode 'deg)
862 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
863 (and n
864 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
865 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
866 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
867 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
f3445fab 868 (math-div
6a5412e4 869 1
f3445fab 870 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
6a5412e4
JB		 871 (nth 1 (nth 1 math-simplify-expr)))))))
872 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
873 (math-div (list 'calcFunc-sqrt
f3445fab 874 (math-add 1 (math-sqr
6a5412e4
JB		 875 (nth 1 (nth 1 math-simplify-expr)))))
876 (nth 1 (nth 1 math-simplify-expr))))))
877
136211a9
EZ		 878(defun math-should-expand-trig (x &optional hyperbolic)
879 (let ((m (math-is-multiple x)))
880 (and math-living-dangerously
881 m (or (and (integerp (car m)) (> (car m) 1))
882 (equal (car m) '(frac 1 2)))
883 (or math-integrating
884 (memq (car-safe (nth 1 m))
885 (if hyperbolic
886 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
887 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
888 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
889 (eq hyperbolic 'exp)))
d3896480 890 m)))
136211a9
EZ		 891
892(defun math-known-sin (plus n mul off)
893 (setq n (math-mul n mul))
894 (and (math-num-integerp n)
895 (setq n (math-mod (math-add (math-trunc n) off) 240))
896 (if (>= n 120)
897 (and (setq n (math-known-sin plus (- n 120) 1 0))
898 (math-neg n))
899 (if (> n 60)
900 (setq n (- 120 n)))
901 (if (math-zerop plus)
902 (and (or calc-symbolic-mode
903 (memq n '(0 20 60)))
904 (cdr (assq n
905 '( (0 . 0)
906 (10 . (/ (calcFunc-sqrt
907 (- 2 (calcFunc-sqrt 3))) 2))
908 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
909 (15 . (/ (calcFunc-sqrt
910 (- 2 (calcFunc-sqrt 2))) 2))
911 (20 . (/ 1 2))
912 (24 . (* (^ (/ 1 2) (/ 3 2))
913 (calcFunc-sqrt
914 (- 5 (calcFunc-sqrt 5)))))
915 (30 . (/ (calcFunc-sqrt 2) 2))
916 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
917 (40 . (/ (calcFunc-sqrt 3) 2))
918 (45 . (/ (calcFunc-sqrt
919 (+ 2 (calcFunc-sqrt 2))) 2))
920 (48 . (* (^ (/ 1 2) (/ 3 2))
921 (calcFunc-sqrt
922 (+ 5 (calcFunc-sqrt 5)))))
923 (50 . (/ (calcFunc-sqrt
924 (+ 2 (calcFunc-sqrt 3))) 2))
925 (60 . 1)))))
926 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
927 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
d3896480 928 (t nil))))))
136211a9
EZ		 929
930(math-defsimplify calcFunc-tan
0c908945
JB		 931 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
932 (nth 1 (nth 1 math-simplify-expr)))
933 (and (math-looks-negp (nth 1 math-simplify-expr))
934 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
136211a9 935 (and (eq calc-angle-mode 'rad)
0c908945 936 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
136211a9
EZ		 937 (and n
938 (math-known-tan (car n) (nth 1 n) 120))))
939 (and (eq calc-angle-mode 'deg)
0c908945 940 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
136211a9
EZ		 941 (and n
942 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
0c908945
JB		 943 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
944 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 945 (list 'calcFunc-sqrt
0c908945
JB		 946 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
947 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
136211a9 948 (math-div (list 'calcFunc-sqrt
0c908945
JB		 949 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
950 (nth 1 (nth 1 math-simplify-expr))))
951 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
136211a9
EZ		 952 (and m
953 (if (equal (car m) '(frac 1 2))
954 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
955 (list 'calcFunc-sin (nth 1 m)))
0c908945
JB		 956 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
957 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
136211a9 958
6a5412e4
JB		 959(math-defsimplify calcFunc-cot
960 (or (and (math-looks-negp (nth 1 math-simplify-expr))
961 (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
962 (and (eq calc-angle-mode 'rad)
963 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
964 (and n
965 (math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
966 (and (eq calc-angle-mode 'deg)
967 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
968 (and n
969 (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
970 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
971 (math-div (list 'calcFunc-sqrt
972 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
973 (nth 1 (nth 1 math-simplify-expr))))
974 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
975 (math-div (nth 1 (nth 1 math-simplify-expr))
976 (list 'calcFunc-sqrt
977 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
978 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
979 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
980
136211a9
EZ		 981(defun math-known-tan (plus n mul)
982 (setq n (math-mul n mul))
983 (and (math-num-integerp n)
984 (setq n (math-mod (math-trunc n) 120))
985 (if (> n 60)
986 (and (setq n (math-known-tan plus (- 120 n) 1))
987 (math-neg n))
988 (if (math-zerop plus)
989 (and (or calc-symbolic-mode
990 (memq n '(0 30 60)))
991 (cdr (assq n '( (0 . 0)
992 (10 . (- 2 (calcFunc-sqrt 3)))
993 (12 . (calcFunc-sqrt
994 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
995 (15 . (- (calcFunc-sqrt 2) 1))
996 (20 . (/ (calcFunc-sqrt 3) 3))
997 (24 . (calcFunc-sqrt
998 (- 5 (* 2 (calcFunc-sqrt 5)))))
999 (30 . 1)
1000 (36 . (calcFunc-sqrt
1001 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1002 (40 . (calcFunc-sqrt 3))
1003 (45 . (+ (calcFunc-sqrt 2) 1))
1004 (48 . (calcFunc-sqrt
1005 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1006 (50 . (+ 2 (calcFunc-sqrt 3)))
1007 (60 . (var uinf var-uinf))))))
1008 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
1009 ((eq n 60) (math-normalize (list '/ -1
1010 (list 'calcFunc-tan plus))))
d3896480 1011 (t nil))))))
136211a9
EZ		 1012
1013(math-defsimplify calcFunc-sinh
0c908945
JB		 1014 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1015 (nth 1 (nth 1 math-simplify-expr)))
1016 (and (math-looks-negp (nth 1 math-simplify-expr))
1017 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
1018 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
136211a9 1019 math-living-dangerously
f3445fab 1020 (list 'calcFunc-sqrt
0c908945
JB		 1021 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1022 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
136211a9 1023 math-living-dangerously
0c908945 1024 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 1025 (list 'calcFunc-sqrt
0c908945
JB		 1026 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1027 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1028 (and m (integerp (car m))
1029 (let ((n (car m)) (a (nth 1 m)))
1030 (if (> n 1)
1031 (list '+
1032 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1033 (list 'calcFunc-cosh a))
1034 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
d3896480 1035 (list 'calcFunc-sinh a)))))))))
136211a9
EZ		 1036
1037(math-defsimplify calcFunc-cosh
0c908945
JB		 1038 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1039 (nth 1 (nth 1 math-simplify-expr)))
1040 (and (math-looks-negp (nth 1 math-simplify-expr))
1041 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
1042 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
136211a9 1043 math-living-dangerously
f3445fab 1044 (list 'calcFunc-sqrt
0c908945
JB		 1045 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1046 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
136211a9
EZ		 1047 math-living-dangerously
1048 (math-div 1
1049 (list 'calcFunc-sqrt
0c908945
JB		 1050 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1051 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1052 (and m (integerp (car m))
1053 (let ((n (car m)) (a (nth 1 m)))
1054 (if (> n 1)
1055 (list '+
1056 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1057 (list 'calcFunc-cosh a))
1058 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
d3896480 1059 (list 'calcFunc-sinh a)))))))))
136211a9
EZ		 1060
1061(math-defsimplify calcFunc-tanh
0c908945
JB		 1062 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1063 (nth 1 (nth 1 math-simplify-expr)))
1064 (and (math-looks-negp (nth 1 math-simplify-expr))
1065 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
1066 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
136211a9 1067 math-living-dangerously
0c908945 1068 (math-div (nth 1 (nth 1 math-simplify-expr))
136211a9 1069 (list 'calcFunc-sqrt
0c908945
JB		 1070 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1071 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
136211a9
EZ		 1072 math-living-dangerously
1073 (math-div (list 'calcFunc-sqrt
0c908945
JB		 1074 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1075 (nth 1 (nth 1 math-simplify-expr))))
1076 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
136211a9
EZ		 1077 (and m
1078 (if (equal (car m) '(frac 1 2))
1079 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
1080 (list 'calcFunc-sinh (nth 1 m)))
0c908945
JB		 1081 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
1082 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
136211a9 1083
6a5412e4
JB		 1084(math-defsimplify calcFunc-sech
1085 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1086 (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
1087 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1088 math-living-dangerously
f3445fab 1089 (math-div
6a5412e4 1090 1
f3445fab 1091 (list 'calcFunc-sqrt
6a5412e4
JB		 1092 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1093 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1094 math-living-dangerously
1095 (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
1096 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1097 math-living-dangerously
1098 (list 'calcFunc-sqrt
1099 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
1100
1101(math-defsimplify calcFunc-csch
1102 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1103 (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
1104 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1105 math-living-dangerously
1106 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
1107 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1108 math-living-dangerously
f3445fab 1109 (math-div
6a5412e4 1110 1
f3445fab 1111 (list 'calcFunc-sqrt
6a5412e4
JB		 1112 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1113 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1114 math-living-dangerously
1115 (math-div (list 'calcFunc-sqrt
1116 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
1117 (nth 1 (nth 1 math-simplify-expr))))))
1118
1119(math-defsimplify calcFunc-coth
1120 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1121 (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
1122 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1123 math-living-dangerously
1124 (math-div (list 'calcFunc-sqrt
1125 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1126 (nth 1 (nth 1 math-simplify-expr))))
1127 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1128 math-living-dangerously
1129 (math-div (nth 1 (nth 1 math-simplify-expr))
1130 (list 'calcFunc-sqrt
1131 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1132 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1133 math-living-dangerously
1134 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
1135
136211a9 1136(math-defsimplify calcFunc-arcsin
0c908945
JB		 1137 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1138 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
1139 (and (eq (nth 1 math-simplify-expr) 1)
136211a9 1140 (math-quarter-circle t))
0c908945 1141 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
136211a9
EZ		 1142 (math-div (math-half-circle t) 6))
1143 (and math-living-dangerously
0c908945
JB		 1144 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1145 (nth 1 (nth 1 math-simplify-expr)))
136211a9 1146 (and math-living-dangerously
0c908945 1147 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
136211a9 1148 (math-sub (math-quarter-circle t)
0c908945 1149 (nth 1 (nth 1 math-simplify-expr))))))
136211a9
EZ		 1150
1151(math-defsimplify calcFunc-arccos
0c908945 1152 (or (and (eq (nth 1 math-simplify-expr) 0)
136211a9 1153 (math-quarter-circle t))
0c908945 1154 (and (eq (nth 1 math-simplify-expr) -1)
136211a9 1155 (math-half-circle t))
0c908945 1156 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
136211a9 1157 (math-div (math-half-circle t) 3))
0c908945 1158 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
136211a9
EZ		 1159 (math-div (math-mul (math-half-circle t) 2) 3))
1160 (and math-living-dangerously
0c908945
JB		 1161 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1162 (nth 1 (nth 1 math-simplify-expr)))
136211a9 1163 (and math-living-dangerously
0c908945 1164 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
136211a9 1165 (math-sub (math-quarter-circle t)
0c908945 1166 (nth 1 (nth 1 math-simplify-expr))))))
136211a9
EZ		 1167
1168(math-defsimplify calcFunc-arctan
0c908945
JB		 1169 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1170 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
1171 (and (eq (nth 1 math-simplify-expr) 1)
136211a9
EZ		 1172 (math-div (math-half-circle t) 4))
1173 (and math-living-dangerously
0c908945
JB		 1174 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
1175 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1176
1177(math-defsimplify calcFunc-arcsinh
0c908945
JB		 1178 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1179 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
1180 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
136211a9 1181 (or math-living-dangerously
0c908945
JB		 1182 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1183 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1184
1185(math-defsimplify calcFunc-arccosh
0c908945 1186 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
136211a9 1187 (or math-living-dangerously
0c908945
JB		 1188 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1189 (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1190
1191(math-defsimplify calcFunc-arctanh
0c908945
JB		 1192 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1193 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
1194 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
136211a9 1195 (or math-living-dangerously
0c908945
JB		 1196 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1197 (nth 1 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1198
1199(math-defsimplify calcFunc-sqrt
d3896480 1200 (math-simplify-sqrt))
136211a9
EZ		 1201
1202(defun math-simplify-sqrt ()
0c908945 1203 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
f3445fab 1204 (math-div (list 'calcFunc-sqrt
0c908945
JB		 1205 (math-mul (nth 1 (nth 1 math-simplify-expr))
1206 (nth 2 (nth 1 math-simplify-expr))))
1207 (nth 2 (nth 1 math-simplify-expr))))
1208 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1209 (math-squared-factor (nth 1 math-simplify-expr))
1210 (math-common-constant-factor (nth 1 math-simplify-expr)))))
136211a9
EZ		 1211 (and fac (not (eq fac 1))
1212 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1213 (math-normalize
1214 (list 'calcFunc-sqrt
f3445fab 1215 (math-cancel-common-factor
0c908945 1216 (nth 1 math-simplify-expr) fac))))))
136211a9 1217 (and math-living-dangerously
0c908945
JB		 1218 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1219 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1220 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1221 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1222 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1223 'calcFunc-sin)
1224 (list 'calcFunc-cos
0c908945
JB		 1225 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1226 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1227 'calcFunc-cos)
1228 (list 'calcFunc-sin
f3445fab 1229 (nth 1 (nth 1 (nth 2
0c908945
JB		 1230 (nth 1 math-simplify-expr))))))))
1231 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1232 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1233 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1234 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1235 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1236 'calcFunc-cosh)
1237 (list 'calcFunc-sinh
0c908945
JB		 1238 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1239 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1240 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1241 (b (nth 2 (nth 1 math-simplify-expr))))
136211a9 1242 (and (or (and (math-equal-int a 1)
0c908945 1243 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
136211a9
EZ		 1244 (math-equal-int b 1))
1245 (eq (car-safe a) '^)
1246 (math-equal-int (nth 2 a) 2)
1247 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1248 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
6a5412e4
JB		 1249 (and (eq (car-safe (nth 1 a)) 'calcFunc-csch)
1250 (list 'calcFunc-coth (nth 1 (nth 1 a))))
136211a9
EZ		 1251 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1252 (list '/ 1 (list 'calcFunc-cos
6a5412e4
JB		 1253 (nth 1 (nth 1 a)))))
1254 (and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
1255 (list '/ 1 (list 'calcFunc-sin
136211a9 1256 (nth 1 (nth 1 a)))))))))
0c908945 1257 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
136211a9 1258 (list '^
0c908945
JB		 1259 (nth 1 (nth 1 math-simplify-expr))
1260 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1261 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1262 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1263 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1264 (list (car (nth 1 math-simplify-expr))
1265 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1266 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1267 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1268 (not (math-any-floats (nth 1 math-simplify-expr)))
136211a9 1269 (let ((f (calcFunc-factors (calcFunc-expand
0c908945 1270 (nth 1 math-simplify-expr)))))
136211a9
EZ		 1271 (and (math-vectorp f)
1272 (or (> (length f) 2)
1273 (> (nth 2 (nth 1 f)) 1))
1274 (let ((out 1) (rest 1) (sums 1) fac pow)
1275 (while (setq f (cdr f))
1276 (setq fac (nth 1 (car f))
1277 pow (nth 2 (car f)))
1278 (if (> pow 1)
1279 (setq out (math-mul out (math-pow
1280 fac (/ pow 2)))
1281 pow (% pow 2)))
1282 (if (> pow 0)
1283 (if (memq (car-safe fac) '(+ -))
1284 (setq sums (math-mul-thru sums fac))
1285 (setq rest (math-mul rest fac)))))
1286 (and (not (and (eq out 1) (memq rest '(1 -1))))
1287 (math-mul
1288 out
1289 (list 'calcFunc-sqrt
d3896480 1290 (math-mul sums rest))))))))))))
136211a9
EZ		 1291
1292;;; Rather than factoring x into primes, just check for the first ten primes.
1293(defun math-squared-factor (x)
1294 (if (Math-integerp x)
1295 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1296 (fac 1)
1297 res)
1298 (while prsqr
1299 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1300 (setq x (car res)
1301 fac (math-mul fac (car prsqr)))
1302 (setq prsqr (cdr prsqr))))
d3896480 1303 fac)))
136211a9
EZ		 1304
1305(math-defsimplify calcFunc-exp
0c908945 1306 (math-simplify-exp (nth 1 math-simplify-expr)))
136211a9
EZ		 1307
1308(defun math-simplify-exp (x)
1309 (or (and (eq (car-safe x) 'calcFunc-ln)
1310 (nth 1 x))
1311 (and math-living-dangerously
1312 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1313 (math-add (nth 1 x)
1314 (list 'calcFunc-sqrt
1315 (math-add (math-sqr (nth 1 x)) 1))))
1316 (and (eq (car-safe x) 'calcFunc-arccosh)
1317 (math-add (nth 1 x)
1318 (list 'calcFunc-sqrt
1319 (math-sub (math-sqr (nth 1 x)) 1))))
1320 (and (eq (car-safe x) 'calcFunc-arctanh)
1321 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1322 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1323 (let ((m (math-should-expand-trig x 'exp)))
1324 (and m (integerp (car m))
1325 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1326 (and calc-symbolic-mode
1327 (math-known-imagp x)
1328 (let* ((ip (calcFunc-im x))
1329 (n (math-linear-in ip '(var pi var-pi)))
1330 s c)
1331 (and n
1332 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1333 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
d3896480 1334 (list '+ c (list '* s '(var i var-i))))))))
136211a9
EZ		 1335
1336(math-defsimplify calcFunc-ln
0c908945 1337 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
136211a9 1338 (or math-living-dangerously
0c908945
JB		 1339 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1340 (nth 1 (nth 1 math-simplify-expr)))
1341 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1342 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
136211a9 1343 (or math-living-dangerously
0c908945
JB		 1344 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1345 (nth 2 (nth 1 math-simplify-expr)))
136211a9 1346 (and calc-symbolic-mode
0c908945
JB		 1347 (math-known-negp (nth 1 math-simplify-expr))
1348 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
2c6dfebb 1349 '(* (var pi var-pi) (var i var-i))))
136211a9 1350 (and calc-symbolic-mode
0c908945
JB		 1351 (math-known-imagp (nth 1 math-simplify-expr))
1352 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
136211a9
EZ		 1353 (ips (math-possible-signs ip)))
1354 (or (and (memq ips '(4 6))
1355 (math-add (list 'calcFunc-ln ip)
1356 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1357 (and (memq ips '(1 3))
1358 (math-sub (list 'calcFunc-ln (math-neg ip))
d3896480 1359 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
136211a9
EZ		 1360
1361(math-defsimplify ^
1362 (math-simplify-pow))
1363
1364(defun math-simplify-pow ()
1365 (or (and math-living-dangerously
0c908945 1366 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
136211a9 1367 (list '^
0c908945 1368 (nth 1 (nth 1 math-simplify-expr))
f3445fab 1369 (math-mul (nth 2 math-simplify-expr)
0c908945
JB		 1370 (nth 2 (nth 1 math-simplify-expr)))))
1371 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
136211a9 1372 (list '^
0c908945
JB		 1373 (nth 1 (nth 1 math-simplify-expr))
1374 (math-div (nth 2 math-simplify-expr) 2)))
1375 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1376 (list (car (nth 1 math-simplify-expr))
f3445fab 1377 (list '^ (nth 1 (nth 1 math-simplify-expr))
0c908945 1378 (nth 2 math-simplify-expr))
f3445fab 1379 (list '^ (nth 2 (nth 1 math-simplify-expr))
0c908945
JB		 1380 (nth 2 math-simplify-expr))))))
1381 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1382 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1383 (nth 1 (nth 2 math-simplify-expr)))
1384 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1385 (math-simplify-exp (nth 2 math-simplify-expr)))
1386 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
136211a9 1387 (not math-integrating)
f3445fab 1388 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
0c908945
JB		 1389 (nth 2 math-simplify-expr))))
1390 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
136211a9 1391 (math-imaginary-i)
0c908945
JB		 1392 (math-num-integerp (nth 2 math-simplify-expr))
1393 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
136211a9 1394 (cond ((eq x 0) 1)
0c908945 1395 ((eq x 1) (nth 1 math-simplify-expr))
136211a9 1396 ((eq x 2) -1)
0c908945 1397 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
136211a9 1398 (and math-integrating
0c908945
JB		 1399 (integerp (nth 2 math-simplify-expr))
1400 (>= (nth 2 math-simplify-expr) 2)
1401 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
f3445fab 1402 (math-mul (math-pow (nth 1 math-simplify-expr)
0c908945 1403 (- (nth 2 math-simplify-expr) 2))
136211a9
EZ		 1404 (math-sub 1
1405 (math-sqr
1406 (list 'calcFunc-sin
0c908945
JB		 1407 (nth 1 (nth 1 math-simplify-expr)))))))
1408 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
f3445fab 1409 (math-mul (math-pow (nth 1 math-simplify-expr)
0c908945 1410 (- (nth 2 math-simplify-expr) 2))
136211a9
EZ		 1411 (math-add 1
1412 (math-sqr
1413 (list 'calcFunc-sinh
0c908945
JB		 1414 (nth 1 (nth 1 math-simplify-expr)))))))))
1415 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1416 (Math-ratp (nth 1 math-simplify-expr))
1417 (Math-posp (nth 1 math-simplify-expr))
1418 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1419 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1420 (let ((flr (math-floor (nth 2 math-simplify-expr))))
136211a9 1421 (and (not (Math-zerop flr))
0c908945
JB		 1422 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1423 (list '^ (nth 1 math-simplify-expr)
1424 (math-sub (nth 2 math-simplify-expr) flr)))))))
1425 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
136211a9
EZ		 1426 (let ((temp (math-simplify-sqrt)))
1427 (and temp
0c908945 1428 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
136211a9
EZ		 1429
1430(math-defsimplify calcFunc-log10
0c908945
JB		 1431 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1432 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
136211a9 1433 (or math-living-dangerously
0c908945
JB		 1434 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1435 (nth 2 (nth 1 math-simplify-expr))))
136211a9
EZ		 1436
1437
1438(math-defsimplify calcFunc-erf
0c908945
JB		 1439 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1440 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1441 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
f3445fab 1442 (list 'calcFunc-conj
0c908945 1443 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
136211a9
EZ		 1444
1445(math-defsimplify calcFunc-erfc
0c908945
JB		 1446 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1447 (math-sub 2 (list 'calcFunc-erfc (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-erfc (nth 1 (nth 1 math-simplify-expr)))))))
136211a9
EZ		 1451
1452
1453(defun math-linear-in (expr term &optional always)
1454 (if (math-expr-contains expr term)
1455 (let* ((calc-prefer-frac t)
1456 (p (math-is-polynomial expr term 1)))
1457 (and (cdr p)
1458 p))
d3896480 1459 (and always (list expr 0))))
136211a9
EZ		 1460
1461(defun math-multiple-of (expr term)
1462 (let ((p (math-linear-in expr term)))
1463 (and p
1464 (math-zerop (car p))
d3896480 1465 (nth 1 p))))
136211a9 1466
d3896480 1467; not perfect, but it'll do
136211a9
EZ		 1468(defun math-integer-plus (expr)
1469 (cond ((Math-integerp expr)
1470 (list 0 expr))
1471 ((and (memq (car expr) '(+ -))
1472 (Math-integerp (nth 1 expr)))
1473 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1474 (nth 1 expr)))
1475 ((and (memq (car expr) '(+ -))
1476 (Math-integerp (nth 2 expr)))
1477 (list (nth 1 expr)
1478 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
d3896480 1479 (t nil)))
136211a9
EZ		 1480
1481(defun math-is-linear (expr &optional always)
1482 (let ((offset nil)
1483 (coef nil))
1484 (if (eq (car-safe expr) '+)
1485 (if (Math-objectp (nth 1 expr))
1486 (setq offset (nth 1 expr)
1487 expr (nth 2 expr))
1488 (if (Math-objectp (nth 2 expr))
1489 (setq offset (nth 2 expr)
1490 expr (nth 1 expr))))
1491 (if (eq (car-safe expr) '-)
1492 (if (Math-objectp (nth 1 expr))
1493 (setq offset (nth 1 expr)
1494 expr (math-neg (nth 2 expr)))
1495 (if (Math-objectp (nth 2 expr))
1496 (setq offset (math-neg (nth 2 expr))
1497 expr (nth 1 expr))))))
1498 (setq coef (math-is-multiple expr always))
1499 (if offset
1500 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1501 (if coef
d3896480 1502 (cons 0 coef)))))
136211a9
EZ		 1503
1504(defun math-is-multiple (expr &optional always)
1505 (or (if (eq (car-safe expr) '*)
1506 (if (Math-objectp (nth 1 expr))
1507 (list (nth 1 expr) (nth 2 expr)))
1508 (if (eq (car-safe expr) '/)
1509 (if (and (Math-objectp (nth 1 expr))
1510 (not (math-equal-int (nth 1 expr) 1)))
1511 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1512 (if (Math-objectp (nth 2 expr))
1513 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1514 (let ((res (math-is-multiple (nth 1 expr))))
1515 (if res
1516 (list (car res)
1517 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1518 (setq res (math-is-multiple (nth 2 expr)))
1519 (if res
1520 (list (math-div 1 (car res))
1521 (math-div (nth 1 expr)
1522 (nth 2 (nth 2 expr)))))))))
1523 (if (eq (car-safe expr) 'neg)
1524 (list -1 (nth 1 expr)))))
1525 (if (Math-objvecp expr)
1526 (and (eq always 1)
1527 (list expr 1))
a1506d29 1528 (and always
d3896480 1529 (list 1 expr)))))
136211a9
EZ		 1530
1531(defun calcFunc-lin (expr &optional var)
1532 (if var
1533 (let ((res (math-linear-in expr var t)))
1534 (or res (math-reject-arg expr "Linear term expected"))
1535 (list 'vec (car res) (nth 1 res) var))
1536 (let ((res (math-is-linear expr t)))
1537 (or res (math-reject-arg expr "Linear term expected"))
d3896480 1538 (cons 'vec res))))
136211a9
EZ		 1539
1540(defun calcFunc-linnt (expr &optional var)
1541 (if var
1542 (let ((res (math-linear-in expr var)))
1543 (or res (math-reject-arg expr "Linear term expected"))
1544 (list 'vec (car res) (nth 1 res) var))
1545 (let ((res (math-is-linear expr)))
1546 (or res (math-reject-arg expr "Linear term expected"))
d3896480 1547 (cons 'vec res))))
136211a9
EZ		 1548
1549(defun calcFunc-islin (expr &optional var)
1550 (if (and (Math-objvecp expr) (not var))
1551 0
1552 (calcFunc-lin expr var)
d3896480 1553 1))
136211a9
EZ		 1554
1555(defun calcFunc-islinnt (expr &optional var)
1556 (if (Math-objvecp expr)
1557 0
1558 (calcFunc-linnt expr var)
d3896480 1559 1))
136211a9
EZ		 1560
1561
1562
1563
1564;;; Simple operations on expressions.
1565
6f826971 1566;;; Return number of occurrences of thing in expr, or nil if none.
136211a9
EZ		 1567(defun math-expr-contains-count (expr thing)
1568 (cond ((equal expr thing) 1)
1569 ((Math-primp expr) nil)
1570 (t
1571 (let ((num 0))
1572 (while (setq expr (cdr expr))
1573 (setq num (+ num (or (math-expr-contains-count
1574 (car expr) thing) 0))))
1575 (and (> num 0)
d3896480 1576 num)))))
136211a9
EZ		 1577
1578(defun math-expr-contains (expr thing)
1579 (cond ((equal expr thing) 1)
1580 ((Math-primp expr) nil)
1581 (t
1582 (while (and (setq expr (cdr expr))
1583 (not (math-expr-contains (car expr) thing))))
d3896480 1584 expr)))
136211a9
EZ		 1585
1586;;; Return non-nil if any variable of thing occurs in expr.
1587(defun math-expr-depends (expr thing)
1588 (if (Math-primp thing)
1589 (and (eq (car-safe thing) 'var)
1590 (math-expr-contains expr thing))
1591 (while (and (setq thing (cdr thing))
1592 (not (math-expr-depends expr (car thing)))))
d3896480 1593 thing))
136211a9
EZ		 1594
1595;;; Substitute all occurrences of old for new in expr (non-destructive).
0c908945
JB		 1596
1597;; The variables math-expr-subst-old and math-expr-subst-new are local
1598;; for math-expr-subst, but used by math-expr-subst-rec.
1599(defvar math-expr-subst-old)
1600(defvar math-expr-subst-new)
1601
1602(defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
d3896480
CW		 1603 (math-expr-subst-rec expr))
1604
1605(defalias 'calcFunc-subst 'math-expr-subst)
136211a9
EZ		 1606
1607(defun math-expr-subst-rec (expr)
0c908945 1608 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
136211a9
EZ		 1609 ((Math-primp expr) expr)
1610 ((memq (car expr) '(calcFunc-deriv
1611 calcFunc-tderiv))
1612 (if (= (length expr) 2)
0c908945
JB		 1613 (if (equal (nth 1 expr) math-expr-subst-old)
1614 (append expr (list math-expr-subst-new))
136211a9
EZ		 1615 expr)
1616 (list (car expr) (nth 1 expr)
1617 (math-expr-subst-rec (nth 2 expr)))))
1618 (t
1619 (cons (car expr)
d3896480 1620 (mapcar 'math-expr-subst-rec (cdr expr))))))
136211a9
EZ		 1621
1622;;; Various measures of the size of an expression.
1623(defun math-expr-weight (expr)
1624 (if (Math-primp expr)
1625 1
1626 (let ((w 1))
1627 (while (setq expr (cdr expr))
1628 (setq w (+ w (math-expr-weight (car expr)))))
d3896480 1629 w)))
136211a9
EZ		 1630
1631(defun math-expr-height (expr)
1632 (if (Math-primp expr)
1633 0
1634 (let ((h 0))
1635 (while (setq expr (cdr expr))
1636 (setq h (max h (math-expr-height (car expr)))))
d3896480 1637 (1+ h))))
136211a9
EZ		 1638
1639
1640
1641
1642;;; Polynomial operations (to support the integrator and solve-for).
1643
1644(defun calcFunc-collect (expr base)
1645 (let ((p (math-is-polynomial expr base 50 t)))
1646 (if (cdr p)
9f6a59d1 1647 (math-build-polynomial-expr (mapcar 'math-normalize p) base)
df802986 1648 (car p))))
136211a9
EZ		 1649
1650;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
f3445fab 1651;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
0c908945
JB		 1652;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1653
f3445fab
GM		 1654;; These variables are local to math-is-polynomial, but are used by
1655;; math-is-poly-rec.
0c908945
JB		 1656(defvar math-is-poly-degree)
1657(defvar math-is-poly-loose)
a974dcf2 1658(defvar math-var)
0c908945 1659
a974dcf2 1660(defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose)
0c908945 1661 (let* ((math-poly-base-variable (if math-is-poly-loose
a974dcf2 1662 (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX))
136211a9
EZ		 1663 math-poly-base-variable))
1664 (poly (math-is-poly-rec expr math-poly-neg-powers)))
0c908945
JB		 1665 (and (or (null math-is-poly-degree)
1666 (<= (length poly) (1+ math-is-poly-degree)))
d3896480 1667 poly)))
136211a9
EZ		 1668
1669(defun math-is-poly-rec (expr negpow)
1670 (math-poly-simplify
a974dcf2 1671 (or (cond ((or (equal expr math-var)
136211a9
EZ		 1672 (eq (car-safe expr) '^))
1673 (let ((pow 1)
1674 (expr expr))
a974dcf2 1675 (or (equal expr math-var)
136211a9
EZ		 1676 (setq pow (nth 2 expr)
1677 expr (nth 1 expr)))
1678 (or (eq math-poly-mult-powers 1)
1679 (setq pow (let ((m (math-is-multiple pow 1)))
1680 (and (eq (car-safe (car m)) 'cplx)
1681 (Math-zerop (nth 1 (car m)))
1682 (setq m (list (nth 2 (car m))
1683 (math-mul (nth 1 m)
1684 '(var i var-i)))))
1685 (and (if math-poly-mult-powers
1686 (equal math-poly-mult-powers
1687 (nth 1 m))
1688 (setq math-poly-mult-powers (nth 1 m)))
a974dcf2 1689 (or (equal expr math-var)
136211a9
EZ		 1690 (eq math-poly-mult-powers 1))
1691 (car m)))))
1692 (if (consp pow)
1693 (progn
1694 (setq pow (math-to-simple-fraction pow))
1695 (and (eq (car-safe pow) 'frac)
1696 math-poly-frac-powers
a974dcf2 1697 (equal expr math-var)
136211a9
EZ		 1698 (setq math-poly-frac-powers
1699 (calcFunc-lcm math-poly-frac-powers
1700 (nth 2 pow))))))
1701 (or (memq math-poly-frac-powers '(1 nil))
1702 (setq pow (math-mul pow math-poly-frac-powers)))
1703 (if (integerp pow)
1704 (if (and (= pow 1)
a974dcf2 1705 (equal expr math-var))
136211a9
EZ		 1706 (list 0 1)
1707 (if (natnump pow)
a974dcf2 1708 (let ((p1 (if (equal expr math-var)
136211a9
EZ		 1709 (list 0 1)
1710 (math-is-poly-rec expr nil)))
1711 (n pow)
1712 (accum (list 1)))
1713 (and p1
0c908945
JB		 1714 (or (null math-is-poly-degree)
1715 (<= (* (1- (length p1)) n) math-is-poly-degree))
136211a9
EZ		 1716 (progn
1717 (while (>= n 1)
1718 (setq accum (math-poly-mul accum p1)
1719 n (1- n)))
1720 accum)))
1721 (and negpow
1722 (math-is-poly-rec expr nil)
1723 (setq math-poly-neg-powers
1724 (cons (math-pow expr (- pow))
1725 math-poly-neg-powers))
1726 (list (list '^ expr pow))))))))
1727 ((Math-objectp expr)
1728 (list expr))
1729 ((memq (car expr) '(+ -))
1730 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1731 (and p1
1732 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1733 (and p2
1734 (math-poly-mix p1 1 p2
1735 (if (eq (car expr) '+) 1 -1)))))))
1736 ((eq (car expr) 'neg)
1737 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1738 ((eq (car expr) '*)
1739 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1740 (and p1
1741 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1742 (and p2
0c908945 1743 (or (null math-is-poly-degree)
f3445fab 1744 (<= (- (+ (length p1) (length p2)) 2)
0c908945 1745 math-is-poly-degree))
136211a9
EZ		 1746 (math-poly-mul p1 p2))))))
1747 ((eq (car expr) '/)
a974dcf2 1748 (and (or (not (math-poly-depends (nth 2 expr) math-var))
136211a9
EZ		 1749 (and negpow
1750 (math-is-poly-rec (nth 2 expr) nil)
1751 (setq math-poly-neg-powers
1752 (cons (nth 2 expr) math-poly-neg-powers))))
1753 (not (Math-zerop (nth 2 expr)))
1754 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1755 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1756 p1))))
1757 ((and (eq (car expr) 'calcFunc-exp)
a974dcf2
JB		 1758 (equal math-var '(var e var-e)))
1759 (math-is-poly-rec (list '^ math-var (nth 1 expr)) negpow))
136211a9
EZ		 1760 ((and (eq (car expr) 'calcFunc-sqrt)
1761 math-poly-frac-powers)
1762 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1763 (t nil))
a974dcf2 1764 (and (or (not (math-poly-depends expr math-var))
0c908945 1765 math-is-poly-loose)
136211a9 1766 (not (eq (car expr) 'vec))
d3896480 1767 (list expr)))))
136211a9
EZ		 1768
1769;;; Check if expr is a polynomial in var; if so, return its degree.
1770(defun math-polynomial-p (expr var)
1771 (cond ((equal expr var) 1)
1772 ((Math-primp expr) 0)
1773 ((memq (car expr) '(+ -))
1774 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1775 p2)
1776 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1777 (max p1 p2))))
1778 ((eq (car expr) '*)
1779 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1780 p2)
1781 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1782 (+ p1 p2))))
1783 ((eq (car expr) 'neg)
1784 (math-polynomial-p (nth 1 expr) var))
1785 ((and (eq (car expr) '/)
1786 (not (math-poly-depends (nth 2 expr) var)))
1787 (math-polynomial-p (nth 1 expr) var))
1788 ((and (eq (car expr) '^)
1789 (natnump (nth 2 expr)))
1790 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1791 (and p1 (* p1 (nth 2 expr)))))
1792 ((math-poly-depends expr var) nil)
d3896480 1793 (t 0)))
136211a9
EZ		 1794
1795(defun math-poly-depends (expr var)
1796 (if math-poly-base-variable
1797 (math-expr-contains expr math-poly-base-variable)
d3896480 1798 (math-expr-depends expr var)))
136211a9
EZ		 1799
1800;;; Find the variable (or sub-expression) which is the base of polynomial expr.
0c908945
JB		 1801;; The variables math-poly-base-const-ok and math-poly-base-pred are
1802;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1803(defvar math-poly-base-const-ok)
1804(defvar math-poly-base-pred)
1805
885e6671
JB		 1806;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1807;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1808;; by math-polynomial-base.
1809
1810(defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
0c908945
JB		 1811 (or math-poly-base-pred
1812 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
885e6671 1813 math-poly-base-top-expr base)))))
0c908945 1814 (or (let ((math-poly-base-const-ok nil))
885e6671 1815 (math-polynomial-base-rec math-poly-base-top-expr))
0c908945 1816 (let ((math-poly-base-const-ok t))
885e6671 1817 (math-polynomial-base-rec math-poly-base-top-expr))))
136211a9
EZ		 1818
1819(defun math-polynomial-base-rec (mpb-expr)
1820 (and (not (Math-objvecp mpb-expr))
1821 (or (and (memq (car mpb-expr) '(+ - *))
1822 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1823 (math-polynomial-base-rec (nth 2 mpb-expr))))
1824 (and (memq (car mpb-expr) '(/ neg))
1825 (math-polynomial-base-rec (nth 1 mpb-expr)))
1826 (and (eq (car mpb-expr) '^)
1827 (math-polynomial-base-rec (nth 1 mpb-expr)))
1828 (and (eq (car mpb-expr) 'calcFunc-exp)
1829 (math-polynomial-base-rec '(var e var-e)))
0c908945
JB		 1830 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1831 (funcall math-poly-base-pred mpb-expr)
d3896480 1832 mpb-expr))))
136211a9
EZ		 1833
1834;;; Return non-nil if expr refers to any variables.
1835(defun math-expr-contains-vars (expr)
1836 (or (eq (car-safe expr) 'var)
1837 (and (not (Math-primp expr))
1838 (progn
1839 (while (and (setq expr (cdr expr))
1840 (not (math-expr-contains-vars (car expr)))))
d3896480 1841 expr))))
136211a9
EZ		 1842
1843;;; Simplify a polynomial in list form by stripping off high-end zeros.
6196cffe 1844;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
136211a9
EZ		 1845(defun math-poly-simplify (p)
1846 (and p
1847 (if (Math-zerop (nth (1- (length p)) p))
1848 (let ((pp (copy-sequence p)))
1849 (while (and (cdr pp)
1850 (Math-zerop (nth (1- (length pp)) pp)))
1851 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1852 pp)
d3896480 1853 p)))
136211a9
EZ		 1854
1855;;; Compute ac*a + bc*b for polynomials in list form a, b and
1856;;; coefficients ac, bc. Result may be unsimplified.
1857(defun math-poly-mix (a ac b bc)
1858 (and (or a b)
1859 (cons (math-add (math-mul (or (car a) 0) ac)
1860 (math-mul (or (car b) 0) bc))
d3896480 1861 (math-poly-mix (cdr a) ac (cdr b) bc))))
136211a9
EZ		 1862
1863(defun math-poly-zerop (a)
1864 (or (null a)
d3896480 1865 (and (null (cdr a)) (Math-zerop (car a)))))
136211a9
EZ		 1866
1867;;; Multiply two polynomials in list form.
1868(defun math-poly-mul (a b)
1869 (and a b
1870 (math-poly-mix b (car a)
d3896480 1871 (math-poly-mul (cdr a) (cons 0 b)) 1)))
136211a9
EZ		 1872
1873;;; Build an expression from a polynomial list.
1874(defun math-build-polynomial-expr (p var)
1875 (if p
1876 (if (Math-numberp var)
1877 (math-with-extra-prec 1
1878 (let* ((rp (reverse p))
1879 (accum (car rp)))
1880 (while (setq rp (cdr rp))
1881 (setq accum (math-add (car rp) (math-mul accum var))))
1882 accum))
1883 (let* ((rp (reverse p))
1884 (n (1- (length rp)))
1885 (accum (math-mul (car rp) (math-pow var n)))
1886 term)
1887 (while (setq rp (cdr rp))
1888 (setq n (1- n))
1889 (or (math-zerop (car rp))
1890 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1891 accum
1892 (math-mul (if (math-looks-negp (car rp))
1893 (math-neg (car rp))
1894 (car rp))
1895 (math-pow var n))))))
1896 accum))
d3896480 1897 0))
136211a9
EZ		 1898
1899
1900(defun math-to-simple-fraction (f)
1901 (or (and (eq (car-safe f) 'float)
1902 (or (and (>= (nth 2 f) 0)
1903 (math-scale-int (nth 1 f) (nth 2 f)))
1904 (and (integerp (nth 1 f))
1905 (> (nth 1 f) -1000)
1906 (< (nth 1 f) 1000)
1907 (math-make-frac (nth 1 f)
1908 (math-scale-int 1 (- (nth 2 f)))))))
d3896480 1909 f))
136211a9 1910
41cf648d
JB		 1911(provide 'calc-alg)
1912
d3896480 1913;;; calc-alg.el ends here
Unnamed repository; edit this file 'description' to name the repository.