1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This file is autoloaded from calc-ext.el.
34 (defun calc-alg-evaluate (arg)
37 (calc-with-default-simplification
38 (let ((math-simplify-only nil))
39 (calc-modify-simplify-mode arg)
40 (calc-enter-result 1 "dsmp" (calc-top 1))))))
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)))
48 (setq calc-simplify-mode (list calc-simplify-mode))))
50 (defun calc-simplify ()
53 (let ((top (calc-top-n 1)))
56 (let ((calc-simplify-mode nil))
57 (math-normalize (math-trig-rewrite top)))))
58 (if (calc-is-hyperbolic)
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))))))
65 (defun calc-simplify-extended ()
68 (calc-with-default-simplification
69 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
71 (defun calc-expand-formula (arg)
74 (calc-with-default-simplification
75 (let ((math-simplify-only nil))
76 (calc-modify-simplify-mode arg)
77 (calc-enter-result 1 "expf"
79 (let ((math-expand-formulas t))
81 (let ((top (calc-top-n 1)))
82 (or (math-expand-formula top)
85 (defun calc-factor (arg)
88 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
89 'calcFunc-factors 'calcFunc-factor)
92 (defun calc-expand (n)
95 (calc-enter-result 1 "expa"
96 (append (list 'calcFunc-expand
98 (and n (list (prefix-numeric-value n)))))))
100 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
101 (defun calcFunc-powerexpand (expr)
102 (math-normalize (math-map-tree 'math-powerexpand expr)))
104 (defun math-powerexpand (expr)
105 (if (eq (car-safe expr) '^)
106 (let ((n (nth 2 expr)))
107 (cond ((and (integerp n)
113 (setq prod (math-mul prod a))
119 (a (math-pow (nth 1 expr) -1))
120 (prod (math-pow (nth 1 expr) -1)))
122 (setq prod (math-mul a prod))
129 (defun calc-powerexpand ()
132 (calc-enter-result 1 "pexp"
133 (calcFunc-powerexpand (calc-top-n 1)))))
135 (defun calc-collect (&optional var)
136 (interactive "sCollect terms involving: ")
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
148 (defun calc-apart (arg)
151 (calc-unary-op "aprt" 'calcFunc-apart arg)))
153 (defun calc-normalize-rat (arg)
156 (calc-unary-op "nrat" 'calcFunc-nrat arg)))
158 (defun calc-poly-gcd (arg)
161 (calc-binary-op "pgcd" 'calcFunc-pgcd arg)))
164 (defun calc-poly-div (arg)
167 (let ((calc-poly-div-remainder nil))
168 (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
169 (if (and calc-poly-div-remainder (null arg))
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)")))))))
178 (defun calc-poly-rem (arg)
181 (calc-binary-op "prem" 'calcFunc-prem arg)))
183 (defun calc-poly-div-rem (arg)
186 (if (calc-is-hyperbolic)
187 (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
188 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))))
190 (defun calc-substitute (&optional oldname newname)
191 (interactive "sSubstitute old: ")
193 (let (old new (num 1) expr)
194 (if (or (equal oldname "") (equal oldname "$") (null oldname))
195 (setq new (calc-top-n 1)
200 (progn (calc-unread-command ?\C-a)
201 (setq newname (read-string (concat "Substitute old: "
205 (if (or (equal newname "") (equal newname "$") (null newname))
206 (setq new (calc-top-n 1)
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)
217 (error "No occurrences found")))
218 (calc-enter-result num "sbst" (math-expr-subst expr old new)))))
221 (defun calc-has-rules (name)
222 (setq name (calc-var-value name))
224 (memq (car name) '(vec calcFunc-assign calcFunc-condition))
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)
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)
237 math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)))
240 ;;; Try to expand a formula according to its definition.
241 (defun math-expand-formula (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)))
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)))
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)
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)))
276 (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
277 (if (math-beforep (nth 2 a) b)
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)
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)
290 ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
292 ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
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))))
304 (math-beforep (car a) (car b)))))
305 (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))))
308 (defsubst math-simplify-extended (a)
309 (let ((math-living-dangerously t))
312 (defalias 'calcFunc-esimplify 'math-simplify-extended)
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."
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))))
333 (mapcar 'math-trig-rewrite fn))))
335 (defun math-hyperbolic-trig-rewrite (fn)
336 "Rewrite hyperbolic functions in terms of sinhs and coshs."
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))))
353 (mapcar 'math-hyperbolic-trig-rewrite fn))))
355 ;; math-top-only is local to math-simplify, but is used by
356 ;; math-simplify-step, which is called by math-simplify.
357 (defvar math-top-only)
359 (defun math-simplify (top-expr)
360 (let ((math-simplifying t)
361 (math-top-only (consp calc-simplify-mode))
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)))))
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))
380 (setq top-expr (math-rewrite top-expr (car r)
381 '(neg (var inf var-inf)))
383 (calc-with-default-simplification
384 (while (let ((r simp-rules))
385 (setq res (math-normalize top-expr))
387 (setq res (math-rewrite res (car r))
389 (not (equal top-expr (setq res (math-simplify-step res)))))
390 (setq top-expr res)))))
393 (defalias 'calcFunc-simplify 'math-simplify)
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)
401 (let ((aa (if (or math-top-only
402 (memq (car a) '(calcFunc-quote calcFunc-condition
405 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
406 (and (symbolp (car aa))
407 (let ((handler (get (car aa) 'math-simplify)))
410 (equal (setq aa (or (funcall (car handler) aa)
413 (setq handler (cdr handler))))))
417 (defmacro math-defsimplify (funcs &rest code)
421 (list 'put (list 'quote func) ''math-simplify
423 (list 'get (list 'quote func) ''math-simplify)
426 (append '(lambda (math-simplify-expr))
428 (if (symbolp funcs) (list funcs) funcs))))
429 (put 'math-defsimplify 'lisp-indent-hook 1)
431 ;; The function created by math-defsimplify uses the variable
432 ;; math-simplify-expr, and so is used by functions in math-defsimplify
433 (defvar math-simplify-expr)
435 (math-defsimplify (+ -)
436 (math-simplify-plus))
438 (defun math-simplify-plus ()
439 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
440 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
441 (not (Math-numberp (nth 2 math-simplify-expr))))
442 (let ((x (nth 2 math-simplify-expr))
443 (op (car math-simplify-expr)))
444 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
445 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
446 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
447 (setcar (nth 1 math-simplify-expr) op)))
448 ((and (eq (car math-simplify-expr) '+)
449 (Math-numberp (nth 1 math-simplify-expr))
450 (not (Math-numberp (nth 2 math-simplify-expr))))
451 (let ((x (nth 2 math-simplify-expr)))
452 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
453 (setcar (cdr math-simplify-expr) x))))
454 (let ((aa math-simplify-expr)
456 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
457 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
459 (eq (car math-simplify-expr) '-) t))
461 (setcar (cdr (cdr math-simplify-expr)) temp)
462 (setcar math-simplify-expr '+)
463 (setcar (cdr (cdr aaa)) 0)))
464 (setq aa (nth 1 aa)))
465 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
466 nil (eq (car math-simplify-expr) '-) t))
468 (setcar (cdr (cdr math-simplify-expr)) temp)
469 (setcar math-simplify-expr '+)
470 (setcar (cdr aa) 0)))
474 (math-simplify-times))
476 (defun math-simplify-times ()
477 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
478 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
479 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
480 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
481 (let ((x (nth 1 math-simplify-expr)))
482 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
483 (setcar (cdr (nth 2 math-simplify-expr)) x)))
484 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
485 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
486 (math-known-scalarp (nth 2 math-simplify-expr) t))
487 (let ((x (nth 2 math-simplify-expr)))
488 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
489 (setcar (cdr math-simplify-expr) x))))
490 (let ((aa math-simplify-expr)
492 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
493 (if (and (Math-ratp (nth 1 math-simplify-expr))
494 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
496 (setcar (cdr (cdr math-simplify-expr))
497 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
498 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
499 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
501 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
502 (nth 1 aaa) nil nil t))
504 (setcar (cdr math-simplify-expr) temp)
505 (setcar (cdr aaa) 1)))
506 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
508 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
511 (setcar (cdr math-simplify-expr) temp)
512 (setcar (cdr (cdr aa)) 1)))
513 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
514 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
515 (math-div (math-mul (nth 2 math-simplify-expr)
516 (nth 1 (nth 1 math-simplify-expr)))
517 (nth 2 (nth 1 math-simplify-expr)))
518 math-simplify-expr)))
521 (math-simplify-divide))
523 (defun math-simplify-divide ()
524 (let ((np (cdr math-simplify-expr))
526 (nn (and (or (eq (car math-simplify-expr) '/)
527 (not (Math-realp (nth 2 math-simplify-expr))))
528 (math-common-constant-factor (nth 2 math-simplify-expr))))
532 (setq n (and (or (eq (car math-simplify-expr) '/)
533 (not (Math-realp (nth 1 math-simplify-expr))))
534 (math-common-constant-factor (nth 1 math-simplify-expr))))
535 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
537 (setcar (cdr math-simplify-expr)
538 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
539 (setcar (cdr (cdr math-simplify-expr))
540 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
541 (if (and (math-negp nn)
542 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
543 (setcar math-simplify-expr (nth 1 op))))
544 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
546 (setcar (cdr math-simplify-expr)
547 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
548 (setcar (cdr (cdr math-simplify-expr))
549 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
550 (if (and (math-negp n)
551 (setq op (assq (car math-simplify-expr)
552 calc-tweak-eqn-table)))
553 (setcar math-simplify-expr (nth 1 op))))))))
554 (if (and (eq (car-safe (car np)) '/)
555 (math-known-scalarp (nth 2 math-simplify-expr) t))
557 (setq np (cdr (nth 1 math-simplify-expr)))
558 (while (eq (car-safe (setq n (car np))) '*)
559 (and (math-known-scalarp (nth 2 n) t)
560 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
561 (setq np (cdr (cdr n))))
562 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
564 np (cdr (cdr (nth 1 math-simplify-expr))))))
565 (while (eq (car-safe (setq n (car np))) '*)
566 (and (math-known-scalarp (nth 2 n) t)
567 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
568 (setq np (cdr (cdr n))))
569 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
572 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
573 ;; are local variables for math-simplify-divisor, but are used by
574 ;; math-simplify-one-divisor.
575 (defvar math-simplify-divisor-nover)
576 (defvar math-simplify-divisor-dover)
578 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
579 math-simplify-divisor-dover)
580 (cond ((eq (car-safe (car dp)) '/)
581 (math-simplify-divisor np (cdr (car dp))
582 math-simplify-divisor-nover
583 math-simplify-divisor-dover)
584 (and (math-known-scalarp (nth 1 (car dp)) t)
585 (math-simplify-divisor np (cdr (cdr (car dp)))
586 math-simplify-divisor-nover
587 (not math-simplify-divisor-dover))))
588 ((or (or (eq (car math-simplify-expr) '/)
589 (let ((signs (math-possible-signs (car np))))
590 (or (memq signs '(1 4))
591 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
593 math-living-dangerously)))
594 (math-numberp (car np)))
597 (scalar (math-known-scalarp (car np))))
598 (while (and (eq (car-safe (setq d (car dp))) '*)
600 (math-simplify-one-divisor np (cdr d))
601 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
604 (math-simplify-one-divisor np dp))))))
606 (defun math-simplify-one-divisor (np dp)
607 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
608 math-simplify-divisor-dover t))
612 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
613 (math-known-negp (car dp))
614 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
615 (setcar math-simplify-expr (nth 1 op)))
616 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
618 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
619 (eq (car math-simplify-expr) '/)
620 (eq (car-safe (car dp)) 'calcFunc-sqrt)
621 (Math-integerp (nth 1 (car dp)))
623 (setcar np (math-mul (car np)
624 (list 'calcFunc-sqrt (nth 1 (car dp)))))
625 (setcar dp (nth 1 (car dp))))))))
627 (defun math-common-constant-factor (expr)
628 (if (Math-realp expr)
630 (and (not (memq expr '(0 1 -1)))
632 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
633 (math-common-constant-factor expr)))
634 (if (memq (car expr) '(+ - cplx sdev))
635 (let ((f1 (math-common-constant-factor (nth 1 expr)))
636 (f2 (math-common-constant-factor (nth 2 expr))))
638 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
640 (if (memq (car expr) '(* polar))
641 (math-common-constant-factor (nth 1 expr))
642 (if (eq (car expr) '/)
643 (or (math-common-constant-factor (nth 1 expr))
644 (and (Math-integerp (nth 2 expr))
645 (list 'frac 1 (math-abs (nth 2 expr))))))))))
647 (defun math-cancel-common-factor (expr val)
648 (if (memq (car-safe expr) '(+ - cplx sdev))
650 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
651 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
653 (if (eq (car-safe expr) '*)
654 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
655 (math-div expr val))))
657 (defun math-frac-gcd (a b)
662 (if (and (Math-integerp a)
665 (and (Math-integerp a) (setq a (list 'frac a 1)))
666 (and (Math-integerp b) (setq b (list 'frac b 1)))
667 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
668 (math-gcd (nth 2 a) (nth 2 b)))))))
673 (defun math-simplify-mod ()
674 (and (Math-realp (nth 2 math-simplify-expr))
675 (Math-posp (nth 2 math-simplify-expr))
676 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
679 (or (math-negp (car lin))
680 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
683 (math-mul (nth 1 lin) (nth 2 lin))
684 (math-mod (car lin) (nth 2 math-simplify-expr)))
685 (nth 2 math-simplify-expr)))
687 (not (math-equal-int (nth 1 lin) 1))
688 (math-num-integerp (nth 1 lin))
689 (math-num-integerp (nth 2 math-simplify-expr))
690 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
691 (not (math-equal-int t1 1))
696 (math-mul (math-div (nth 1 lin) t1)
698 (let ((calc-prefer-frac t))
699 (math-div (car lin) t1)))
700 (math-div (nth 2 math-simplify-expr) t1))))
701 (and (math-equal-int (nth 2 math-simplify-expr) 1)
702 (math-known-integerp (if lin
703 (math-mul (nth 1 lin) (nth 2 lin))
704 (nth 1 math-simplify-expr)))
705 (if lin (math-mod (car lin) 1) 0))))))
707 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
708 calcFunc-gt calcFunc-leq calcFunc-geq)
709 (if (= (length math-simplify-expr) 3)
710 (math-simplify-ineq)))
712 (defun math-simplify-ineq ()
713 (let ((np (cdr math-simplify-expr))
715 (while (memq (car-safe (setq n (car np))) '(+ -))
716 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
719 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
720 (eq np (cdr math-simplify-expr)))
721 (math-simplify-divide)
722 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
723 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
724 (or (and (eq signs 2) 1)
725 (and (memq signs '(1 4 5)) 0)))
726 ((eq (car math-simplify-expr) 'calcFunc-neq)
727 (or (and (eq signs 2) 0)
728 (and (memq signs '(1 4 5)) 1)))
729 ((eq (car math-simplify-expr) 'calcFunc-lt)
730 (or (and (eq signs 1) 1)
731 (and (memq signs '(2 4 6)) 0)))
732 ((eq (car math-simplify-expr) 'calcFunc-gt)
733 (or (and (eq signs 4) 1)
734 (and (memq signs '(1 2 3)) 0)))
735 ((eq (car math-simplify-expr) 'calcFunc-leq)
736 (or (and (eq signs 4) 0)
737 (and (memq signs '(1 2 3)) 1)))
738 ((eq (car math-simplify-expr) 'calcFunc-geq)
739 (or (and (eq signs 1) 0)
740 (and (memq signs '(2 4 6)) 1))))
741 math-simplify-expr))))
743 (defun math-simplify-add-term (np dp minus lplain)
744 (or (math-vectorp (car np))
747 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
749 (if (setq temp (math-combine-sum n (nth 2 d)
750 minus (eq (car d) '+) t))
751 (if (or lplain (eq (math-looks-negp temp) minus))
753 (setcar np (setq n (if minus (math-neg temp) temp)))
754 (setcar (cdr (cdr d)) 0))
757 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
761 (if (setq temp (math-combine-sum n d minus t t))
764 (eq (math-looks-negp temp) minus)))
766 (setcar np (setq n (if minus (math-neg temp) temp)))
770 (setcar dp (setq n (math-neg temp)))))))))
772 (math-defsimplify calcFunc-sin
773 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
774 (nth 1 (nth 1 math-simplify-expr)))
775 (and (math-looks-negp (nth 1 math-simplify-expr))
776 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
777 (and (eq calc-angle-mode 'rad)
778 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
780 (math-known-sin (car n) (nth 1 n) 120 0))))
781 (and (eq calc-angle-mode 'deg)
782 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
784 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
785 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
786 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
787 (nth 1 (nth 1 math-simplify-expr))))))
788 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
789 (math-div (nth 1 (nth 1 math-simplify-expr))
791 (math-add 1 (math-sqr
792 (nth 1 (nth 1 math-simplify-expr)))))))
793 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
794 (and m (integerp (car m))
795 (let ((n (car m)) (a (nth 1 m)))
797 (list '* (list 'calcFunc-sin (list '* (1- n) a))
798 (list 'calcFunc-cos a))
799 (list '* (list 'calcFunc-cos (list '* (1- n) a))
800 (list 'calcFunc-sin a))))))))
802 (math-defsimplify calcFunc-cos
803 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
804 (nth 1 (nth 1 math-simplify-expr)))
805 (and (math-looks-negp (nth 1 math-simplify-expr))
806 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
807 (and (eq calc-angle-mode 'rad)
808 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
810 (math-known-sin (car n) (nth 1 n) 120 300))))
811 (and (eq calc-angle-mode 'deg)
812 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
814 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
815 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
817 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
818 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
822 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
823 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
824 (and m (integerp (car m))
825 (let ((n (car m)) (a (nth 1 m)))
827 (list '* (list 'calcFunc-cos (list '* (1- n) a))
828 (list 'calcFunc-cos a))
829 (list '* (list 'calcFunc-sin (list '* (1- n) a))
830 (list 'calcFunc-sin a))))))))
832 (math-defsimplify calcFunc-sec
833 (or (and (math-looks-negp (nth 1 math-simplify-expr))
834 (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
835 (and (eq calc-angle-mode 'rad)
836 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
838 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
839 (and (eq calc-angle-mode 'deg)
840 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
842 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
843 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
847 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
848 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
851 (nth 1 (nth 1 math-simplify-expr))))
852 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
855 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
857 (math-defsimplify calcFunc-csc
858 (or (and (math-looks-negp (nth 1 math-simplify-expr))
859 (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
860 (and (eq calc-angle-mode 'rad)
861 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
863 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
864 (and (eq calc-angle-mode 'deg)
865 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
867 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
868 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
869 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
870 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
873 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
874 (nth 1 (nth 1 math-simplify-expr)))))))
875 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
876 (math-div (list 'calcFunc-sqrt
877 (math-add 1 (math-sqr
878 (nth 1 (nth 1 math-simplify-expr)))))
879 (nth 1 (nth 1 math-simplify-expr))))))
881 (defun math-should-expand-trig (x &optional hyperbolic)
882 (let ((m (math-is-multiple x)))
883 (and math-living-dangerously
884 m (or (and (integerp (car m)) (> (car m) 1))
885 (equal (car m) '(frac 1 2)))
887 (memq (car-safe (nth 1 m))
889 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
890 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
891 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
892 (eq hyperbolic 'exp)))
895 (defun math-known-sin (plus n mul off)
896 (setq n (math-mul n mul))
897 (and (math-num-integerp n)
898 (setq n (math-mod (math-add (math-trunc n) off) 240))
900 (and (setq n (math-known-sin plus (- n 120) 1 0))
904 (if (math-zerop plus)
905 (and (or calc-symbolic-mode
909 (10 . (/ (calcFunc-sqrt
910 (- 2 (calcFunc-sqrt 3))) 2))
911 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
912 (15 . (/ (calcFunc-sqrt
913 (- 2 (calcFunc-sqrt 2))) 2))
915 (24 . (* (^ (/ 1 2) (/ 3 2))
917 (- 5 (calcFunc-sqrt 5)))))
918 (30 . (/ (calcFunc-sqrt 2) 2))
919 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
920 (40 . (/ (calcFunc-sqrt 3) 2))
921 (45 . (/ (calcFunc-sqrt
922 (+ 2 (calcFunc-sqrt 2))) 2))
923 (48 . (* (^ (/ 1 2) (/ 3 2))
925 (+ 5 (calcFunc-sqrt 5)))))
926 (50 . (/ (calcFunc-sqrt
927 (+ 2 (calcFunc-sqrt 3))) 2))
929 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
930 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
933 (math-defsimplify calcFunc-tan
934 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
935 (nth 1 (nth 1 math-simplify-expr)))
936 (and (math-looks-negp (nth 1 math-simplify-expr))
937 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
938 (and (eq calc-angle-mode 'rad)
939 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
941 (math-known-tan (car n) (nth 1 n) 120))))
942 (and (eq calc-angle-mode 'deg)
943 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
945 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
946 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
947 (math-div (nth 1 (nth 1 math-simplify-expr))
949 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
950 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
951 (math-div (list 'calcFunc-sqrt
952 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
953 (nth 1 (nth 1 math-simplify-expr))))
954 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
956 (if (equal (car m) '(frac 1 2))
957 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
958 (list 'calcFunc-sin (nth 1 m)))
959 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
960 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
962 (math-defsimplify calcFunc-cot
963 (or (and (math-looks-negp (nth 1 math-simplify-expr))
964 (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
965 (and (eq calc-angle-mode 'rad)
966 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
968 (math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
969 (and (eq calc-angle-mode 'deg)
970 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
972 (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
973 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
974 (math-div (list 'calcFunc-sqrt
975 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
976 (nth 1 (nth 1 math-simplify-expr))))
977 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
978 (math-div (nth 1 (nth 1 math-simplify-expr))
980 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
981 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
982 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
984 (defun math-known-tan (plus n mul)
985 (setq n (math-mul n mul))
986 (and (math-num-integerp n)
987 (setq n (math-mod (math-trunc n) 120))
989 (and (setq n (math-known-tan plus (- 120 n) 1))
991 (if (math-zerop plus)
992 (and (or calc-symbolic-mode
994 (cdr (assq n '( (0 . 0)
995 (10 . (- 2 (calcFunc-sqrt 3)))
997 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
998 (15 . (- (calcFunc-sqrt 2) 1))
999 (20 . (/ (calcFunc-sqrt 3) 3))
1000 (24 . (calcFunc-sqrt
1001 (- 5 (* 2 (calcFunc-sqrt 5)))))
1003 (36 . (calcFunc-sqrt
1004 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1005 (40 . (calcFunc-sqrt 3))
1006 (45 . (+ (calcFunc-sqrt 2) 1))
1007 (48 . (calcFunc-sqrt
1008 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1009 (50 . (+ 2 (calcFunc-sqrt 3)))
1010 (60 . (var uinf var-uinf))))))
1011 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
1012 ((eq n 60) (math-normalize (list '/ -1
1013 (list 'calcFunc-tan plus))))
1016 (math-defsimplify calcFunc-sinh
1017 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1018 (nth 1 (nth 1 math-simplify-expr)))
1019 (and (math-looks-negp (nth 1 math-simplify-expr))
1020 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
1021 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1022 math-living-dangerously
1023 (list 'calcFunc-sqrt
1024 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1025 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1026 math-living-dangerously
1027 (math-div (nth 1 (nth 1 math-simplify-expr))
1028 (list 'calcFunc-sqrt
1029 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1030 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1031 (and m (integerp (car m))
1032 (let ((n (car m)) (a (nth 1 m)))
1035 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1036 (list 'calcFunc-cosh a))
1037 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1038 (list 'calcFunc-sinh a)))))))))
1040 (math-defsimplify calcFunc-cosh
1041 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1042 (nth 1 (nth 1 math-simplify-expr)))
1043 (and (math-looks-negp (nth 1 math-simplify-expr))
1044 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
1045 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1046 math-living-dangerously
1047 (list 'calcFunc-sqrt
1048 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1049 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1050 math-living-dangerously
1052 (list 'calcFunc-sqrt
1053 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1054 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1055 (and m (integerp (car m))
1056 (let ((n (car m)) (a (nth 1 m)))
1059 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1060 (list 'calcFunc-cosh a))
1061 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1062 (list 'calcFunc-sinh a)))))))))
1064 (math-defsimplify calcFunc-tanh
1065 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1066 (nth 1 (nth 1 math-simplify-expr)))
1067 (and (math-looks-negp (nth 1 math-simplify-expr))
1068 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
1069 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1070 math-living-dangerously
1071 (math-div (nth 1 (nth 1 math-simplify-expr))
1072 (list 'calcFunc-sqrt
1073 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1074 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1075 math-living-dangerously
1076 (math-div (list 'calcFunc-sqrt
1077 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1078 (nth 1 (nth 1 math-simplify-expr))))
1079 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1081 (if (equal (car m) '(frac 1 2))
1082 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
1083 (list 'calcFunc-sinh (nth 1 m)))
1084 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
1085 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
1087 (math-defsimplify calcFunc-sech
1088 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1089 (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
1090 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1091 math-living-dangerously
1094 (list 'calcFunc-sqrt
1095 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1096 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1097 math-living-dangerously
1098 (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
1099 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1100 math-living-dangerously
1101 (list 'calcFunc-sqrt
1102 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
1104 (math-defsimplify calcFunc-csch
1105 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1106 (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
1107 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1108 math-living-dangerously
1109 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
1110 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1111 math-living-dangerously
1114 (list 'calcFunc-sqrt
1115 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1116 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1117 math-living-dangerously
1118 (math-div (list 'calcFunc-sqrt
1119 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
1120 (nth 1 (nth 1 math-simplify-expr))))))
1122 (math-defsimplify calcFunc-coth
1123 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1124 (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
1125 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1126 math-living-dangerously
1127 (math-div (list 'calcFunc-sqrt
1128 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1129 (nth 1 (nth 1 math-simplify-expr))))
1130 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1131 math-living-dangerously
1132 (math-div (nth 1 (nth 1 math-simplify-expr))
1133 (list 'calcFunc-sqrt
1134 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1135 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1136 math-living-dangerously
1137 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
1139 (math-defsimplify calcFunc-arcsin
1140 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1141 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
1142 (and (eq (nth 1 math-simplify-expr) 1)
1143 (math-quarter-circle t))
1144 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1145 (math-div (math-half-circle t) 6))
1146 (and math-living-dangerously
1147 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1148 (nth 1 (nth 1 math-simplify-expr)))
1149 (and math-living-dangerously
1150 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1151 (math-sub (math-quarter-circle t)
1152 (nth 1 (nth 1 math-simplify-expr))))))
1154 (math-defsimplify calcFunc-arccos
1155 (or (and (eq (nth 1 math-simplify-expr) 0)
1156 (math-quarter-circle t))
1157 (and (eq (nth 1 math-simplify-expr) -1)
1158 (math-half-circle t))
1159 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1160 (math-div (math-half-circle t) 3))
1161 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
1162 (math-div (math-mul (math-half-circle t) 2) 3))
1163 (and math-living-dangerously
1164 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1165 (nth 1 (nth 1 math-simplify-expr)))
1166 (and math-living-dangerously
1167 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1168 (math-sub (math-quarter-circle t)
1169 (nth 1 (nth 1 math-simplify-expr))))))
1171 (math-defsimplify calcFunc-arctan
1172 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1173 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
1174 (and (eq (nth 1 math-simplify-expr) 1)
1175 (math-div (math-half-circle t) 4))
1176 (and math-living-dangerously
1177 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
1178 (nth 1 (nth 1 math-simplify-expr)))))
1180 (math-defsimplify calcFunc-arcsinh
1181 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1182 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
1183 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
1184 (or math-living-dangerously
1185 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1186 (nth 1 (nth 1 math-simplify-expr)))))
1188 (math-defsimplify calcFunc-arccosh
1189 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1190 (or math-living-dangerously
1191 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1192 (nth 1 (nth 1 math-simplify-expr))))
1194 (math-defsimplify calcFunc-arctanh
1195 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1196 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
1197 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
1198 (or math-living-dangerously
1199 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1200 (nth 1 (nth 1 math-simplify-expr)))))
1202 (math-defsimplify calcFunc-sqrt
1203 (math-simplify-sqrt))
1205 (defun math-simplify-sqrt ()
1206 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
1207 (math-div (list 'calcFunc-sqrt
1208 (math-mul (nth 1 (nth 1 math-simplify-expr))
1209 (nth 2 (nth 1 math-simplify-expr))))
1210 (nth 2 (nth 1 math-simplify-expr))))
1211 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1212 (math-squared-factor (nth 1 math-simplify-expr))
1213 (math-common-constant-factor (nth 1 math-simplify-expr)))))
1214 (and fac (not (eq fac 1))
1215 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1217 (list 'calcFunc-sqrt
1218 (math-cancel-common-factor
1219 (nth 1 math-simplify-expr) fac))))))
1220 (and math-living-dangerously
1221 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1222 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1223 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1224 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1225 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1228 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1229 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1232 (nth 1 (nth 1 (nth 2
1233 (nth 1 math-simplify-expr))))))))
1234 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1235 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1236 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1237 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1238 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
1240 (list 'calcFunc-sinh
1241 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1242 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1243 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1244 (b (nth 2 (nth 1 math-simplify-expr))))
1245 (and (or (and (math-equal-int a 1)
1246 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
1247 (math-equal-int b 1))
1248 (eq (car-safe a) '^)
1249 (math-equal-int (nth 2 a) 2)
1250 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1251 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
1252 (and (eq (car-safe (nth 1 a)) 'calcFunc-csch)
1253 (list 'calcFunc-coth (nth 1 (nth 1 a))))
1254 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1255 (list '/ 1 (list 'calcFunc-cos
1256 (nth 1 (nth 1 a)))))
1257 (and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
1258 (list '/ 1 (list 'calcFunc-sin
1259 (nth 1 (nth 1 a)))))))))
1260 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1262 (nth 1 (nth 1 math-simplify-expr))
1263 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1264 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1265 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1266 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1267 (list (car (nth 1 math-simplify-expr))
1268 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1269 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1270 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1271 (not (math-any-floats (nth 1 math-simplify-expr)))
1272 (let ((f (calcFunc-factors (calcFunc-expand
1273 (nth 1 math-simplify-expr)))))
1274 (and (math-vectorp f)
1275 (or (> (length f) 2)
1276 (> (nth 2 (nth 1 f)) 1))
1277 (let ((out 1) (rest 1) (sums 1) fac pow)
1278 (while (setq f (cdr f))
1279 (setq fac (nth 1 (car f))
1280 pow (nth 2 (car f)))
1282 (setq out (math-mul out (math-pow
1286 (if (memq (car-safe fac) '(+ -))
1287 (setq sums (math-mul-thru sums fac))
1288 (setq rest (math-mul rest fac)))))
1289 (and (not (and (eq out 1) (memq rest '(1 -1))))
1292 (list 'calcFunc-sqrt
1293 (math-mul sums rest))))))))))))
1295 ;;; Rather than factoring x into primes, just check for the first ten primes.
1296 (defun math-squared-factor (x)
1297 (if (Math-integerp x)
1298 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1302 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1304 fac (math-mul fac (car prsqr)))
1305 (setq prsqr (cdr prsqr))))
1308 (math-defsimplify calcFunc-exp
1309 (math-simplify-exp (nth 1 math-simplify-expr)))
1311 (defun math-simplify-exp (x)
1312 (or (and (eq (car-safe x) 'calcFunc-ln)
1314 (and math-living-dangerously
1315 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1317 (list 'calcFunc-sqrt
1318 (math-add (math-sqr (nth 1 x)) 1))))
1319 (and (eq (car-safe x) 'calcFunc-arccosh)
1321 (list 'calcFunc-sqrt
1322 (math-sub (math-sqr (nth 1 x)) 1))))
1323 (and (eq (car-safe x) 'calcFunc-arctanh)
1324 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1325 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1326 (let ((m (math-should-expand-trig x 'exp)))
1327 (and m (integerp (car m))
1328 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1329 (and calc-symbolic-mode
1330 (math-known-imagp x)
1331 (let* ((ip (calcFunc-im x))
1332 (n (math-linear-in ip '(var pi var-pi)))
1335 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1336 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
1337 (list '+ c (list '* s '(var i var-i))))))))
1339 (math-defsimplify calcFunc-ln
1340 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1341 (or math-living-dangerously
1342 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1343 (nth 1 (nth 1 math-simplify-expr)))
1344 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1345 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
1346 (or math-living-dangerously
1347 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1348 (nth 2 (nth 1 math-simplify-expr)))
1349 (and calc-symbolic-mode
1350 (math-known-negp (nth 1 math-simplify-expr))
1351 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
1352 '(* (var pi var-pi) (var i var-i))))
1353 (and calc-symbolic-mode
1354 (math-known-imagp (nth 1 math-simplify-expr))
1355 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
1356 (ips (math-possible-signs ip)))
1357 (or (and (memq ips '(4 6))
1358 (math-add (list 'calcFunc-ln ip)
1359 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1360 (and (memq ips '(1 3))
1361 (math-sub (list 'calcFunc-ln (math-neg ip))
1362 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
1365 (math-simplify-pow))
1367 (defun math-simplify-pow ()
1368 (or (and math-living-dangerously
1369 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1371 (nth 1 (nth 1 math-simplify-expr))
1372 (math-mul (nth 2 math-simplify-expr)
1373 (nth 2 (nth 1 math-simplify-expr)))))
1374 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1376 (nth 1 (nth 1 math-simplify-expr))
1377 (math-div (nth 2 math-simplify-expr) 2)))
1378 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1379 (list (car (nth 1 math-simplify-expr))
1380 (list '^ (nth 1 (nth 1 math-simplify-expr))
1381 (nth 2 math-simplify-expr))
1382 (list '^ (nth 2 (nth 1 math-simplify-expr))
1383 (nth 2 math-simplify-expr))))))
1384 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1385 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1386 (nth 1 (nth 2 math-simplify-expr)))
1387 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1388 (math-simplify-exp (nth 2 math-simplify-expr)))
1389 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1390 (not math-integrating)
1391 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
1392 (nth 2 math-simplify-expr))))
1393 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
1395 (math-num-integerp (nth 2 math-simplify-expr))
1396 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
1398 ((eq x 1) (nth 1 math-simplify-expr))
1400 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
1401 (and math-integrating
1402 (integerp (nth 2 math-simplify-expr))
1403 (>= (nth 2 math-simplify-expr) 2)
1404 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1405 (math-mul (math-pow (nth 1 math-simplify-expr)
1406 (- (nth 2 math-simplify-expr) 2))
1410 (nth 1 (nth 1 math-simplify-expr)))))))
1411 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1412 (math-mul (math-pow (nth 1 math-simplify-expr)
1413 (- (nth 2 math-simplify-expr) 2))
1416 (list 'calcFunc-sinh
1417 (nth 1 (nth 1 math-simplify-expr)))))))))
1418 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1419 (Math-ratp (nth 1 math-simplify-expr))
1420 (Math-posp (nth 1 math-simplify-expr))
1421 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1422 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1423 (let ((flr (math-floor (nth 2 math-simplify-expr))))
1424 (and (not (Math-zerop flr))
1425 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1426 (list '^ (nth 1 math-simplify-expr)
1427 (math-sub (nth 2 math-simplify-expr) flr)))))))
1428 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
1429 (let ((temp (math-simplify-sqrt)))
1431 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
1433 (math-defsimplify calcFunc-log10
1434 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1435 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
1436 (or math-living-dangerously
1437 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1438 (nth 2 (nth 1 math-simplify-expr))))
1441 (math-defsimplify calcFunc-erf
1442 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1443 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1444 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1445 (list 'calcFunc-conj
1446 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
1448 (math-defsimplify calcFunc-erfc
1449 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1450 (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
1451 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1452 (list 'calcFunc-conj
1453 (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
1456 (defun math-linear-in (expr term &optional always)
1457 (if (math-expr-contains expr term)
1458 (let* ((calc-prefer-frac t)
1459 (p (math-is-polynomial expr term 1)))
1462 (and always (list expr 0))))
1464 (defun math-multiple-of (expr term)
1465 (let ((p (math-linear-in expr term)))
1467 (math-zerop (car p))
1470 ; not perfect, but it'll do
1471 (defun math-integer-plus (expr)
1472 (cond ((Math-integerp expr)
1474 ((and (memq (car expr) '(+ -))
1475 (Math-integerp (nth 1 expr)))
1476 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1478 ((and (memq (car expr) '(+ -))
1479 (Math-integerp (nth 2 expr)))
1481 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
1484 (defun math-is-linear (expr &optional always)
1487 (if (eq (car-safe expr) '+)
1488 (if (Math-objectp (nth 1 expr))
1489 (setq offset (nth 1 expr)
1491 (if (Math-objectp (nth 2 expr))
1492 (setq offset (nth 2 expr)
1493 expr (nth 1 expr))))
1494 (if (eq (car-safe expr) '-)
1495 (if (Math-objectp (nth 1 expr))
1496 (setq offset (nth 1 expr)
1497 expr (math-neg (nth 2 expr)))
1498 (if (Math-objectp (nth 2 expr))
1499 (setq offset (math-neg (nth 2 expr))
1500 expr (nth 1 expr))))))
1501 (setq coef (math-is-multiple expr always))
1503 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1507 (defun math-is-multiple (expr &optional always)
1508 (or (if (eq (car-safe expr) '*)
1509 (if (Math-objectp (nth 1 expr))
1510 (list (nth 1 expr) (nth 2 expr)))
1511 (if (eq (car-safe expr) '/)
1512 (if (and (Math-objectp (nth 1 expr))
1513 (not (math-equal-int (nth 1 expr) 1)))
1514 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1515 (if (Math-objectp (nth 2 expr))
1516 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1517 (let ((res (math-is-multiple (nth 1 expr))))
1520 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1521 (setq res (math-is-multiple (nth 2 expr)))
1523 (list (math-div 1 (car res))
1524 (math-div (nth 1 expr)
1525 (nth 2 (nth 2 expr)))))))))
1526 (if (eq (car-safe expr) 'neg)
1527 (list -1 (nth 1 expr)))))
1528 (if (Math-objvecp expr)
1534 (defun calcFunc-lin (expr &optional var)
1536 (let ((res (math-linear-in expr var t)))
1537 (or res (math-reject-arg expr "Linear term expected"))
1538 (list 'vec (car res) (nth 1 res) var))
1539 (let ((res (math-is-linear expr t)))
1540 (or res (math-reject-arg expr "Linear term expected"))
1543 (defun calcFunc-linnt (expr &optional var)
1545 (let ((res (math-linear-in expr var)))
1546 (or res (math-reject-arg expr "Linear term expected"))
1547 (list 'vec (car res) (nth 1 res) var))
1548 (let ((res (math-is-linear expr)))
1549 (or res (math-reject-arg expr "Linear term expected"))
1552 (defun calcFunc-islin (expr &optional var)
1553 (if (and (Math-objvecp expr) (not var))
1555 (calcFunc-lin expr var)
1558 (defun calcFunc-islinnt (expr &optional var)
1559 (if (Math-objvecp expr)
1561 (calcFunc-linnt expr var)
1567 ;;; Simple operations on expressions.
1569 ;;; Return number of occurrences of thing in expr, or nil if none.
1570 (defun math-expr-contains-count (expr thing)
1571 (cond ((equal expr thing) 1)
1572 ((Math-primp expr) nil)
1575 (while (setq expr (cdr expr))
1576 (setq num (+ num (or (math-expr-contains-count
1577 (car expr) thing) 0))))
1581 (defun math-expr-contains (expr thing)
1582 (cond ((equal expr thing) 1)
1583 ((Math-primp expr) nil)
1585 (while (and (setq expr (cdr expr))
1586 (not (math-expr-contains (car expr) thing))))
1589 ;;; Return non-nil if any variable of thing occurs in expr.
1590 (defun math-expr-depends (expr thing)
1591 (if (Math-primp thing)
1592 (and (eq (car-safe thing) 'var)
1593 (math-expr-contains expr thing))
1594 (while (and (setq thing (cdr thing))
1595 (not (math-expr-depends expr (car thing)))))
1598 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1600 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1601 ;; for math-expr-subst, but used by math-expr-subst-rec.
1602 (defvar math-expr-subst-old)
1603 (defvar math-expr-subst-new)
1605 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
1606 (math-expr-subst-rec expr))
1608 (defalias 'calcFunc-subst 'math-expr-subst)
1610 (defun math-expr-subst-rec (expr)
1611 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
1612 ((Math-primp expr) expr)
1613 ((memq (car expr) '(calcFunc-deriv
1615 (if (= (length expr) 2)
1616 (if (equal (nth 1 expr) math-expr-subst-old)
1617 (append expr (list math-expr-subst-new))
1619 (list (car expr) (nth 1 expr)
1620 (math-expr-subst-rec (nth 2 expr)))))
1623 (mapcar 'math-expr-subst-rec (cdr expr))))))
1625 ;;; Various measures of the size of an expression.
1626 (defun math-expr-weight (expr)
1627 (if (Math-primp expr)
1630 (while (setq expr (cdr expr))
1631 (setq w (+ w (math-expr-weight (car expr)))))
1634 (defun math-expr-height (expr)
1635 (if (Math-primp expr)
1638 (while (setq expr (cdr expr))
1639 (setq h (max h (math-expr-height (car expr)))))
1645 ;;; Polynomial operations (to support the integrator and solve-for).
1647 (defun calcFunc-collect (expr base)
1648 (let ((p (math-is-polynomial expr base 50 t)))
1650 (math-build-polynomial-expr (mapcar 'math-normalize p) base)
1653 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1654 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1655 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1657 ;; These variables are local to math-is-polynomial, but are used by
1658 ;; math-is-poly-rec.
1659 (defvar math-is-poly-degree)
1660 (defvar math-is-poly-loose)
1663 (defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose)
1664 (let* ((math-poly-base-variable (if math-is-poly-loose
1665 (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX))
1666 math-poly-base-variable))
1667 (poly (math-is-poly-rec expr math-poly-neg-powers)))
1668 (and (or (null math-is-poly-degree)
1669 (<= (length poly) (1+ math-is-poly-degree)))
1672 (defun math-is-poly-rec (expr negpow)
1674 (or (cond ((or (equal expr math-var)
1675 (eq (car-safe expr) '^))
1678 (or (equal expr math-var)
1679 (setq pow (nth 2 expr)
1681 (or (eq math-poly-mult-powers 1)
1682 (setq pow (let ((m (math-is-multiple pow 1)))
1683 (and (eq (car-safe (car m)) 'cplx)
1684 (Math-zerop (nth 1 (car m)))
1685 (setq m (list (nth 2 (car m))
1688 (and (if math-poly-mult-powers
1689 (equal math-poly-mult-powers
1691 (setq math-poly-mult-powers (nth 1 m)))
1692 (or (equal expr math-var)
1693 (eq math-poly-mult-powers 1))
1697 (setq pow (math-to-simple-fraction pow))
1698 (and (eq (car-safe pow) 'frac)
1699 math-poly-frac-powers
1700 (equal expr math-var)
1701 (setq math-poly-frac-powers
1702 (calcFunc-lcm math-poly-frac-powers
1704 (or (memq math-poly-frac-powers '(1 nil))
1705 (setq pow (math-mul pow math-poly-frac-powers)))
1708 (equal expr math-var))
1711 (let ((p1 (if (equal expr math-var)
1713 (math-is-poly-rec expr nil)))
1717 (or (null math-is-poly-degree)
1718 (<= (* (1- (length p1)) n) math-is-poly-degree))
1721 (setq accum (math-poly-mul accum p1)
1725 (math-is-poly-rec expr nil)
1726 (setq math-poly-neg-powers
1727 (cons (math-pow expr (- pow))
1728 math-poly-neg-powers))
1729 (list (list '^ expr pow))))))))
1730 ((Math-objectp expr)
1732 ((memq (car expr) '(+ -))
1733 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1735 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1737 (math-poly-mix p1 1 p2
1738 (if (eq (car expr) '+) 1 -1)))))))
1739 ((eq (car expr) 'neg)
1740 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1742 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1744 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1746 (or (null math-is-poly-degree)
1747 (<= (- (+ (length p1) (length p2)) 2)
1748 math-is-poly-degree))
1749 (math-poly-mul p1 p2))))))
1751 (and (or (not (math-poly-depends (nth 2 expr) math-var))
1753 (math-is-poly-rec (nth 2 expr) nil)
1754 (setq math-poly-neg-powers
1755 (cons (nth 2 expr) math-poly-neg-powers))))
1756 (not (Math-zerop (nth 2 expr)))
1757 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1758 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1760 ((and (eq (car expr) 'calcFunc-exp)
1761 (equal math-var '(var e var-e)))
1762 (math-is-poly-rec (list '^ math-var (nth 1 expr)) negpow))
1763 ((and (eq (car expr) 'calcFunc-sqrt)
1764 math-poly-frac-powers)
1765 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1767 (and (or (not (math-poly-depends expr math-var))
1769 (not (eq (car expr) 'vec))
1772 ;;; Check if expr is a polynomial in var; if so, return its degree.
1773 (defun math-polynomial-p (expr var)
1774 (cond ((equal expr var) 1)
1775 ((Math-primp expr) 0)
1776 ((memq (car expr) '(+ -))
1777 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1779 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1782 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1784 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1786 ((eq (car expr) 'neg)
1787 (math-polynomial-p (nth 1 expr) var))
1788 ((and (eq (car expr) '/)
1789 (not (math-poly-depends (nth 2 expr) var)))
1790 (math-polynomial-p (nth 1 expr) var))
1791 ((and (eq (car expr) '^)
1792 (natnump (nth 2 expr)))
1793 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1794 (and p1 (* p1 (nth 2 expr)))))
1795 ((math-poly-depends expr var) nil)
1798 (defun math-poly-depends (expr var)
1799 (if math-poly-base-variable
1800 (math-expr-contains expr math-poly-base-variable)
1801 (math-expr-depends expr var)))
1803 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1804 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1805 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1806 (defvar math-poly-base-const-ok)
1807 (defvar math-poly-base-pred)
1809 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1810 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1811 ;; by math-polynomial-base.
1813 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
1814 (or math-poly-base-pred
1815 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
1816 math-poly-base-top-expr base)))))
1817 (or (let ((math-poly-base-const-ok nil))
1818 (math-polynomial-base-rec math-poly-base-top-expr))
1819 (let ((math-poly-base-const-ok t))
1820 (math-polynomial-base-rec math-poly-base-top-expr))))
1822 (defun math-polynomial-base-rec (mpb-expr)
1823 (and (not (Math-objvecp mpb-expr))
1824 (or (and (memq (car mpb-expr) '(+ - *))
1825 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1826 (math-polynomial-base-rec (nth 2 mpb-expr))))
1827 (and (memq (car mpb-expr) '(/ neg))
1828 (math-polynomial-base-rec (nth 1 mpb-expr)))
1829 (and (eq (car mpb-expr) '^)
1830 (math-polynomial-base-rec (nth 1 mpb-expr)))
1831 (and (eq (car mpb-expr) 'calcFunc-exp)
1832 (math-polynomial-base-rec '(var e var-e)))
1833 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1834 (funcall math-poly-base-pred mpb-expr)
1837 ;;; Return non-nil if expr refers to any variables.
1838 (defun math-expr-contains-vars (expr)
1839 (or (eq (car-safe expr) 'var)
1840 (and (not (Math-primp expr))
1842 (while (and (setq expr (cdr expr))
1843 (not (math-expr-contains-vars (car expr)))))
1846 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1847 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1848 (defun math-poly-simplify (p)
1850 (if (Math-zerop (nth (1- (length p)) p))
1851 (let ((pp (copy-sequence p)))
1852 (while (and (cdr pp)
1853 (Math-zerop (nth (1- (length pp)) pp)))
1854 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1858 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1859 ;;; coefficients ac, bc. Result may be unsimplified.
1860 (defun math-poly-mix (a ac b bc)
1862 (cons (math-add (math-mul (or (car a) 0) ac)
1863 (math-mul (or (car b) 0) bc))
1864 (math-poly-mix (cdr a) ac (cdr b) bc))))
1866 (defun math-poly-zerop (a)
1868 (and (null (cdr a)) (Math-zerop (car a)))))
1870 ;;; Multiply two polynomials in list form.
1871 (defun math-poly-mul (a b)
1873 (math-poly-mix b (car a)
1874 (math-poly-mul (cdr a) (cons 0 b)) 1)))
1876 ;;; Build an expression from a polynomial list.
1877 (defun math-build-polynomial-expr (p var)
1879 (if (Math-numberp var)
1880 (math-with-extra-prec 1
1881 (let* ((rp (reverse p))
1883 (while (setq rp (cdr rp))
1884 (setq accum (math-add (car rp) (math-mul accum var))))
1886 (let* ((rp (reverse p))
1887 (n (1- (length rp)))
1888 (accum (math-mul (car rp) (math-pow var n)))
1890 (while (setq rp (cdr rp))
1892 (or (math-zerop (car rp))
1893 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1895 (math-mul (if (math-looks-negp (car rp))
1898 (math-pow var n))))))
1903 (defun math-to-simple-fraction (f)
1904 (or (and (eq (car-safe f) 'float)
1905 (or (and (>= (nth 2 f) 0)
1906 (math-scale-int (nth 1 f) (nth 2 f)))
1907 (and (integerp (nth 1 f))
1910 (math-make-frac (nth 1 f)
1911 (math-scale-int 1 (- (nth 2 f)))))))
1916 ;;; calc-alg.el ends here