1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This file is autoloaded from calc-ext.el.
35 (defun calc-alg-evaluate (arg)
38 (calc-with-default-simplification
39 (let ((math-simplify-only nil))
40 (calc-modify-simplify-mode arg)
41 (calc-enter-result 1 "dsmp" (calc-top 1))))))
43 (defun calc-modify-simplify-mode (arg)
44 (if (= (math-abs arg) 2)
45 (setq calc-simplify-mode 'alg)
46 (if (>= (math-abs arg) 3)
47 (setq calc-simplify-mode 'ext)))
49 (setq calc-simplify-mode (list calc-simplify-mode))))
51 (defun calc-simplify ()
54 (let ((top (calc-top-n 1)))
57 (let ((calc-simplify-mode nil))
58 (math-normalize (math-trig-rewrite top)))))
59 (if (calc-is-hyperbolic)
61 (let ((calc-simplify-mode nil))
62 (math-normalize (math-hyperbolic-trig-rewrite top)))))
63 (calc-with-default-simplification
64 (calc-enter-result 1 "simp" (math-simplify top))))))
66 (defun calc-simplify-extended ()
69 (calc-with-default-simplification
70 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
72 (defun calc-expand-formula (arg)
75 (calc-with-default-simplification
76 (let ((math-simplify-only nil))
77 (calc-modify-simplify-mode arg)
78 (calc-enter-result 1 "expf"
80 (let ((math-expand-formulas t))
82 (let ((top (calc-top-n 1)))
83 (or (math-expand-formula top)
86 (defun calc-factor (arg)
89 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
90 'calcFunc-factors 'calcFunc-factor)
93 (defun calc-expand (n)
96 (calc-enter-result 1 "expa"
97 (append (list 'calcFunc-expand
99 (and n (list (prefix-numeric-value n)))))))
101 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
102 (defun calcFunc-powerexpand (expr)
103 (math-normalize (math-map-tree 'math-powerexpand expr)))
105 (defun math-powerexpand (expr)
106 (if (eq (car-safe expr) '^)
107 (let ((n (nth 2 expr)))
108 (cond ((and (integerp n)
114 (setq prod (math-mul prod a))
120 (a (math-pow (nth 1 expr) -1))
121 (prod (math-pow (nth 1 expr) -1)))
123 (setq prod (math-mul a prod))
130 (defun calc-powerexpand ()
133 (calc-enter-result 1 "pexp"
134 (calcFunc-powerexpand (calc-top-n 1)))))
136 (defun calc-collect (&optional var)
137 (interactive "sCollect terms involving: ")
139 (if (or (equal var "") (equal var "$") (null var))
140 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
141 (calc-top-list-n 2)))
142 (let ((var (math-read-expr var)))
143 (if (eq (car-safe var) 'error)
144 (error "Bad format in expression: %s" (nth 1 var)))
145 (calc-enter-result 1 "clct" (list 'calcFunc-collect
149 (defun calc-apart (arg)
152 (calc-unary-op "aprt" 'calcFunc-apart arg)))
154 (defun calc-normalize-rat (arg)
157 (calc-unary-op "nrat" 'calcFunc-nrat arg)))
159 (defun calc-poly-gcd (arg)
162 (calc-binary-op "pgcd" 'calcFunc-pgcd arg)))
165 (defun calc-poly-div (arg)
168 (let ((calc-poly-div-remainder nil))
169 (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
170 (if (and calc-poly-div-remainder (null arg))
172 (calc-clear-command-flag 'clear-message)
173 (calc-record calc-poly-div-remainder "prem")
174 (if (not (Math-zerop calc-poly-div-remainder))
175 (message "(Remainder was %s)"
176 (math-format-flat-expr calc-poly-div-remainder 0))
177 (message "(No remainder)")))))))
179 (defun calc-poly-rem (arg)
182 (calc-binary-op "prem" 'calcFunc-prem arg)))
184 (defun calc-poly-div-rem (arg)
187 (if (calc-is-hyperbolic)
188 (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
189 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))))
191 (defun calc-substitute (&optional oldname newname)
192 (interactive "sSubstitute old: ")
194 (let (old new (num 1) expr)
195 (if (or (equal oldname "") (equal oldname "$") (null oldname))
196 (setq new (calc-top-n 1)
201 (progn (calc-unread-command ?\C-a)
202 (setq newname (read-string (concat "Substitute old: "
206 (if (or (equal newname "") (equal newname "$") (null newname))
207 (setq new (calc-top-n 1)
210 (setq new (if (stringp newname) (math-read-expr newname) newname))
211 (if (eq (car-safe new) 'error)
212 (error "Bad format in expression: %s" (nth 1 new)))
213 (setq expr (calc-top-n 1)))
214 (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
215 (if (eq (car-safe old) 'error)
216 (error "Bad format in expression: %s" (nth 1 old)))
217 (or (math-expr-contains expr old)
218 (error "No occurrences found")))
219 (calc-enter-result num "sbst" (math-expr-subst expr old new)))))
222 (defun calc-has-rules (name)
223 (setq name (calc-var-value name))
225 (memq (car name) '(vec calcFunc-assign calcFunc-condition))
228 ;; math-eval-rules-cache and math-eval-rules-cache-other are
229 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
230 (defvar math-eval-rules-cache)
231 (defvar math-eval-rules-cache-other)
233 (defun math-recompile-eval-rules ()
234 (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
235 (math-compile-rewrites
236 '(var EvalRules var-EvalRules)))
237 math-eval-rules-cache-other (assq nil math-eval-rules-cache)
238 math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)))
241 ;;; Try to expand a formula according to its definition.
242 (defun math-expand-formula (expr)
245 (or (get (car expr) 'calc-user-defn)
246 (get (car expr) 'math-expandable))
247 (let ((res (let ((math-expand-formulas t))
248 (apply (car expr) (cdr expr)))))
249 (and (not (eq (car-safe res) (car expr)))
255 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
256 (defun math-beforep (a b) ; [Public]
257 (cond ((and (Math-realp a) (Math-realp b))
258 (let ((comp (math-compare a b)))
262 (> (length (memq (car-safe a)
263 '(bigneg nil bigpos frac float)))
264 (length (memq (car-safe b)
265 '(bigneg nil bigpos frac float))))))))
266 ((equal b '(neg (var inf var-inf))) nil)
267 ((equal a '(neg (var inf var-inf))) t)
268 ((equal a '(var inf var-inf)) nil)
269 ((equal b '(var inf var-inf)) t)
271 (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
272 (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
277 (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
278 (if (math-beforep (nth 2 a) b)
282 ((and (eq (car a) 'intv) (eq (car b) 'intv)
283 (math-intv-constp a) (math-intv-constp b))
284 (let ((comp (math-compare (nth 2 a) (nth 2 b))))
285 (cond ((eq comp -1) t)
287 ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
288 ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
289 ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
291 ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
293 ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
296 (if (eq (car b) 'var)
297 (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
298 (not (Math-numberp b))))
299 ((eq (car b) 'var) (Math-numberp a))
300 ((eq (car a) (car b))
301 (while (and (setq a (cdr a) b (cdr b)) a
302 (equal (car a) (car b))))
305 (math-beforep (car a) (car b)))))
306 (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))))
309 (defsubst math-simplify-extended (a)
310 (let ((math-living-dangerously t))
313 (defalias 'calcFunc-esimplify 'math-simplify-extended)
315 ;;; Rewrite the trig functions in a form easier to simplify.
316 (defun math-trig-rewrite (fn)
317 "Rewrite trigonometric functions in terms of sines and cosines."
321 ((eq (car-safe fn) 'calcFunc-sec)
322 (list '/ 1 (cons 'calcFunc-cos (math-trig-rewrite (cdr fn)))))
323 ((eq (car-safe fn) 'calcFunc-csc)
324 (list '/ 1 (cons 'calcFunc-sin (math-trig-rewrite (cdr fn)))))
325 ((eq (car-safe fn) 'calcFunc-tan)
326 (let ((newfn (math-trig-rewrite (cdr fn))))
327 (list '/ (cons 'calcFunc-sin newfn)
328 (cons 'calcFunc-cos newfn))))
329 ((eq (car-safe fn) 'calcFunc-cot)
330 (let ((newfn (math-trig-rewrite (cdr fn))))
331 (list '/ (cons 'calcFunc-cos newfn)
332 (cons 'calcFunc-sin newfn))))
334 (mapcar 'math-trig-rewrite fn))))
336 (defun math-hyperbolic-trig-rewrite (fn)
337 "Rewrite hyperbolic functions in terms of sinhs and coshs."
341 ((eq (car-safe fn) 'calcFunc-sech)
342 (list '/ 1 (cons 'calcFunc-cosh (math-hyperbolic-trig-rewrite (cdr fn)))))
343 ((eq (car-safe fn) 'calcFunc-csch)
344 (list '/ 1 (cons 'calcFunc-sinh (math-hyperbolic-trig-rewrite (cdr fn)))))
345 ((eq (car-safe fn) 'calcFunc-tanh)
346 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
347 (list '/ (cons 'calcFunc-sinh newfn)
348 (cons 'calcFunc-cosh newfn))))
349 ((eq (car-safe fn) 'calcFunc-coth)
350 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn))))
351 (list '/ (cons 'calcFunc-cosh newfn)
352 (cons 'calcFunc-sinh newfn))))
354 (mapcar 'math-hyperbolic-trig-rewrite fn))))
356 ;; math-top-only is local to math-simplify, but is used by
357 ;; math-simplify-step, which is called by math-simplify.
358 (defvar math-top-only)
360 (defun math-simplify (top-expr)
361 (let ((math-simplifying t)
362 (math-top-only (consp calc-simplify-mode))
363 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
364 '((var AlgSimpRules var-AlgSimpRules)))
365 (and math-living-dangerously
366 (calc-has-rules 'var-ExtSimpRules)
367 '((var ExtSimpRules var-ExtSimpRules)))
368 (and math-simplifying-units
369 (calc-has-rules 'var-UnitSimpRules)
370 '((var UnitSimpRules var-UnitSimpRules)))
371 (and math-integrating
372 (calc-has-rules 'var-IntegSimpRules)
373 '((var IntegSimpRules var-IntegSimpRules)))))
376 (let ((r simp-rules))
377 (setq res (math-simplify-step (math-normalize top-expr))
378 calc-simplify-mode '(nil)
379 top-expr (math-normalize res))
381 (setq top-expr (math-rewrite top-expr (car r)
382 '(neg (var inf var-inf)))
384 (calc-with-default-simplification
385 (while (let ((r simp-rules))
386 (setq res (math-normalize top-expr))
388 (setq res (math-rewrite res (car r))
390 (not (equal top-expr (setq res (math-simplify-step res)))))
391 (setq top-expr res)))))
394 (defalias 'calcFunc-simplify 'math-simplify)
396 ;;; The following has a "bug" in that if any recursive simplifications
397 ;;; occur only the first handler will be tried; this doesn't really
398 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
399 (defun math-simplify-step (a)
402 (let ((aa (if (or math-top-only
403 (memq (car a) '(calcFunc-quote calcFunc-condition
406 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
407 (and (symbolp (car aa))
408 (let ((handler (get (car aa) 'math-simplify)))
411 (equal (setq aa (or (funcall (car handler) aa)
414 (setq handler (cdr handler))))))
418 (defmacro math-defsimplify (funcs &rest code)
422 (list 'put (list 'quote func) ''math-simplify
424 (list 'get (list 'quote func) ''math-simplify)
427 (append '(lambda (math-simplify-expr))
429 (if (symbolp funcs) (list funcs) funcs))))
430 (put 'math-defsimplify 'lisp-indent-hook 1)
432 ;; The function created by math-defsimplify uses the variable
433 ;; math-simplify-expr, and so is used by functions in math-defsimplify
434 (defvar math-simplify-expr)
436 (math-defsimplify (+ -)
437 (math-simplify-plus))
439 (defun math-simplify-plus ()
440 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
441 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
442 (not (Math-numberp (nth 2 math-simplify-expr))))
443 (let ((x (nth 2 math-simplify-expr))
444 (op (car math-simplify-expr)))
445 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
446 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
447 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
448 (setcar (nth 1 math-simplify-expr) op)))
449 ((and (eq (car math-simplify-expr) '+)
450 (Math-numberp (nth 1 math-simplify-expr))
451 (not (Math-numberp (nth 2 math-simplify-expr))))
452 (let ((x (nth 2 math-simplify-expr)))
453 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
454 (setcar (cdr math-simplify-expr) x))))
455 (let ((aa math-simplify-expr)
457 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
458 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
460 (eq (car math-simplify-expr) '-) t))
462 (setcar (cdr (cdr math-simplify-expr)) temp)
463 (setcar math-simplify-expr '+)
464 (setcar (cdr (cdr aaa)) 0)))
465 (setq aa (nth 1 aa)))
466 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
467 nil (eq (car math-simplify-expr) '-) t))
469 (setcar (cdr (cdr math-simplify-expr)) temp)
470 (setcar math-simplify-expr '+)
471 (setcar (cdr aa) 0)))
475 (math-simplify-times))
477 (defun math-simplify-times ()
478 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
479 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
480 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
481 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
482 (let ((x (nth 1 math-simplify-expr)))
483 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
484 (setcar (cdr (nth 2 math-simplify-expr)) x)))
485 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
486 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
487 (math-known-scalarp (nth 2 math-simplify-expr) t))
488 (let ((x (nth 2 math-simplify-expr)))
489 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
490 (setcar (cdr math-simplify-expr) x))))
491 (let ((aa math-simplify-expr)
493 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
494 (if (and (Math-ratp (nth 1 math-simplify-expr))
495 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
497 (setcar (cdr (cdr math-simplify-expr))
498 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
499 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
500 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
502 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
503 (nth 1 aaa) nil nil t))
505 (setcar (cdr math-simplify-expr) temp)
506 (setcar (cdr aaa) 1)))
507 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
509 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
512 (setcar (cdr math-simplify-expr) temp)
513 (setcar (cdr (cdr aa)) 1)))
514 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
515 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
516 (math-div (math-mul (nth 2 math-simplify-expr)
517 (nth 1 (nth 1 math-simplify-expr)))
518 (nth 2 (nth 1 math-simplify-expr)))
519 math-simplify-expr)))
522 (math-simplify-divide))
524 (defun math-simplify-divide ()
525 (let ((np (cdr math-simplify-expr))
527 (nn (and (or (eq (car math-simplify-expr) '/)
528 (not (Math-realp (nth 2 math-simplify-expr))))
529 (math-common-constant-factor (nth 2 math-simplify-expr))))
533 (setq n (and (or (eq (car math-simplify-expr) '/)
534 (not (Math-realp (nth 1 math-simplify-expr))))
535 (math-common-constant-factor (nth 1 math-simplify-expr))))
536 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
538 (setcar (cdr math-simplify-expr)
539 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
540 (setcar (cdr (cdr math-simplify-expr))
541 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
542 (if (and (math-negp nn)
543 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
544 (setcar math-simplify-expr (nth 1 op))))
545 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
547 (setcar (cdr math-simplify-expr)
548 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
549 (setcar (cdr (cdr math-simplify-expr))
550 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
551 (if (and (math-negp n)
552 (setq op (assq (car math-simplify-expr)
553 calc-tweak-eqn-table)))
554 (setcar math-simplify-expr (nth 1 op))))))))
555 (if (and (eq (car-safe (car np)) '/)
556 (math-known-scalarp (nth 2 math-simplify-expr) t))
558 (setq np (cdr (nth 1 math-simplify-expr)))
559 (while (eq (car-safe (setq n (car np))) '*)
560 (and (math-known-scalarp (nth 2 n) t)
561 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
562 (setq np (cdr (cdr n))))
563 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
565 np (cdr (cdr (nth 1 math-simplify-expr))))))
566 (while (eq (car-safe (setq n (car np))) '*)
567 (and (math-known-scalarp (nth 2 n) t)
568 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
569 (setq np (cdr (cdr n))))
570 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
573 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
574 ;; are local variables for math-simplify-divisor, but are used by
575 ;; math-simplify-one-divisor.
576 (defvar math-simplify-divisor-nover)
577 (defvar math-simplify-divisor-dover)
579 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
580 math-simplify-divisor-dover)
581 (cond ((eq (car-safe (car dp)) '/)
582 (math-simplify-divisor np (cdr (car dp))
583 math-simplify-divisor-nover
584 math-simplify-divisor-dover)
585 (and (math-known-scalarp (nth 1 (car dp)) t)
586 (math-simplify-divisor np (cdr (cdr (car dp)))
587 math-simplify-divisor-nover
588 (not math-simplify-divisor-dover))))
589 ((or (or (eq (car math-simplify-expr) '/)
590 (let ((signs (math-possible-signs (car np))))
591 (or (memq signs '(1 4))
592 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
594 math-living-dangerously)))
595 (math-numberp (car np)))
598 (scalar (math-known-scalarp (car np))))
599 (while (and (eq (car-safe (setq d (car dp))) '*)
601 (math-simplify-one-divisor np (cdr d))
602 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
605 (math-simplify-one-divisor np dp))))))
607 (defun math-simplify-one-divisor (np dp)
608 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
609 math-simplify-divisor-dover t))
613 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
614 (math-known-negp (car dp))
615 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
616 (setcar math-simplify-expr (nth 1 op)))
617 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
619 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
620 (eq (car math-simplify-expr) '/)
621 (eq (car-safe (car dp)) 'calcFunc-sqrt)
622 (Math-integerp (nth 1 (car dp)))
624 (setcar np (math-mul (car np)
625 (list 'calcFunc-sqrt (nth 1 (car dp)))))
626 (setcar dp (nth 1 (car dp))))))))
628 (defun math-common-constant-factor (expr)
629 (if (Math-realp expr)
631 (and (not (memq expr '(0 1 -1)))
633 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
634 (math-common-constant-factor expr)))
635 (if (memq (car expr) '(+ - cplx sdev))
636 (let ((f1 (math-common-constant-factor (nth 1 expr)))
637 (f2 (math-common-constant-factor (nth 2 expr))))
639 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
641 (if (memq (car expr) '(* polar))
642 (math-common-constant-factor (nth 1 expr))
643 (if (eq (car expr) '/)
644 (or (math-common-constant-factor (nth 1 expr))
645 (and (Math-integerp (nth 2 expr))
646 (list 'frac 1 (math-abs (nth 2 expr))))))))))
648 (defun math-cancel-common-factor (expr val)
649 (if (memq (car-safe expr) '(+ - cplx sdev))
651 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
652 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
654 (if (eq (car-safe expr) '*)
655 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
656 (math-div expr val))))
658 (defun math-frac-gcd (a b)
663 (if (and (Math-integerp a)
666 (and (Math-integerp a) (setq a (list 'frac a 1)))
667 (and (Math-integerp b) (setq b (list 'frac b 1)))
668 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
669 (math-gcd (nth 2 a) (nth 2 b)))))))
674 (defun math-simplify-mod ()
675 (and (Math-realp (nth 2 math-simplify-expr))
676 (Math-posp (nth 2 math-simplify-expr))
677 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
680 (or (math-negp (car lin))
681 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
684 (math-mul (nth 1 lin) (nth 2 lin))
685 (math-mod (car lin) (nth 2 math-simplify-expr)))
686 (nth 2 math-simplify-expr)))
688 (not (math-equal-int (nth 1 lin) 1))
689 (math-num-integerp (nth 1 lin))
690 (math-num-integerp (nth 2 math-simplify-expr))
691 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
692 (not (math-equal-int t1 1))
697 (math-mul (math-div (nth 1 lin) t1)
699 (let ((calc-prefer-frac t))
700 (math-div (car lin) t1)))
701 (math-div (nth 2 math-simplify-expr) t1))))
702 (and (math-equal-int (nth 2 math-simplify-expr) 1)
703 (math-known-integerp (if lin
704 (math-mul (nth 1 lin) (nth 2 lin))
705 (nth 1 math-simplify-expr)))
706 (if lin (math-mod (car lin) 1) 0))))))
708 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
709 calcFunc-gt calcFunc-leq calcFunc-geq)
710 (if (= (length math-simplify-expr) 3)
711 (math-simplify-ineq)))
713 (defun math-simplify-ineq ()
714 (let ((np (cdr math-simplify-expr))
716 (while (memq (car-safe (setq n (car np))) '(+ -))
717 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
720 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
721 (eq np (cdr math-simplify-expr)))
722 (math-simplify-divide)
723 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
724 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
725 (or (and (eq signs 2) 1)
726 (and (memq signs '(1 4 5)) 0)))
727 ((eq (car math-simplify-expr) 'calcFunc-neq)
728 (or (and (eq signs 2) 0)
729 (and (memq signs '(1 4 5)) 1)))
730 ((eq (car math-simplify-expr) 'calcFunc-lt)
731 (or (and (eq signs 1) 1)
732 (and (memq signs '(2 4 6)) 0)))
733 ((eq (car math-simplify-expr) 'calcFunc-gt)
734 (or (and (eq signs 4) 1)
735 (and (memq signs '(1 2 3)) 0)))
736 ((eq (car math-simplify-expr) 'calcFunc-leq)
737 (or (and (eq signs 4) 0)
738 (and (memq signs '(1 2 3)) 1)))
739 ((eq (car math-simplify-expr) 'calcFunc-geq)
740 (or (and (eq signs 1) 0)
741 (and (memq signs '(2 4 6)) 1))))
742 math-simplify-expr))))
744 (defun math-simplify-add-term (np dp minus lplain)
745 (or (math-vectorp (car np))
748 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
750 (if (setq temp (math-combine-sum n (nth 2 d)
751 minus (eq (car d) '+) t))
752 (if (or lplain (eq (math-looks-negp temp) minus))
754 (setcar np (setq n (if minus (math-neg temp) temp)))
755 (setcar (cdr (cdr d)) 0))
758 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
762 (if (setq temp (math-combine-sum n d minus t t))
765 (eq (math-looks-negp temp) minus)))
767 (setcar np (setq n (if minus (math-neg temp) temp)))
771 (setcar dp (setq n (math-neg temp)))))))))
773 (math-defsimplify calcFunc-sin
774 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
775 (nth 1 (nth 1 math-simplify-expr)))
776 (and (math-looks-negp (nth 1 math-simplify-expr))
777 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
778 (and (eq calc-angle-mode 'rad)
779 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
781 (math-known-sin (car n) (nth 1 n) 120 0))))
782 (and (eq calc-angle-mode 'deg)
783 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
785 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
786 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
787 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
788 (nth 1 (nth 1 math-simplify-expr))))))
789 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
790 (math-div (nth 1 (nth 1 math-simplify-expr))
792 (math-add 1 (math-sqr
793 (nth 1 (nth 1 math-simplify-expr)))))))
794 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
795 (and m (integerp (car m))
796 (let ((n (car m)) (a (nth 1 m)))
798 (list '* (list 'calcFunc-sin (list '* (1- n) a))
799 (list 'calcFunc-cos a))
800 (list '* (list 'calcFunc-cos (list '* (1- n) a))
801 (list 'calcFunc-sin a))))))))
803 (math-defsimplify calcFunc-cos
804 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
805 (nth 1 (nth 1 math-simplify-expr)))
806 (and (math-looks-negp (nth 1 math-simplify-expr))
807 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
808 (and (eq calc-angle-mode 'rad)
809 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
811 (math-known-sin (car n) (nth 1 n) 120 300))))
812 (and (eq calc-angle-mode 'deg)
813 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
815 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
816 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
818 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
819 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
823 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
824 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
825 (and m (integerp (car m))
826 (let ((n (car m)) (a (nth 1 m)))
828 (list '* (list 'calcFunc-cos (list '* (1- n) a))
829 (list 'calcFunc-cos a))
830 (list '* (list 'calcFunc-sin (list '* (1- n) a))
831 (list 'calcFunc-sin a))))))))
833 (math-defsimplify calcFunc-sec
834 (or (and (math-looks-negp (nth 1 math-simplify-expr))
835 (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
836 (and (eq calc-angle-mode 'rad)
837 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
839 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
840 (and (eq calc-angle-mode 'deg)
841 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
843 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
844 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
848 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
849 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
852 (nth 1 (nth 1 math-simplify-expr))))
853 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
856 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
858 (math-defsimplify calcFunc-csc
859 (or (and (math-looks-negp (nth 1 math-simplify-expr))
860 (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
861 (and (eq calc-angle-mode 'rad)
862 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
864 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
865 (and (eq calc-angle-mode 'deg)
866 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
868 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
869 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
870 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
871 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
874 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
875 (nth 1 (nth 1 math-simplify-expr)))))))
876 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
877 (math-div (list 'calcFunc-sqrt
878 (math-add 1 (math-sqr
879 (nth 1 (nth 1 math-simplify-expr)))))
880 (nth 1 (nth 1 math-simplify-expr))))))
882 (defun math-should-expand-trig (x &optional hyperbolic)
883 (let ((m (math-is-multiple x)))
884 (and math-living-dangerously
885 m (or (and (integerp (car m)) (> (car m) 1))
886 (equal (car m) '(frac 1 2)))
888 (memq (car-safe (nth 1 m))
890 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
891 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
892 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
893 (eq hyperbolic 'exp)))
896 (defun math-known-sin (plus n mul off)
897 (setq n (math-mul n mul))
898 (and (math-num-integerp n)
899 (setq n (math-mod (math-add (math-trunc n) off) 240))
901 (and (setq n (math-known-sin plus (- n 120) 1 0))
905 (if (math-zerop plus)
906 (and (or calc-symbolic-mode
910 (10 . (/ (calcFunc-sqrt
911 (- 2 (calcFunc-sqrt 3))) 2))
912 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
913 (15 . (/ (calcFunc-sqrt
914 (- 2 (calcFunc-sqrt 2))) 2))
916 (24 . (* (^ (/ 1 2) (/ 3 2))
918 (- 5 (calcFunc-sqrt 5)))))
919 (30 . (/ (calcFunc-sqrt 2) 2))
920 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
921 (40 . (/ (calcFunc-sqrt 3) 2))
922 (45 . (/ (calcFunc-sqrt
923 (+ 2 (calcFunc-sqrt 2))) 2))
924 (48 . (* (^ (/ 1 2) (/ 3 2))
926 (+ 5 (calcFunc-sqrt 5)))))
927 (50 . (/ (calcFunc-sqrt
928 (+ 2 (calcFunc-sqrt 3))) 2))
930 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
931 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
934 (math-defsimplify calcFunc-tan
935 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
936 (nth 1 (nth 1 math-simplify-expr)))
937 (and (math-looks-negp (nth 1 math-simplify-expr))
938 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
939 (and (eq calc-angle-mode 'rad)
940 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
942 (math-known-tan (car n) (nth 1 n) 120))))
943 (and (eq calc-angle-mode 'deg)
944 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
946 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
947 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
948 (math-div (nth 1 (nth 1 math-simplify-expr))
950 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
951 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
952 (math-div (list 'calcFunc-sqrt
953 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
954 (nth 1 (nth 1 math-simplify-expr))))
955 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
957 (if (equal (car m) '(frac 1 2))
958 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
959 (list 'calcFunc-sin (nth 1 m)))
960 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
961 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
963 (math-defsimplify calcFunc-cot
964 (or (and (math-looks-negp (nth 1 math-simplify-expr))
965 (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
966 (and (eq calc-angle-mode 'rad)
967 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
969 (math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
970 (and (eq calc-angle-mode 'deg)
971 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
973 (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
974 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
975 (math-div (list 'calcFunc-sqrt
976 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
977 (nth 1 (nth 1 math-simplify-expr))))
978 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
979 (math-div (nth 1 (nth 1 math-simplify-expr))
981 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
982 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
983 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
985 (defun math-known-tan (plus n mul)
986 (setq n (math-mul n mul))
987 (and (math-num-integerp n)
988 (setq n (math-mod (math-trunc n) 120))
990 (and (setq n (math-known-tan plus (- 120 n) 1))
992 (if (math-zerop plus)
993 (and (or calc-symbolic-mode
995 (cdr (assq n '( (0 . 0)
996 (10 . (- 2 (calcFunc-sqrt 3)))
998 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
999 (15 . (- (calcFunc-sqrt 2) 1))
1000 (20 . (/ (calcFunc-sqrt 3) 3))
1001 (24 . (calcFunc-sqrt
1002 (- 5 (* 2 (calcFunc-sqrt 5)))))
1004 (36 . (calcFunc-sqrt
1005 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1006 (40 . (calcFunc-sqrt 3))
1007 (45 . (+ (calcFunc-sqrt 2) 1))
1008 (48 . (calcFunc-sqrt
1009 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1010 (50 . (+ 2 (calcFunc-sqrt 3)))
1011 (60 . (var uinf var-uinf))))))
1012 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
1013 ((eq n 60) (math-normalize (list '/ -1
1014 (list 'calcFunc-tan plus))))
1017 (math-defsimplify calcFunc-sinh
1018 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1019 (nth 1 (nth 1 math-simplify-expr)))
1020 (and (math-looks-negp (nth 1 math-simplify-expr))
1021 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
1022 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1023 math-living-dangerously
1024 (list 'calcFunc-sqrt
1025 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1026 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1027 math-living-dangerously
1028 (math-div (nth 1 (nth 1 math-simplify-expr))
1029 (list 'calcFunc-sqrt
1030 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1031 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1032 (and m (integerp (car m))
1033 (let ((n (car m)) (a (nth 1 m)))
1036 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1037 (list 'calcFunc-cosh a))
1038 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1039 (list 'calcFunc-sinh a)))))))))
1041 (math-defsimplify calcFunc-cosh
1042 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1043 (nth 1 (nth 1 math-simplify-expr)))
1044 (and (math-looks-negp (nth 1 math-simplify-expr))
1045 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
1046 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1047 math-living-dangerously
1048 (list 'calcFunc-sqrt
1049 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1050 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1051 math-living-dangerously
1053 (list 'calcFunc-sqrt
1054 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1055 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1056 (and m (integerp (car m))
1057 (let ((n (car m)) (a (nth 1 m)))
1060 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1061 (list 'calcFunc-cosh a))
1062 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1063 (list 'calcFunc-sinh a)))))))))
1065 (math-defsimplify calcFunc-tanh
1066 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1067 (nth 1 (nth 1 math-simplify-expr)))
1068 (and (math-looks-negp (nth 1 math-simplify-expr))
1069 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
1070 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1071 math-living-dangerously
1072 (math-div (nth 1 (nth 1 math-simplify-expr))
1073 (list 'calcFunc-sqrt
1074 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1075 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1076 math-living-dangerously
1077 (math-div (list 'calcFunc-sqrt
1078 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1079 (nth 1 (nth 1 math-simplify-expr))))
1080 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1082 (if (equal (car m) '(frac 1 2))
1083 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
1084 (list 'calcFunc-sinh (nth 1 m)))
1085 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
1086 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
1088 (math-defsimplify calcFunc-sech
1089 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1090 (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
1091 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1092 math-living-dangerously
1095 (list 'calcFunc-sqrt
1096 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1097 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1098 math-living-dangerously
1099 (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
1100 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1101 math-living-dangerously
1102 (list 'calcFunc-sqrt
1103 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
1105 (math-defsimplify calcFunc-csch
1106 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1107 (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
1108 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1109 math-living-dangerously
1110 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
1111 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1112 math-living-dangerously
1115 (list 'calcFunc-sqrt
1116 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1117 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1118 math-living-dangerously
1119 (math-div (list 'calcFunc-sqrt
1120 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
1121 (nth 1 (nth 1 math-simplify-expr))))))
1123 (math-defsimplify calcFunc-coth
1124 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1125 (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
1126 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1127 math-living-dangerously
1128 (math-div (list 'calcFunc-sqrt
1129 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1130 (nth 1 (nth 1 math-simplify-expr))))
1131 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1132 math-living-dangerously
1133 (math-div (nth 1 (nth 1 math-simplify-expr))
1134 (list 'calcFunc-sqrt
1135 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1136 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1137 math-living-dangerously
1138 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
1140 (math-defsimplify calcFunc-arcsin
1141 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1142 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
1143 (and (eq (nth 1 math-simplify-expr) 1)
1144 (math-quarter-circle t))
1145 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1146 (math-div (math-half-circle t) 6))
1147 (and math-living-dangerously
1148 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1149 (nth 1 (nth 1 math-simplify-expr)))
1150 (and math-living-dangerously
1151 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1152 (math-sub (math-quarter-circle t)
1153 (nth 1 (nth 1 math-simplify-expr))))))
1155 (math-defsimplify calcFunc-arccos
1156 (or (and (eq (nth 1 math-simplify-expr) 0)
1157 (math-quarter-circle t))
1158 (and (eq (nth 1 math-simplify-expr) -1)
1159 (math-half-circle t))
1160 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1161 (math-div (math-half-circle t) 3))
1162 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
1163 (math-div (math-mul (math-half-circle t) 2) 3))
1164 (and math-living-dangerously
1165 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1166 (nth 1 (nth 1 math-simplify-expr)))
1167 (and math-living-dangerously
1168 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1169 (math-sub (math-quarter-circle t)
1170 (nth 1 (nth 1 math-simplify-expr))))))
1172 (math-defsimplify calcFunc-arctan
1173 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1174 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
1175 (and (eq (nth 1 math-simplify-expr) 1)
1176 (math-div (math-half-circle t) 4))
1177 (and math-living-dangerously
1178 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
1179 (nth 1 (nth 1 math-simplify-expr)))))
1181 (math-defsimplify calcFunc-arcsinh
1182 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1183 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
1184 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
1185 (or math-living-dangerously
1186 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1187 (nth 1 (nth 1 math-simplify-expr)))))
1189 (math-defsimplify calcFunc-arccosh
1190 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1191 (or math-living-dangerously
1192 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1193 (nth 1 (nth 1 math-simplify-expr))))
1195 (math-defsimplify calcFunc-arctanh
1196 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1197 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
1198 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
1199 (or math-living-dangerously
1200 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1201 (nth 1 (nth 1 math-simplify-expr)))))
1203 (math-defsimplify calcFunc-sqrt
1204 (math-simplify-sqrt))
1206 (defun math-simplify-sqrt ()
1207 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
1208 (math-div (list 'calcFunc-sqrt
1209 (math-mul (nth 1 (nth 1 math-simplify-expr))
1210 (nth 2 (nth 1 math-simplify-expr))))
1211 (nth 2 (nth 1 math-simplify-expr))))
1212 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1213 (math-squared-factor (nth 1 math-simplify-expr))
1214 (math-common-constant-factor (nth 1 math-simplify-expr)))))
1215 (and fac (not (eq fac 1))
1216 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1218 (list 'calcFunc-sqrt
1219 (math-cancel-common-factor
1220 (nth 1 math-simplify-expr) fac))))))
1221 (and math-living-dangerously
1222 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1223 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1224 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1225 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1226 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1229 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1230 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1233 (nth 1 (nth 1 (nth 2
1234 (nth 1 math-simplify-expr))))))))
1235 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1236 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1237 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1238 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1239 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
1241 (list 'calcFunc-sinh
1242 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1243 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1244 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1245 (b (nth 2 (nth 1 math-simplify-expr))))
1246 (and (or (and (math-equal-int a 1)
1247 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
1248 (math-equal-int b 1))
1249 (eq (car-safe a) '^)
1250 (math-equal-int (nth 2 a) 2)
1251 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1252 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
1253 (and (eq (car-safe (nth 1 a)) 'calcFunc-csch)
1254 (list 'calcFunc-coth (nth 1 (nth 1 a))))
1255 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1256 (list '/ 1 (list 'calcFunc-cos
1257 (nth 1 (nth 1 a)))))
1258 (and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
1259 (list '/ 1 (list 'calcFunc-sin
1260 (nth 1 (nth 1 a)))))))))
1261 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1263 (nth 1 (nth 1 math-simplify-expr))
1264 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1265 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1266 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1267 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1268 (list (car (nth 1 math-simplify-expr))
1269 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1270 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1271 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1272 (not (math-any-floats (nth 1 math-simplify-expr)))
1273 (let ((f (calcFunc-factors (calcFunc-expand
1274 (nth 1 math-simplify-expr)))))
1275 (and (math-vectorp f)
1276 (or (> (length f) 2)
1277 (> (nth 2 (nth 1 f)) 1))
1278 (let ((out 1) (rest 1) (sums 1) fac pow)
1279 (while (setq f (cdr f))
1280 (setq fac (nth 1 (car f))
1281 pow (nth 2 (car f)))
1283 (setq out (math-mul out (math-pow
1287 (if (memq (car-safe fac) '(+ -))
1288 (setq sums (math-mul-thru sums fac))
1289 (setq rest (math-mul rest fac)))))
1290 (and (not (and (eq out 1) (memq rest '(1 -1))))
1293 (list 'calcFunc-sqrt
1294 (math-mul sums rest))))))))))))
1296 ;;; Rather than factoring x into primes, just check for the first ten primes.
1297 (defun math-squared-factor (x)
1298 (if (Math-integerp x)
1299 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1303 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1305 fac (math-mul fac (car prsqr)))
1306 (setq prsqr (cdr prsqr))))
1309 (math-defsimplify calcFunc-exp
1310 (math-simplify-exp (nth 1 math-simplify-expr)))
1312 (defun math-simplify-exp (x)
1313 (or (and (eq (car-safe x) 'calcFunc-ln)
1315 (and math-living-dangerously
1316 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1318 (list 'calcFunc-sqrt
1319 (math-add (math-sqr (nth 1 x)) 1))))
1320 (and (eq (car-safe x) 'calcFunc-arccosh)
1322 (list 'calcFunc-sqrt
1323 (math-sub (math-sqr (nth 1 x)) 1))))
1324 (and (eq (car-safe x) 'calcFunc-arctanh)
1325 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1326 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1327 (let ((m (math-should-expand-trig x 'exp)))
1328 (and m (integerp (car m))
1329 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1330 (and calc-symbolic-mode
1331 (math-known-imagp x)
1332 (let* ((ip (calcFunc-im x))
1333 (n (math-linear-in ip '(var pi var-pi)))
1336 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1337 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
1338 (list '+ c (list '* s '(var i var-i))))))))
1340 (math-defsimplify calcFunc-ln
1341 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1342 (or math-living-dangerously
1343 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1344 (nth 1 (nth 1 math-simplify-expr)))
1345 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1346 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
1347 (or math-living-dangerously
1348 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1349 (nth 2 (nth 1 math-simplify-expr)))
1350 (and calc-symbolic-mode
1351 (math-known-negp (nth 1 math-simplify-expr))
1352 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
1353 '(* (var pi var-pi) (var i var-i))))
1354 (and calc-symbolic-mode
1355 (math-known-imagp (nth 1 math-simplify-expr))
1356 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
1357 (ips (math-possible-signs ip)))
1358 (or (and (memq ips '(4 6))
1359 (math-add (list 'calcFunc-ln ip)
1360 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1361 (and (memq ips '(1 3))
1362 (math-sub (list 'calcFunc-ln (math-neg ip))
1363 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
1366 (math-simplify-pow))
1368 (defun math-simplify-pow ()
1369 (or (and math-living-dangerously
1370 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1372 (nth 1 (nth 1 math-simplify-expr))
1373 (math-mul (nth 2 math-simplify-expr)
1374 (nth 2 (nth 1 math-simplify-expr)))))
1375 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1377 (nth 1 (nth 1 math-simplify-expr))
1378 (math-div (nth 2 math-simplify-expr) 2)))
1379 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1380 (list (car (nth 1 math-simplify-expr))
1381 (list '^ (nth 1 (nth 1 math-simplify-expr))
1382 (nth 2 math-simplify-expr))
1383 (list '^ (nth 2 (nth 1 math-simplify-expr))
1384 (nth 2 math-simplify-expr))))))
1385 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1386 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1387 (nth 1 (nth 2 math-simplify-expr)))
1388 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1389 (math-simplify-exp (nth 2 math-simplify-expr)))
1390 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1391 (not math-integrating)
1392 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
1393 (nth 2 math-simplify-expr))))
1394 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
1396 (math-num-integerp (nth 2 math-simplify-expr))
1397 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
1399 ((eq x 1) (nth 1 math-simplify-expr))
1401 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
1402 (and math-integrating
1403 (integerp (nth 2 math-simplify-expr))
1404 (>= (nth 2 math-simplify-expr) 2)
1405 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1406 (math-mul (math-pow (nth 1 math-simplify-expr)
1407 (- (nth 2 math-simplify-expr) 2))
1411 (nth 1 (nth 1 math-simplify-expr)))))))
1412 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1413 (math-mul (math-pow (nth 1 math-simplify-expr)
1414 (- (nth 2 math-simplify-expr) 2))
1417 (list 'calcFunc-sinh
1418 (nth 1 (nth 1 math-simplify-expr)))))))))
1419 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1420 (Math-ratp (nth 1 math-simplify-expr))
1421 (Math-posp (nth 1 math-simplify-expr))
1422 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1423 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1424 (let ((flr (math-floor (nth 2 math-simplify-expr))))
1425 (and (not (Math-zerop flr))
1426 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1427 (list '^ (nth 1 math-simplify-expr)
1428 (math-sub (nth 2 math-simplify-expr) flr)))))))
1429 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
1430 (let ((temp (math-simplify-sqrt)))
1432 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
1434 (math-defsimplify calcFunc-log10
1435 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1436 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
1437 (or math-living-dangerously
1438 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1439 (nth 2 (nth 1 math-simplify-expr))))
1442 (math-defsimplify calcFunc-erf
1443 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1444 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1445 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1446 (list 'calcFunc-conj
1447 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
1449 (math-defsimplify calcFunc-erfc
1450 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1451 (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
1452 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1453 (list 'calcFunc-conj
1454 (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
1457 (defun math-linear-in (expr term &optional always)
1458 (if (math-expr-contains expr term)
1459 (let* ((calc-prefer-frac t)
1460 (p (math-is-polynomial expr term 1)))
1463 (and always (list expr 0))))
1465 (defun math-multiple-of (expr term)
1466 (let ((p (math-linear-in expr term)))
1468 (math-zerop (car p))
1471 ; not perfect, but it'll do
1472 (defun math-integer-plus (expr)
1473 (cond ((Math-integerp expr)
1475 ((and (memq (car expr) '(+ -))
1476 (Math-integerp (nth 1 expr)))
1477 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1479 ((and (memq (car expr) '(+ -))
1480 (Math-integerp (nth 2 expr)))
1482 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
1485 (defun math-is-linear (expr &optional always)
1488 (if (eq (car-safe expr) '+)
1489 (if (Math-objectp (nth 1 expr))
1490 (setq offset (nth 1 expr)
1492 (if (Math-objectp (nth 2 expr))
1493 (setq offset (nth 2 expr)
1494 expr (nth 1 expr))))
1495 (if (eq (car-safe expr) '-)
1496 (if (Math-objectp (nth 1 expr))
1497 (setq offset (nth 1 expr)
1498 expr (math-neg (nth 2 expr)))
1499 (if (Math-objectp (nth 2 expr))
1500 (setq offset (math-neg (nth 2 expr))
1501 expr (nth 1 expr))))))
1502 (setq coef (math-is-multiple expr always))
1504 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1508 (defun math-is-multiple (expr &optional always)
1509 (or (if (eq (car-safe expr) '*)
1510 (if (Math-objectp (nth 1 expr))
1511 (list (nth 1 expr) (nth 2 expr)))
1512 (if (eq (car-safe expr) '/)
1513 (if (and (Math-objectp (nth 1 expr))
1514 (not (math-equal-int (nth 1 expr) 1)))
1515 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1516 (if (Math-objectp (nth 2 expr))
1517 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1518 (let ((res (math-is-multiple (nth 1 expr))))
1521 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1522 (setq res (math-is-multiple (nth 2 expr)))
1524 (list (math-div 1 (car res))
1525 (math-div (nth 1 expr)
1526 (nth 2 (nth 2 expr)))))))))
1527 (if (eq (car-safe expr) 'neg)
1528 (list -1 (nth 1 expr)))))
1529 (if (Math-objvecp expr)
1535 (defun calcFunc-lin (expr &optional var)
1537 (let ((res (math-linear-in expr var t)))
1538 (or res (math-reject-arg expr "Linear term expected"))
1539 (list 'vec (car res) (nth 1 res) var))
1540 (let ((res (math-is-linear expr t)))
1541 (or res (math-reject-arg expr "Linear term expected"))
1544 (defun calcFunc-linnt (expr &optional var)
1546 (let ((res (math-linear-in expr var)))
1547 (or res (math-reject-arg expr "Linear term expected"))
1548 (list 'vec (car res) (nth 1 res) var))
1549 (let ((res (math-is-linear expr)))
1550 (or res (math-reject-arg expr "Linear term expected"))
1553 (defun calcFunc-islin (expr &optional var)
1554 (if (and (Math-objvecp expr) (not var))
1556 (calcFunc-lin expr var)
1559 (defun calcFunc-islinnt (expr &optional var)
1560 (if (Math-objvecp expr)
1562 (calcFunc-linnt expr var)
1568 ;;; Simple operations on expressions.
1570 ;;; Return number of occurrences of thing in expr, or nil if none.
1571 (defun math-expr-contains-count (expr thing)
1572 (cond ((equal expr thing) 1)
1573 ((Math-primp expr) nil)
1576 (while (setq expr (cdr expr))
1577 (setq num (+ num (or (math-expr-contains-count
1578 (car expr) thing) 0))))
1582 (defun math-expr-contains (expr thing)
1583 (cond ((equal expr thing) 1)
1584 ((Math-primp expr) nil)
1586 (while (and (setq expr (cdr expr))
1587 (not (math-expr-contains (car expr) thing))))
1590 ;;; Return non-nil if any variable of thing occurs in expr.
1591 (defun math-expr-depends (expr thing)
1592 (if (Math-primp thing)
1593 (and (eq (car-safe thing) 'var)
1594 (math-expr-contains expr thing))
1595 (while (and (setq thing (cdr thing))
1596 (not (math-expr-depends expr (car thing)))))
1599 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1601 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1602 ;; for math-expr-subst, but used by math-expr-subst-rec.
1603 (defvar math-expr-subst-old)
1604 (defvar math-expr-subst-new)
1606 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
1607 (math-expr-subst-rec expr))
1609 (defalias 'calcFunc-subst 'math-expr-subst)
1611 (defun math-expr-subst-rec (expr)
1612 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
1613 ((Math-primp expr) expr)
1614 ((memq (car expr) '(calcFunc-deriv
1616 (if (= (length expr) 2)
1617 (if (equal (nth 1 expr) math-expr-subst-old)
1618 (append expr (list math-expr-subst-new))
1620 (list (car expr) (nth 1 expr)
1621 (math-expr-subst-rec (nth 2 expr)))))
1624 (mapcar 'math-expr-subst-rec (cdr expr))))))
1626 ;;; Various measures of the size of an expression.
1627 (defun math-expr-weight (expr)
1628 (if (Math-primp expr)
1631 (while (setq expr (cdr expr))
1632 (setq w (+ w (math-expr-weight (car expr)))))
1635 (defun math-expr-height (expr)
1636 (if (Math-primp expr)
1639 (while (setq expr (cdr expr))
1640 (setq h (max h (math-expr-height (car expr)))))
1646 ;;; Polynomial operations (to support the integrator and solve-for).
1648 (defun calcFunc-collect (expr base)
1649 (let ((p (math-is-polynomial expr base 50 t)))
1651 (math-build-polynomial-expr (mapcar 'math-normalize p) base)
1654 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1655 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1656 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1658 ;; These variables are local to math-is-polynomial, but are used by
1659 ;; math-is-poly-rec.
1660 (defvar math-is-poly-degree)
1661 (defvar math-is-poly-loose)
1664 (defun math-is-polynomial (expr var &optional math-is-poly-degree math-is-poly-loose)
1665 (let* ((math-poly-base-variable (if math-is-poly-loose
1666 (if (eq math-is-poly-loose 'gen) var '(var XXX XXX))
1667 math-poly-base-variable))
1668 (poly (math-is-poly-rec expr math-poly-neg-powers)))
1669 (and (or (null math-is-poly-degree)
1670 (<= (length poly) (1+ math-is-poly-degree)))
1673 (defun math-is-poly-rec (expr negpow)
1675 (or (cond ((or (equal expr var)
1676 (eq (car-safe expr) '^))
1679 (or (equal expr var)
1680 (setq pow (nth 2 expr)
1682 (or (eq math-poly-mult-powers 1)
1683 (setq pow (let ((m (math-is-multiple pow 1)))
1684 (and (eq (car-safe (car m)) 'cplx)
1685 (Math-zerop (nth 1 (car m)))
1686 (setq m (list (nth 2 (car m))
1689 (and (if math-poly-mult-powers
1690 (equal math-poly-mult-powers
1692 (setq math-poly-mult-powers (nth 1 m)))
1693 (or (equal expr var)
1694 (eq math-poly-mult-powers 1))
1698 (setq pow (math-to-simple-fraction pow))
1699 (and (eq (car-safe pow) 'frac)
1700 math-poly-frac-powers
1702 (setq math-poly-frac-powers
1703 (calcFunc-lcm math-poly-frac-powers
1705 (or (memq math-poly-frac-powers '(1 nil))
1706 (setq pow (math-mul pow math-poly-frac-powers)))
1712 (let ((p1 (if (equal expr var)
1714 (math-is-poly-rec expr nil)))
1718 (or (null math-is-poly-degree)
1719 (<= (* (1- (length p1)) n) math-is-poly-degree))
1722 (setq accum (math-poly-mul accum p1)
1726 (math-is-poly-rec expr nil)
1727 (setq math-poly-neg-powers
1728 (cons (math-pow expr (- pow))
1729 math-poly-neg-powers))
1730 (list (list '^ expr pow))))))))
1731 ((Math-objectp expr)
1733 ((memq (car expr) '(+ -))
1734 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1736 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1738 (math-poly-mix p1 1 p2
1739 (if (eq (car expr) '+) 1 -1)))))))
1740 ((eq (car expr) 'neg)
1741 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1743 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1745 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1747 (or (null math-is-poly-degree)
1748 (<= (- (+ (length p1) (length p2)) 2)
1749 math-is-poly-degree))
1750 (math-poly-mul p1 p2))))))
1752 (and (or (not (math-poly-depends (nth 2 expr) var))
1754 (math-is-poly-rec (nth 2 expr) nil)
1755 (setq math-poly-neg-powers
1756 (cons (nth 2 expr) math-poly-neg-powers))))
1757 (not (Math-zerop (nth 2 expr)))
1758 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1759 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1761 ((and (eq (car expr) 'calcFunc-exp)
1762 (equal var '(var e var-e)))
1763 (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
1764 ((and (eq (car expr) 'calcFunc-sqrt)
1765 math-poly-frac-powers)
1766 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1768 (and (or (not (math-poly-depends expr var))
1770 (not (eq (car expr) 'vec))
1773 ;;; Check if expr is a polynomial in var; if so, return its degree.
1774 (defun math-polynomial-p (expr var)
1775 (cond ((equal expr var) 1)
1776 ((Math-primp expr) 0)
1777 ((memq (car expr) '(+ -))
1778 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1780 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1783 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1785 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1787 ((eq (car expr) 'neg)
1788 (math-polynomial-p (nth 1 expr) var))
1789 ((and (eq (car expr) '/)
1790 (not (math-poly-depends (nth 2 expr) var)))
1791 (math-polynomial-p (nth 1 expr) var))
1792 ((and (eq (car expr) '^)
1793 (natnump (nth 2 expr)))
1794 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1795 (and p1 (* p1 (nth 2 expr)))))
1796 ((math-poly-depends expr var) nil)
1799 (defun math-poly-depends (expr var)
1800 (if math-poly-base-variable
1801 (math-expr-contains expr math-poly-base-variable)
1802 (math-expr-depends expr var)))
1804 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1805 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1806 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1807 (defvar math-poly-base-const-ok)
1808 (defvar math-poly-base-pred)
1810 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1811 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1812 ;; by math-polynomial-base.
1814 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
1815 (or math-poly-base-pred
1816 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
1817 math-poly-base-top-expr base)))))
1818 (or (let ((math-poly-base-const-ok nil))
1819 (math-polynomial-base-rec math-poly-base-top-expr))
1820 (let ((math-poly-base-const-ok t))
1821 (math-polynomial-base-rec math-poly-base-top-expr))))
1823 (defun math-polynomial-base-rec (mpb-expr)
1824 (and (not (Math-objvecp mpb-expr))
1825 (or (and (memq (car mpb-expr) '(+ - *))
1826 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1827 (math-polynomial-base-rec (nth 2 mpb-expr))))
1828 (and (memq (car mpb-expr) '(/ neg))
1829 (math-polynomial-base-rec (nth 1 mpb-expr)))
1830 (and (eq (car mpb-expr) '^)
1831 (math-polynomial-base-rec (nth 1 mpb-expr)))
1832 (and (eq (car mpb-expr) 'calcFunc-exp)
1833 (math-polynomial-base-rec '(var e var-e)))
1834 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1835 (funcall math-poly-base-pred mpb-expr)
1838 ;;; Return non-nil if expr refers to any variables.
1839 (defun math-expr-contains-vars (expr)
1840 (or (eq (car-safe expr) 'var)
1841 (and (not (Math-primp expr))
1843 (while (and (setq expr (cdr expr))
1844 (not (math-expr-contains-vars (car expr)))))
1847 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1848 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1849 (defun math-poly-simplify (p)
1851 (if (Math-zerop (nth (1- (length p)) p))
1852 (let ((pp (copy-sequence p)))
1853 (while (and (cdr pp)
1854 (Math-zerop (nth (1- (length pp)) pp)))
1855 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1859 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1860 ;;; coefficients ac, bc. Result may be unsimplified.
1861 (defun math-poly-mix (a ac b bc)
1863 (cons (math-add (math-mul (or (car a) 0) ac)
1864 (math-mul (or (car b) 0) bc))
1865 (math-poly-mix (cdr a) ac (cdr b) bc))))
1867 (defun math-poly-zerop (a)
1869 (and (null (cdr a)) (Math-zerop (car a)))))
1871 ;;; Multiply two polynomials in list form.
1872 (defun math-poly-mul (a b)
1874 (math-poly-mix b (car a)
1875 (math-poly-mul (cdr a) (cons 0 b)) 1)))
1877 ;;; Build an expression from a polynomial list.
1878 (defun math-build-polynomial-expr (p var)
1880 (if (Math-numberp var)
1881 (math-with-extra-prec 1
1882 (let* ((rp (reverse p))
1884 (while (setq rp (cdr rp))
1885 (setq accum (math-add (car rp) (math-mul accum var))))
1887 (let* ((rp (reverse p))
1888 (n (1- (length rp)))
1889 (accum (math-mul (car rp) (math-pow var n)))
1891 (while (setq rp (cdr rp))
1893 (or (math-zerop (car rp))
1894 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1896 (math-mul (if (math-looks-negp (car rp))
1899 (math-pow var n))))))
1904 (defun math-to-simple-fraction (f)
1905 (or (and (eq (car-safe f) 'float)
1906 (or (and (>= (nth 2 f) 0)
1907 (math-scale-int (nth 1 f) (nth 2 f)))
1908 (and (integerp (nth 1 f))
1911 (math-make-frac (nth 1 f)
1912 (math-scale-int 1 (- (nth 2 f)))))))
1917 ;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
1918 ;;; calc-alg.el ends here