1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 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 (calc-with-default-simplification
55 (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
57 (defun calc-simplify-extended ()
60 (calc-with-default-simplification
61 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
63 (defun calc-expand-formula (arg)
66 (calc-with-default-simplification
67 (let ((math-simplify-only nil))
68 (calc-modify-simplify-mode arg)
69 (calc-enter-result 1 "expf"
71 (let ((math-expand-formulas t))
73 (let ((top (calc-top-n 1)))
74 (or (math-expand-formula top)
77 (defun calc-factor (arg)
80 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
81 'calcFunc-factors 'calcFunc-factor)
84 (defun calc-expand (n)
87 (calc-enter-result 1 "expa"
88 (append (list 'calcFunc-expand
90 (and n (list (prefix-numeric-value n)))))))
92 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
93 (defun calcFunc-powerexpand (expr)
94 (math-normalize (math-map-tree 'math-powerexpand expr)))
96 (defun math-powerexpand (expr)
97 (if (eq (car-safe expr) '^)
98 (let ((n (nth 2 expr)))
99 (cond ((and (integerp n)
105 (setq prod (math-mul prod a))
111 (a (math-pow (nth 1 expr) -1))
112 (prod (math-pow (nth 1 expr) -1)))
114 (setq prod (math-mul a prod))
121 (defun calc-powerexpand ()
124 (calc-enter-result 1 "pexp"
125 (calcFunc-powerexpand (calc-top-n 1)))))
127 (defun calc-collect (&optional var)
128 (interactive "sCollect terms involving: ")
130 (if (or (equal var "") (equal var "$") (null var))
131 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
132 (calc-top-list-n 2)))
133 (let ((var (math-read-expr var)))
134 (if (eq (car-safe var) 'error)
135 (error "Bad format in expression: %s" (nth 1 var)))
136 (calc-enter-result 1 "clct" (list 'calcFunc-collect
140 (defun calc-apart (arg)
143 (calc-unary-op "aprt" 'calcFunc-apart arg)))
145 (defun calc-normalize-rat (arg)
148 (calc-unary-op "nrat" 'calcFunc-nrat arg)))
150 (defun calc-poly-gcd (arg)
153 (calc-binary-op "pgcd" 'calcFunc-pgcd arg)))
156 (defun calc-poly-div (arg)
159 (let ((calc-poly-div-remainder nil))
160 (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
161 (if (and calc-poly-div-remainder (null arg))
163 (calc-clear-command-flag 'clear-message)
164 (calc-record calc-poly-div-remainder "prem")
165 (if (not (Math-zerop calc-poly-div-remainder))
166 (message "(Remainder was %s)"
167 (math-format-flat-expr calc-poly-div-remainder 0))
168 (message "(No remainder)")))))))
170 (defun calc-poly-rem (arg)
173 (calc-binary-op "prem" 'calcFunc-prem arg)))
175 (defun calc-poly-div-rem (arg)
178 (if (calc-is-hyperbolic)
179 (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
180 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))))
182 (defun calc-substitute (&optional oldname newname)
183 (interactive "sSubstitute old: ")
185 (let (old new (num 1) expr)
186 (if (or (equal oldname "") (equal oldname "$") (null oldname))
187 (setq new (calc-top-n 1)
192 (progn (calc-unread-command ?\C-a)
193 (setq newname (read-string (concat "Substitute old: "
197 (if (or (equal newname "") (equal newname "$") (null newname))
198 (setq new (calc-top-n 1)
201 (setq new (if (stringp newname) (math-read-expr newname) newname))
202 (if (eq (car-safe new) 'error)
203 (error "Bad format in expression: %s" (nth 1 new)))
204 (setq expr (calc-top-n 1)))
205 (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
206 (if (eq (car-safe old) 'error)
207 (error "Bad format in expression: %s" (nth 1 old)))
208 (or (math-expr-contains expr old)
209 (error "No occurrences found")))
210 (calc-enter-result num "sbst" (math-expr-subst expr old new)))))
213 (defun calc-has-rules (name)
214 (setq name (calc-var-value name))
216 (memq (car name) '(vec calcFunc-assign calcFunc-condition))
219 ;; math-eval-rules-cache and math-eval-rules-cache-other are
220 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
221 (defvar math-eval-rules-cache)
222 (defvar math-eval-rules-cache-other)
224 (defun math-recompile-eval-rules ()
225 (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
226 (math-compile-rewrites
227 '(var EvalRules var-EvalRules)))
228 math-eval-rules-cache-other (assq nil math-eval-rules-cache)
229 math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)))
232 ;;; Try to expand a formula according to its definition.
233 (defun math-expand-formula (expr)
236 (or (get (car expr) 'calc-user-defn)
237 (get (car expr) 'math-expandable))
238 (let ((res (let ((math-expand-formulas t))
239 (apply (car expr) (cdr expr)))))
240 (and (not (eq (car-safe res) (car expr)))
246 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
247 (defun math-beforep (a b) ; [Public]
248 (cond ((and (Math-realp a) (Math-realp b))
249 (let ((comp (math-compare a b)))
253 (> (length (memq (car-safe a)
254 '(bigneg nil bigpos frac float)))
255 (length (memq (car-safe b)
256 '(bigneg nil bigpos frac float))))))))
257 ((equal b '(neg (var inf var-inf))) nil)
258 ((equal a '(neg (var inf var-inf))) t)
259 ((equal a '(var inf var-inf)) nil)
260 ((equal b '(var inf var-inf)) t)
262 (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
263 (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
268 (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
269 (if (math-beforep (nth 2 a) b)
273 ((and (eq (car a) 'intv) (eq (car b) 'intv)
274 (math-intv-constp a) (math-intv-constp b))
275 (let ((comp (math-compare (nth 2 a) (nth 2 b))))
276 (cond ((eq comp -1) t)
278 ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
279 ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
280 ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
282 ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
284 ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
287 (if (eq (car b) 'var)
288 (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
289 (not (Math-numberp b))))
290 ((eq (car b) 'var) (Math-numberp a))
291 ((eq (car a) (car b))
292 (while (and (setq a (cdr a) b (cdr b)) a
293 (equal (car a) (car b))))
296 (math-beforep (car a) (car b)))))
297 (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))))
300 (defsubst math-simplify-extended (a)
301 (let ((math-living-dangerously t))
304 (defalias 'calcFunc-esimplify 'math-simplify-extended)
306 ;; math-top-only is local to math-simplify, but is used by
307 ;; math-simplify-step, which is called by math-simplify.
308 (defvar math-top-only)
310 (defun math-simplify (top-expr)
311 (let ((math-simplifying t)
312 (math-top-only (consp calc-simplify-mode))
313 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
314 '((var AlgSimpRules var-AlgSimpRules)))
315 (and math-living-dangerously
316 (calc-has-rules 'var-ExtSimpRules)
317 '((var ExtSimpRules var-ExtSimpRules)))
318 (and math-simplifying-units
319 (calc-has-rules 'var-UnitSimpRules)
320 '((var UnitSimpRules var-UnitSimpRules)))
321 (and math-integrating
322 (calc-has-rules 'var-IntegSimpRules)
323 '((var IntegSimpRules var-IntegSimpRules)))))
326 (let ((r simp-rules))
327 (setq res (math-simplify-step (math-normalize top-expr))
328 calc-simplify-mode '(nil)
329 top-expr (math-normalize res))
331 (setq top-expr (math-rewrite top-expr (car r)
332 '(neg (var inf var-inf)))
334 (calc-with-default-simplification
335 (while (let ((r simp-rules))
336 (setq res (math-normalize top-expr))
338 (setq res (math-rewrite res (car r))
340 (not (equal top-expr (setq res (math-simplify-step res)))))
341 (setq top-expr res)))))
344 (defalias 'calcFunc-simplify 'math-simplify)
346 ;;; The following has a "bug" in that if any recursive simplifications
347 ;;; occur only the first handler will be tried; this doesn't really
348 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
349 (defun math-simplify-step (a)
352 (let ((aa (if (or math-top-only
353 (memq (car a) '(calcFunc-quote calcFunc-condition
356 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
357 (and (symbolp (car aa))
358 (let ((handler (get (car aa) 'math-simplify)))
361 (equal (setq aa (or (funcall (car handler) aa)
364 (setq handler (cdr handler))))))
368 (defmacro math-defsimplify (funcs &rest code)
372 (list 'put (list 'quote func) ''math-simplify
374 (list 'get (list 'quote func) ''math-simplify)
377 (append '(lambda (math-simplify-expr))
379 (if (symbolp funcs) (list funcs) funcs))))
380 (put 'math-defsimplify 'lisp-indent-hook 1)
382 ;; The function created by math-defsimplify uses the variable
383 ;; math-simplify-expr, and so is used by functions in math-defsimplify
384 (defvar math-simplify-expr)
386 (math-defsimplify (+ -)
387 (math-simplify-plus))
389 (defun math-simplify-plus ()
390 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
391 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
392 (not (Math-numberp (nth 2 math-simplify-expr))))
393 (let ((x (nth 2 math-simplify-expr))
394 (op (car math-simplify-expr)))
395 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
396 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
397 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
398 (setcar (nth 1 math-simplify-expr) op)))
399 ((and (eq (car math-simplify-expr) '+)
400 (Math-numberp (nth 1 math-simplify-expr))
401 (not (Math-numberp (nth 2 math-simplify-expr))))
402 (let ((x (nth 2 math-simplify-expr)))
403 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
404 (setcar (cdr math-simplify-expr) x))))
405 (let ((aa math-simplify-expr)
407 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
408 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
410 (eq (car math-simplify-expr) '-) t))
412 (setcar (cdr (cdr math-simplify-expr)) temp)
413 (setcar math-simplify-expr '+)
414 (setcar (cdr (cdr aaa)) 0)))
415 (setq aa (nth 1 aa)))
416 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
417 nil (eq (car math-simplify-expr) '-) t))
419 (setcar (cdr (cdr math-simplify-expr)) temp)
420 (setcar math-simplify-expr '+)
421 (setcar (cdr aa) 0)))
425 (math-simplify-times))
427 (defun math-simplify-times ()
428 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
429 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
430 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
431 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
432 (let ((x (nth 1 math-simplify-expr)))
433 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
434 (setcar (cdr (nth 2 math-simplify-expr)) x)))
435 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
436 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
437 (math-known-scalarp (nth 2 math-simplify-expr) t))
438 (let ((x (nth 2 math-simplify-expr)))
439 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
440 (setcar (cdr math-simplify-expr) x))))
441 (let ((aa math-simplify-expr)
443 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
444 (if (and (Math-ratp (nth 1 math-simplify-expr))
445 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
447 (setcar (cdr (cdr math-simplify-expr))
448 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
449 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
450 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
452 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
453 (nth 1 aaa) nil nil t))
455 (setcar (cdr math-simplify-expr) temp)
456 (setcar (cdr aaa) 1)))
457 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
459 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
462 (setcar (cdr math-simplify-expr) temp)
463 (setcar (cdr (cdr aa)) 1)))
464 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
465 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
466 (math-div (math-mul (nth 2 math-simplify-expr)
467 (nth 1 (nth 1 math-simplify-expr)))
468 (nth 2 (nth 1 math-simplify-expr)))
469 math-simplify-expr)))
472 (math-simplify-divide))
474 (defun math-simplify-divide ()
475 (let ((np (cdr math-simplify-expr))
477 (nn (and (or (eq (car math-simplify-expr) '/)
478 (not (Math-realp (nth 2 math-simplify-expr))))
479 (math-common-constant-factor (nth 2 math-simplify-expr))))
483 (setq n (and (or (eq (car math-simplify-expr) '/)
484 (not (Math-realp (nth 1 math-simplify-expr))))
485 (math-common-constant-factor (nth 1 math-simplify-expr))))
486 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
488 (setcar (cdr math-simplify-expr)
489 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
490 (setcar (cdr (cdr math-simplify-expr))
491 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
492 (if (and (math-negp nn)
493 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
494 (setcar math-simplify-expr (nth 1 op))))
495 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
497 (setcar (cdr math-simplify-expr)
498 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
499 (setcar (cdr (cdr math-simplify-expr))
500 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
501 (if (and (math-negp n)
502 (setq op (assq (car math-simplify-expr)
503 calc-tweak-eqn-table)))
504 (setcar math-simplify-expr (nth 1 op))))))))
505 (if (and (eq (car-safe (car np)) '/)
506 (math-known-scalarp (nth 2 math-simplify-expr) t))
508 (setq np (cdr (nth 1 math-simplify-expr)))
509 (while (eq (car-safe (setq n (car np))) '*)
510 (and (math-known-scalarp (nth 2 n) t)
511 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
512 (setq np (cdr (cdr n))))
513 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
515 np (cdr (cdr (nth 1 math-simplify-expr))))))
516 (while (eq (car-safe (setq n (car np))) '*)
517 (and (math-known-scalarp (nth 2 n) t)
518 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
519 (setq np (cdr (cdr n))))
520 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
523 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
524 ;; are local variables for math-simplify-divisor, but are used by
525 ;; math-simplify-one-divisor.
526 (defvar math-simplify-divisor-nover)
527 (defvar math-simplify-divisor-dover)
529 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
530 math-simplify-divisor-dover)
531 (cond ((eq (car-safe (car dp)) '/)
532 (math-simplify-divisor np (cdr (car dp))
533 math-simplify-divisor-nover
534 math-simplify-divisor-dover)
535 (and (math-known-scalarp (nth 1 (car dp)) t)
536 (math-simplify-divisor np (cdr (cdr (car dp)))
537 math-simplify-divisor-nover
538 (not math-simplify-divisor-dover))))
539 ((or (or (eq (car math-simplify-expr) '/)
540 (let ((signs (math-possible-signs (car np))))
541 (or (memq signs '(1 4))
542 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
544 math-living-dangerously)))
545 (math-numberp (car np)))
548 (scalar (math-known-scalarp (car np))))
549 (while (and (eq (car-safe (setq d (car dp))) '*)
551 (math-simplify-one-divisor np (cdr d))
552 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
555 (math-simplify-one-divisor np dp))))))
557 (defun math-simplify-one-divisor (np dp)
558 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
559 math-simplify-divisor-dover t))
563 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
564 (math-known-negp (car dp))
565 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
566 (setcar math-simplify-expr (nth 1 op)))
567 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
569 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
570 (eq (car math-simplify-expr) '/)
571 (eq (car-safe (car dp)) 'calcFunc-sqrt)
572 (Math-integerp (nth 1 (car dp)))
574 (setcar np (math-mul (car np)
575 (list 'calcFunc-sqrt (nth 1 (car dp)))))
576 (setcar dp (nth 1 (car dp))))))))
578 (defun math-common-constant-factor (expr)
579 (if (Math-realp expr)
581 (and (not (memq expr '(0 1 -1)))
583 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
584 (math-common-constant-factor expr)))
585 (if (memq (car expr) '(+ - cplx sdev))
586 (let ((f1 (math-common-constant-factor (nth 1 expr)))
587 (f2 (math-common-constant-factor (nth 2 expr))))
589 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
591 (if (memq (car expr) '(* polar))
592 (math-common-constant-factor (nth 1 expr))
593 (if (eq (car expr) '/)
594 (or (math-common-constant-factor (nth 1 expr))
595 (and (Math-integerp (nth 2 expr))
596 (list 'frac 1 (math-abs (nth 2 expr))))))))))
598 (defun math-cancel-common-factor (expr val)
599 (if (memq (car-safe expr) '(+ - cplx sdev))
601 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
602 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
604 (if (eq (car-safe expr) '*)
605 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
606 (math-div expr val))))
608 (defun math-frac-gcd (a b)
613 (if (and (Math-integerp a)
616 (and (Math-integerp a) (setq a (list 'frac a 1)))
617 (and (Math-integerp b) (setq b (list 'frac b 1)))
618 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
619 (math-gcd (nth 2 a) (nth 2 b)))))))
624 (defun math-simplify-mod ()
625 (and (Math-realp (nth 2 math-simplify-expr))
626 (Math-posp (nth 2 math-simplify-expr))
627 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
630 (or (math-negp (car lin))
631 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
634 (math-mul (nth 1 lin) (nth 2 lin))
635 (math-mod (car lin) (nth 2 math-simplify-expr)))
636 (nth 2 math-simplify-expr)))
638 (not (math-equal-int (nth 1 lin) 1))
639 (math-num-integerp (nth 1 lin))
640 (math-num-integerp (nth 2 math-simplify-expr))
641 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
642 (not (math-equal-int t1 1))
647 (math-mul (math-div (nth 1 lin) t1)
649 (let ((calc-prefer-frac t))
650 (math-div (car lin) t1)))
651 (math-div (nth 2 math-simplify-expr) t1))))
652 (and (math-equal-int (nth 2 math-simplify-expr) 1)
653 (math-known-integerp (if lin
654 (math-mul (nth 1 lin) (nth 2 lin))
655 (nth 1 math-simplify-expr)))
656 (if lin (math-mod (car lin) 1) 0))))))
658 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
659 calcFunc-gt calcFunc-leq calcFunc-geq)
660 (if (= (length math-simplify-expr) 3)
661 (math-simplify-ineq)))
663 (defun math-simplify-ineq ()
664 (let ((np (cdr math-simplify-expr))
666 (while (memq (car-safe (setq n (car np))) '(+ -))
667 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
670 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
671 (eq np (cdr math-simplify-expr)))
672 (math-simplify-divide)
673 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
674 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
675 (or (and (eq signs 2) 1)
676 (and (memq signs '(1 4 5)) 0)))
677 ((eq (car math-simplify-expr) 'calcFunc-neq)
678 (or (and (eq signs 2) 0)
679 (and (memq signs '(1 4 5)) 1)))
680 ((eq (car math-simplify-expr) 'calcFunc-lt)
681 (or (and (eq signs 1) 1)
682 (and (memq signs '(2 4 6)) 0)))
683 ((eq (car math-simplify-expr) 'calcFunc-gt)
684 (or (and (eq signs 4) 1)
685 (and (memq signs '(1 2 3)) 0)))
686 ((eq (car math-simplify-expr) 'calcFunc-leq)
687 (or (and (eq signs 4) 0)
688 (and (memq signs '(1 2 3)) 1)))
689 ((eq (car math-simplify-expr) 'calcFunc-geq)
690 (or (and (eq signs 1) 0)
691 (and (memq signs '(2 4 6)) 1))))
692 math-simplify-expr))))
694 (defun math-simplify-add-term (np dp minus lplain)
695 (or (math-vectorp (car np))
698 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
700 (if (setq temp (math-combine-sum n (nth 2 d)
701 minus (eq (car d) '+) t))
702 (if (or lplain (eq (math-looks-negp temp) minus))
704 (setcar np (setq n (if minus (math-neg temp) temp)))
705 (setcar (cdr (cdr d)) 0))
708 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
712 (if (setq temp (math-combine-sum n d minus t t))
715 (eq (math-looks-negp temp) minus)))
717 (setcar np (setq n (if minus (math-neg temp) temp)))
721 (setcar dp (setq n (math-neg temp)))))))))
723 (math-defsimplify calcFunc-sin
724 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
725 (nth 1 (nth 1 math-simplify-expr)))
726 (and (math-looks-negp (nth 1 math-simplify-expr))
727 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
728 (and (eq calc-angle-mode 'rad)
729 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
731 (math-known-sin (car n) (nth 1 n) 120 0))))
732 (and (eq calc-angle-mode 'deg)
733 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
735 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
736 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
737 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
738 (nth 1 (nth 1 math-simplify-expr))))))
739 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
740 (math-div (nth 1 (nth 1 math-simplify-expr))
742 (math-add 1 (math-sqr
743 (nth 1 (nth 1 math-simplify-expr)))))))
744 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
745 (and m (integerp (car m))
746 (let ((n (car m)) (a (nth 1 m)))
748 (list '* (list 'calcFunc-sin (list '* (1- n) a))
749 (list 'calcFunc-cos a))
750 (list '* (list 'calcFunc-cos (list '* (1- n) a))
751 (list 'calcFunc-sin a))))))))
753 (math-defsimplify calcFunc-cos
754 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
755 (nth 1 (nth 1 math-simplify-expr)))
756 (and (math-looks-negp (nth 1 math-simplify-expr))
757 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
758 (and (eq calc-angle-mode 'rad)
759 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
761 (math-known-sin (car n) (nth 1 n) 120 300))))
762 (and (eq calc-angle-mode 'deg)
763 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
765 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
766 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
768 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
769 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
773 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
774 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
775 (and m (integerp (car m))
776 (let ((n (car m)) (a (nth 1 m)))
778 (list '* (list 'calcFunc-cos (list '* (1- n) a))
779 (list 'calcFunc-cos a))
780 (list '* (list 'calcFunc-sin (list '* (1- n) a))
781 (list 'calcFunc-sin a))))))))
783 (math-defsimplify calcFunc-sec
784 (or (and (math-looks-negp (nth 1 math-simplify-expr))
785 (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr))))
786 (and (eq calc-angle-mode 'rad)
787 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
789 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300)))))
790 (and (eq calc-angle-mode 'deg)
791 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
793 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))))
794 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
798 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
799 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
802 (nth 1 (nth 1 math-simplify-expr))))
803 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
806 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
808 (math-defsimplify calcFunc-csc
809 (or (and (math-looks-negp (nth 1 math-simplify-expr))
810 (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr)))))
811 (and (eq calc-angle-mode 'rad)
812 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
814 (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0)))))
815 (and (eq calc-angle-mode 'deg)
816 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
818 (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))))
819 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
820 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
821 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
824 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
825 (nth 1 (nth 1 math-simplify-expr)))))))
826 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
827 (math-div (list 'calcFunc-sqrt
828 (math-add 1 (math-sqr
829 (nth 1 (nth 1 math-simplify-expr)))))
830 (nth 1 (nth 1 math-simplify-expr))))))
832 (defun math-should-expand-trig (x &optional hyperbolic)
833 (let ((m (math-is-multiple x)))
834 (and math-living-dangerously
835 m (or (and (integerp (car m)) (> (car m) 1))
836 (equal (car m) '(frac 1 2)))
838 (memq (car-safe (nth 1 m))
840 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
841 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
842 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
843 (eq hyperbolic 'exp)))
846 (defun math-known-sin (plus n mul off)
847 (setq n (math-mul n mul))
848 (and (math-num-integerp n)
849 (setq n (math-mod (math-add (math-trunc n) off) 240))
851 (and (setq n (math-known-sin plus (- n 120) 1 0))
855 (if (math-zerop plus)
856 (and (or calc-symbolic-mode
860 (10 . (/ (calcFunc-sqrt
861 (- 2 (calcFunc-sqrt 3))) 2))
862 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
863 (15 . (/ (calcFunc-sqrt
864 (- 2 (calcFunc-sqrt 2))) 2))
866 (24 . (* (^ (/ 1 2) (/ 3 2))
868 (- 5 (calcFunc-sqrt 5)))))
869 (30 . (/ (calcFunc-sqrt 2) 2))
870 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
871 (40 . (/ (calcFunc-sqrt 3) 2))
872 (45 . (/ (calcFunc-sqrt
873 (+ 2 (calcFunc-sqrt 2))) 2))
874 (48 . (* (^ (/ 1 2) (/ 3 2))
876 (+ 5 (calcFunc-sqrt 5)))))
877 (50 . (/ (calcFunc-sqrt
878 (+ 2 (calcFunc-sqrt 3))) 2))
880 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
881 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
884 (math-defsimplify calcFunc-tan
885 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
886 (nth 1 (nth 1 math-simplify-expr)))
887 (and (math-looks-negp (nth 1 math-simplify-expr))
888 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
889 (and (eq calc-angle-mode 'rad)
890 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
892 (math-known-tan (car n) (nth 1 n) 120))))
893 (and (eq calc-angle-mode 'deg)
894 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
896 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
897 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
898 (math-div (nth 1 (nth 1 math-simplify-expr))
900 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
901 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
902 (math-div (list 'calcFunc-sqrt
903 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
904 (nth 1 (nth 1 math-simplify-expr))))
905 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
907 (if (equal (car m) '(frac 1 2))
908 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
909 (list 'calcFunc-sin (nth 1 m)))
910 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
911 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
913 (math-defsimplify calcFunc-cot
914 (or (and (math-looks-negp (nth 1 math-simplify-expr))
915 (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr)))))
916 (and (eq calc-angle-mode 'rad)
917 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
919 (math-div 1 (math-known-tan (car n) (nth 1 n) 120)))))
920 (and (eq calc-angle-mode 'deg)
921 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
923 (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3))))))
924 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
925 (math-div (list 'calcFunc-sqrt
926 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
927 (nth 1 (nth 1 math-simplify-expr))))
928 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
929 (math-div (nth 1 (nth 1 math-simplify-expr))
931 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
932 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
933 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
935 (defun math-known-tan (plus n mul)
936 (setq n (math-mul n mul))
937 (and (math-num-integerp n)
938 (setq n (math-mod (math-trunc n) 120))
940 (and (setq n (math-known-tan plus (- 120 n) 1))
942 (if (math-zerop plus)
943 (and (or calc-symbolic-mode
945 (cdr (assq n '( (0 . 0)
946 (10 . (- 2 (calcFunc-sqrt 3)))
948 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
949 (15 . (- (calcFunc-sqrt 2) 1))
950 (20 . (/ (calcFunc-sqrt 3) 3))
952 (- 5 (* 2 (calcFunc-sqrt 5)))))
955 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
956 (40 . (calcFunc-sqrt 3))
957 (45 . (+ (calcFunc-sqrt 2) 1))
959 (+ 5 (* 2 (calcFunc-sqrt 5)))))
960 (50 . (+ 2 (calcFunc-sqrt 3)))
961 (60 . (var uinf var-uinf))))))
962 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
963 ((eq n 60) (math-normalize (list '/ -1
964 (list 'calcFunc-tan plus))))
967 (math-defsimplify calcFunc-sinh
968 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
969 (nth 1 (nth 1 math-simplify-expr)))
970 (and (math-looks-negp (nth 1 math-simplify-expr))
971 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
972 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
973 math-living-dangerously
975 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
976 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
977 math-living-dangerously
978 (math-div (nth 1 (nth 1 math-simplify-expr))
980 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
981 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
982 (and m (integerp (car m))
983 (let ((n (car m)) (a (nth 1 m)))
986 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
987 (list 'calcFunc-cosh a))
988 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
989 (list 'calcFunc-sinh a)))))))))
991 (math-defsimplify calcFunc-cosh
992 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
993 (nth 1 (nth 1 math-simplify-expr)))
994 (and (math-looks-negp (nth 1 math-simplify-expr))
995 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
996 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
997 math-living-dangerously
999 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
1000 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1001 math-living-dangerously
1003 (list 'calcFunc-sqrt
1004 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
1005 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1006 (and m (integerp (car m))
1007 (let ((n (car m)) (a (nth 1 m)))
1010 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
1011 (list 'calcFunc-cosh a))
1012 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
1013 (list 'calcFunc-sinh a)))))))))
1015 (math-defsimplify calcFunc-tanh
1016 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1017 (nth 1 (nth 1 math-simplify-expr)))
1018 (and (math-looks-negp (nth 1 math-simplify-expr))
1019 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
1020 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1021 math-living-dangerously
1022 (math-div (nth 1 (nth 1 math-simplify-expr))
1023 (list 'calcFunc-sqrt
1024 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1025 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1026 math-living-dangerously
1027 (math-div (list 'calcFunc-sqrt
1028 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1029 (nth 1 (nth 1 math-simplify-expr))))
1030 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
1032 (if (equal (car m) '(frac 1 2))
1033 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
1034 (list 'calcFunc-sinh (nth 1 m)))
1035 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
1036 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
1038 (math-defsimplify calcFunc-sech
1039 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1040 (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr))))
1041 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1042 math-living-dangerously
1045 (list 'calcFunc-sqrt
1046 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1047 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1048 math-living-dangerously
1049 (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1)
1050 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1051 math-living-dangerously
1052 (list 'calcFunc-sqrt
1053 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))))
1055 (math-defsimplify calcFunc-csch
1056 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1057 (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr)))))
1058 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1059 math-living-dangerously
1060 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))
1061 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1062 math-living-dangerously
1065 (list 'calcFunc-sqrt
1066 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1067 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1068 math-living-dangerously
1069 (math-div (list 'calcFunc-sqrt
1070 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
1071 (nth 1 (nth 1 math-simplify-expr))))))
1073 (math-defsimplify calcFunc-coth
1074 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1075 (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr)))))
1076 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
1077 math-living-dangerously
1078 (math-div (list 'calcFunc-sqrt
1079 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
1080 (nth 1 (nth 1 math-simplify-expr))))
1081 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
1082 math-living-dangerously
1083 (math-div (nth 1 (nth 1 math-simplify-expr))
1084 (list 'calcFunc-sqrt
1085 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
1086 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
1087 math-living-dangerously
1088 (math-div 1 (nth 1 (nth 1 math-simplify-expr))))))
1090 (math-defsimplify calcFunc-arcsin
1091 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1092 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
1093 (and (eq (nth 1 math-simplify-expr) 1)
1094 (math-quarter-circle t))
1095 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1096 (math-div (math-half-circle t) 6))
1097 (and math-living-dangerously
1098 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1099 (nth 1 (nth 1 math-simplify-expr)))
1100 (and math-living-dangerously
1101 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1102 (math-sub (math-quarter-circle t)
1103 (nth 1 (nth 1 math-simplify-expr))))))
1105 (math-defsimplify calcFunc-arccos
1106 (or (and (eq (nth 1 math-simplify-expr) 0)
1107 (math-quarter-circle t))
1108 (and (eq (nth 1 math-simplify-expr) -1)
1109 (math-half-circle t))
1110 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
1111 (math-div (math-half-circle t) 3))
1112 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
1113 (math-div (math-mul (math-half-circle t) 2) 3))
1114 (and math-living-dangerously
1115 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1116 (nth 1 (nth 1 math-simplify-expr)))
1117 (and math-living-dangerously
1118 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
1119 (math-sub (math-quarter-circle t)
1120 (nth 1 (nth 1 math-simplify-expr))))))
1122 (math-defsimplify calcFunc-arctan
1123 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1124 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
1125 (and (eq (nth 1 math-simplify-expr) 1)
1126 (math-div (math-half-circle t) 4))
1127 (and math-living-dangerously
1128 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
1129 (nth 1 (nth 1 math-simplify-expr)))))
1131 (math-defsimplify calcFunc-arcsinh
1132 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1133 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
1134 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
1135 (or math-living-dangerously
1136 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1137 (nth 1 (nth 1 math-simplify-expr)))))
1139 (math-defsimplify calcFunc-arccosh
1140 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1141 (or math-living-dangerously
1142 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1143 (nth 1 (nth 1 math-simplify-expr))))
1145 (math-defsimplify calcFunc-arctanh
1146 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1147 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
1148 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
1149 (or math-living-dangerously
1150 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1151 (nth 1 (nth 1 math-simplify-expr)))))
1153 (math-defsimplify calcFunc-sqrt
1154 (math-simplify-sqrt))
1156 (defun math-simplify-sqrt ()
1157 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
1158 (math-div (list 'calcFunc-sqrt
1159 (math-mul (nth 1 (nth 1 math-simplify-expr))
1160 (nth 2 (nth 1 math-simplify-expr))))
1161 (nth 2 (nth 1 math-simplify-expr))))
1162 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1163 (math-squared-factor (nth 1 math-simplify-expr))
1164 (math-common-constant-factor (nth 1 math-simplify-expr)))))
1165 (and fac (not (eq fac 1))
1166 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1168 (list 'calcFunc-sqrt
1169 (math-cancel-common-factor
1170 (nth 1 math-simplify-expr) fac))))))
1171 (and math-living-dangerously
1172 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1173 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1174 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1175 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1176 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1179 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1180 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1183 (nth 1 (nth 1 (nth 2
1184 (nth 1 math-simplify-expr))))))))
1185 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1186 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1187 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1188 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1189 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
1191 (list 'calcFunc-sinh
1192 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1193 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1194 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1195 (b (nth 2 (nth 1 math-simplify-expr))))
1196 (and (or (and (math-equal-int a 1)
1197 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
1198 (math-equal-int b 1))
1199 (eq (car-safe a) '^)
1200 (math-equal-int (nth 2 a) 2)
1201 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1202 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
1203 (and (eq (car-safe (nth 1 a)) 'calcFunc-csch)
1204 (list 'calcFunc-coth (nth 1 (nth 1 a))))
1205 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1206 (list '/ 1 (list 'calcFunc-cos
1207 (nth 1 (nth 1 a)))))
1208 (and (eq (car-safe (nth 1 a)) 'calcFunc-cot)
1209 (list '/ 1 (list 'calcFunc-sin
1210 (nth 1 (nth 1 a)))))))))
1211 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1213 (nth 1 (nth 1 math-simplify-expr))
1214 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1215 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1216 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1217 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1218 (list (car (nth 1 math-simplify-expr))
1219 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1220 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1221 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1222 (not (math-any-floats (nth 1 math-simplify-expr)))
1223 (let ((f (calcFunc-factors (calcFunc-expand
1224 (nth 1 math-simplify-expr)))))
1225 (and (math-vectorp f)
1226 (or (> (length f) 2)
1227 (> (nth 2 (nth 1 f)) 1))
1228 (let ((out 1) (rest 1) (sums 1) fac pow)
1229 (while (setq f (cdr f))
1230 (setq fac (nth 1 (car f))
1231 pow (nth 2 (car f)))
1233 (setq out (math-mul out (math-pow
1237 (if (memq (car-safe fac) '(+ -))
1238 (setq sums (math-mul-thru sums fac))
1239 (setq rest (math-mul rest fac)))))
1240 (and (not (and (eq out 1) (memq rest '(1 -1))))
1243 (list 'calcFunc-sqrt
1244 (math-mul sums rest))))))))))))
1246 ;;; Rather than factoring x into primes, just check for the first ten primes.
1247 (defun math-squared-factor (x)
1248 (if (Math-integerp x)
1249 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1253 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1255 fac (math-mul fac (car prsqr)))
1256 (setq prsqr (cdr prsqr))))
1259 (math-defsimplify calcFunc-exp
1260 (math-simplify-exp (nth 1 math-simplify-expr)))
1262 (defun math-simplify-exp (x)
1263 (or (and (eq (car-safe x) 'calcFunc-ln)
1265 (and math-living-dangerously
1266 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1268 (list 'calcFunc-sqrt
1269 (math-add (math-sqr (nth 1 x)) 1))))
1270 (and (eq (car-safe x) 'calcFunc-arccosh)
1272 (list 'calcFunc-sqrt
1273 (math-sub (math-sqr (nth 1 x)) 1))))
1274 (and (eq (car-safe x) 'calcFunc-arctanh)
1275 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1276 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1277 (let ((m (math-should-expand-trig x 'exp)))
1278 (and m (integerp (car m))
1279 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1280 (and calc-symbolic-mode
1281 (math-known-imagp x)
1282 (let* ((ip (calcFunc-im x))
1283 (n (math-linear-in ip '(var pi var-pi)))
1286 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1287 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
1288 (list '+ c (list '* s '(var i var-i))))))))
1290 (math-defsimplify calcFunc-ln
1291 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1292 (or math-living-dangerously
1293 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1294 (nth 1 (nth 1 math-simplify-expr)))
1295 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1296 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
1297 (or math-living-dangerously
1298 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1299 (nth 2 (nth 1 math-simplify-expr)))
1300 (and calc-symbolic-mode
1301 (math-known-negp (nth 1 math-simplify-expr))
1302 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
1303 '(* (var pi var-pi) (var i var-i))))
1304 (and calc-symbolic-mode
1305 (math-known-imagp (nth 1 math-simplify-expr))
1306 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
1307 (ips (math-possible-signs ip)))
1308 (or (and (memq ips '(4 6))
1309 (math-add (list 'calcFunc-ln ip)
1310 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1311 (and (memq ips '(1 3))
1312 (math-sub (list 'calcFunc-ln (math-neg ip))
1313 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
1316 (math-simplify-pow))
1318 (defun math-simplify-pow ()
1319 (or (and math-living-dangerously
1320 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1322 (nth 1 (nth 1 math-simplify-expr))
1323 (math-mul (nth 2 math-simplify-expr)
1324 (nth 2 (nth 1 math-simplify-expr)))))
1325 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1327 (nth 1 (nth 1 math-simplify-expr))
1328 (math-div (nth 2 math-simplify-expr) 2)))
1329 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1330 (list (car (nth 1 math-simplify-expr))
1331 (list '^ (nth 1 (nth 1 math-simplify-expr))
1332 (nth 2 math-simplify-expr))
1333 (list '^ (nth 2 (nth 1 math-simplify-expr))
1334 (nth 2 math-simplify-expr))))))
1335 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1336 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1337 (nth 1 (nth 2 math-simplify-expr)))
1338 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1339 (math-simplify-exp (nth 2 math-simplify-expr)))
1340 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1341 (not math-integrating)
1342 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
1343 (nth 2 math-simplify-expr))))
1344 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
1346 (math-num-integerp (nth 2 math-simplify-expr))
1347 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
1349 ((eq x 1) (nth 1 math-simplify-expr))
1351 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
1352 (and math-integrating
1353 (integerp (nth 2 math-simplify-expr))
1354 (>= (nth 2 math-simplify-expr) 2)
1355 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1356 (math-mul (math-pow (nth 1 math-simplify-expr)
1357 (- (nth 2 math-simplify-expr) 2))
1361 (nth 1 (nth 1 math-simplify-expr)))))))
1362 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1363 (math-mul (math-pow (nth 1 math-simplify-expr)
1364 (- (nth 2 math-simplify-expr) 2))
1367 (list 'calcFunc-sinh
1368 (nth 1 (nth 1 math-simplify-expr)))))))))
1369 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1370 (Math-ratp (nth 1 math-simplify-expr))
1371 (Math-posp (nth 1 math-simplify-expr))
1372 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1373 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1374 (let ((flr (math-floor (nth 2 math-simplify-expr))))
1375 (and (not (Math-zerop flr))
1376 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1377 (list '^ (nth 1 math-simplify-expr)
1378 (math-sub (nth 2 math-simplify-expr) flr)))))))
1379 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
1380 (let ((temp (math-simplify-sqrt)))
1382 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
1384 (math-defsimplify calcFunc-log10
1385 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1386 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
1387 (or math-living-dangerously
1388 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1389 (nth 2 (nth 1 math-simplify-expr))))
1392 (math-defsimplify calcFunc-erf
1393 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1394 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1395 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1396 (list 'calcFunc-conj
1397 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
1399 (math-defsimplify calcFunc-erfc
1400 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1401 (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
1402 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1403 (list 'calcFunc-conj
1404 (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
1407 (defun math-linear-in (expr term &optional always)
1408 (if (math-expr-contains expr term)
1409 (let* ((calc-prefer-frac t)
1410 (p (math-is-polynomial expr term 1)))
1413 (and always (list expr 0))))
1415 (defun math-multiple-of (expr term)
1416 (let ((p (math-linear-in expr term)))
1418 (math-zerop (car p))
1421 ; not perfect, but it'll do
1422 (defun math-integer-plus (expr)
1423 (cond ((Math-integerp expr)
1425 ((and (memq (car expr) '(+ -))
1426 (Math-integerp (nth 1 expr)))
1427 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1429 ((and (memq (car expr) '(+ -))
1430 (Math-integerp (nth 2 expr)))
1432 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
1435 (defun math-is-linear (expr &optional always)
1438 (if (eq (car-safe expr) '+)
1439 (if (Math-objectp (nth 1 expr))
1440 (setq offset (nth 1 expr)
1442 (if (Math-objectp (nth 2 expr))
1443 (setq offset (nth 2 expr)
1444 expr (nth 1 expr))))
1445 (if (eq (car-safe expr) '-)
1446 (if (Math-objectp (nth 1 expr))
1447 (setq offset (nth 1 expr)
1448 expr (math-neg (nth 2 expr)))
1449 (if (Math-objectp (nth 2 expr))
1450 (setq offset (math-neg (nth 2 expr))
1451 expr (nth 1 expr))))))
1452 (setq coef (math-is-multiple expr always))
1454 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1458 (defun math-is-multiple (expr &optional always)
1459 (or (if (eq (car-safe expr) '*)
1460 (if (Math-objectp (nth 1 expr))
1461 (list (nth 1 expr) (nth 2 expr)))
1462 (if (eq (car-safe expr) '/)
1463 (if (and (Math-objectp (nth 1 expr))
1464 (not (math-equal-int (nth 1 expr) 1)))
1465 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1466 (if (Math-objectp (nth 2 expr))
1467 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1468 (let ((res (math-is-multiple (nth 1 expr))))
1471 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1472 (setq res (math-is-multiple (nth 2 expr)))
1474 (list (math-div 1 (car res))
1475 (math-div (nth 1 expr)
1476 (nth 2 (nth 2 expr)))))))))
1477 (if (eq (car-safe expr) 'neg)
1478 (list -1 (nth 1 expr)))))
1479 (if (Math-objvecp expr)
1485 (defun calcFunc-lin (expr &optional var)
1487 (let ((res (math-linear-in expr var t)))
1488 (or res (math-reject-arg expr "Linear term expected"))
1489 (list 'vec (car res) (nth 1 res) var))
1490 (let ((res (math-is-linear expr t)))
1491 (or res (math-reject-arg expr "Linear term expected"))
1494 (defun calcFunc-linnt (expr &optional var)
1496 (let ((res (math-linear-in expr var)))
1497 (or res (math-reject-arg expr "Linear term expected"))
1498 (list 'vec (car res) (nth 1 res) var))
1499 (let ((res (math-is-linear expr)))
1500 (or res (math-reject-arg expr "Linear term expected"))
1503 (defun calcFunc-islin (expr &optional var)
1504 (if (and (Math-objvecp expr) (not var))
1506 (calcFunc-lin expr var)
1509 (defun calcFunc-islinnt (expr &optional var)
1510 (if (Math-objvecp expr)
1512 (calcFunc-linnt expr var)
1518 ;;; Simple operations on expressions.
1520 ;;; Return number of occurrences of thing in expr, or nil if none.
1521 (defun math-expr-contains-count (expr thing)
1522 (cond ((equal expr thing) 1)
1523 ((Math-primp expr) nil)
1526 (while (setq expr (cdr expr))
1527 (setq num (+ num (or (math-expr-contains-count
1528 (car expr) thing) 0))))
1532 (defun math-expr-contains (expr thing)
1533 (cond ((equal expr thing) 1)
1534 ((Math-primp expr) nil)
1536 (while (and (setq expr (cdr expr))
1537 (not (math-expr-contains (car expr) thing))))
1540 ;;; Return non-nil if any variable of thing occurs in expr.
1541 (defun math-expr-depends (expr thing)
1542 (if (Math-primp thing)
1543 (and (eq (car-safe thing) 'var)
1544 (math-expr-contains expr thing))
1545 (while (and (setq thing (cdr thing))
1546 (not (math-expr-depends expr (car thing)))))
1549 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1551 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1552 ;; for math-expr-subst, but used by math-expr-subst-rec.
1553 (defvar math-expr-subst-old)
1554 (defvar math-expr-subst-new)
1556 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
1557 (math-expr-subst-rec expr))
1559 (defalias 'calcFunc-subst 'math-expr-subst)
1561 (defun math-expr-subst-rec (expr)
1562 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
1563 ((Math-primp expr) expr)
1564 ((memq (car expr) '(calcFunc-deriv
1566 (if (= (length expr) 2)
1567 (if (equal (nth 1 expr) math-expr-subst-old)
1568 (append expr (list math-expr-subst-new))
1570 (list (car expr) (nth 1 expr)
1571 (math-expr-subst-rec (nth 2 expr)))))
1574 (mapcar 'math-expr-subst-rec (cdr expr))))))
1576 ;;; Various measures of the size of an expression.
1577 (defun math-expr-weight (expr)
1578 (if (Math-primp expr)
1581 (while (setq expr (cdr expr))
1582 (setq w (+ w (math-expr-weight (car expr)))))
1585 (defun math-expr-height (expr)
1586 (if (Math-primp expr)
1589 (while (setq expr (cdr expr))
1590 (setq h (max h (math-expr-height (car expr)))))
1596 ;;; Polynomial operations (to support the integrator and solve-for).
1598 (defun calcFunc-collect (expr base)
1599 (let ((p (math-is-polynomial expr base 50 t)))
1601 (math-normalize ; fix selection bug
1602 (math-build-polynomial-expr p base))
1605 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1606 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1607 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1609 ;; The variables math-is-poly-degree and math-is-poly-loose are local to
1610 ;; math-is-polynomial, but are used by math-is-poly-rec
1611 (defvar math-is-poly-degree)
1612 (defvar math-is-poly-loose)
1614 (defun math-is-polynomial (expr var &optional math-is-poly-degree math-is-poly-loose)
1615 (let* ((math-poly-base-variable (if math-is-poly-loose
1616 (if (eq math-is-poly-loose 'gen) var '(var XXX XXX))
1617 math-poly-base-variable))
1618 (poly (math-is-poly-rec expr math-poly-neg-powers)))
1619 (and (or (null math-is-poly-degree)
1620 (<= (length poly) (1+ math-is-poly-degree)))
1623 (defun math-is-poly-rec (expr negpow)
1625 (or (cond ((or (equal expr var)
1626 (eq (car-safe expr) '^))
1629 (or (equal expr var)
1630 (setq pow (nth 2 expr)
1632 (or (eq math-poly-mult-powers 1)
1633 (setq pow (let ((m (math-is-multiple pow 1)))
1634 (and (eq (car-safe (car m)) 'cplx)
1635 (Math-zerop (nth 1 (car m)))
1636 (setq m (list (nth 2 (car m))
1639 (and (if math-poly-mult-powers
1640 (equal math-poly-mult-powers
1642 (setq math-poly-mult-powers (nth 1 m)))
1643 (or (equal expr var)
1644 (eq math-poly-mult-powers 1))
1648 (setq pow (math-to-simple-fraction pow))
1649 (and (eq (car-safe pow) 'frac)
1650 math-poly-frac-powers
1652 (setq math-poly-frac-powers
1653 (calcFunc-lcm math-poly-frac-powers
1655 (or (memq math-poly-frac-powers '(1 nil))
1656 (setq pow (math-mul pow math-poly-frac-powers)))
1662 (let ((p1 (if (equal expr var)
1664 (math-is-poly-rec expr nil)))
1668 (or (null math-is-poly-degree)
1669 (<= (* (1- (length p1)) n) math-is-poly-degree))
1672 (setq accum (math-poly-mul accum p1)
1676 (math-is-poly-rec expr nil)
1677 (setq math-poly-neg-powers
1678 (cons (math-pow expr (- pow))
1679 math-poly-neg-powers))
1680 (list (list '^ expr pow))))))))
1681 ((Math-objectp expr)
1683 ((memq (car expr) '(+ -))
1684 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1686 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1688 (math-poly-mix p1 1 p2
1689 (if (eq (car expr) '+) 1 -1)))))))
1690 ((eq (car expr) 'neg)
1691 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1693 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1695 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1697 (or (null math-is-poly-degree)
1698 (<= (- (+ (length p1) (length p2)) 2)
1699 math-is-poly-degree))
1700 (math-poly-mul p1 p2))))))
1702 (and (or (not (math-poly-depends (nth 2 expr) var))
1704 (math-is-poly-rec (nth 2 expr) nil)
1705 (setq math-poly-neg-powers
1706 (cons (nth 2 expr) math-poly-neg-powers))))
1707 (not (Math-zerop (nth 2 expr)))
1708 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1709 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1711 ((and (eq (car expr) 'calcFunc-exp)
1712 (equal var '(var e var-e)))
1713 (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
1714 ((and (eq (car expr) 'calcFunc-sqrt)
1715 math-poly-frac-powers)
1716 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1718 (and (or (not (math-poly-depends expr var))
1720 (not (eq (car expr) 'vec))
1723 ;;; Check if expr is a polynomial in var; if so, return its degree.
1724 (defun math-polynomial-p (expr var)
1725 (cond ((equal expr var) 1)
1726 ((Math-primp expr) 0)
1727 ((memq (car expr) '(+ -))
1728 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1730 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1733 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1735 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1737 ((eq (car expr) 'neg)
1738 (math-polynomial-p (nth 1 expr) var))
1739 ((and (eq (car expr) '/)
1740 (not (math-poly-depends (nth 2 expr) var)))
1741 (math-polynomial-p (nth 1 expr) var))
1742 ((and (eq (car expr) '^)
1743 (natnump (nth 2 expr)))
1744 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1745 (and p1 (* p1 (nth 2 expr)))))
1746 ((math-poly-depends expr var) nil)
1749 (defun math-poly-depends (expr var)
1750 (if math-poly-base-variable
1751 (math-expr-contains expr math-poly-base-variable)
1752 (math-expr-depends expr var)))
1754 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1755 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1756 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1757 (defvar math-poly-base-const-ok)
1758 (defvar math-poly-base-pred)
1760 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1761 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1762 ;; by math-polynomial-base.
1764 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
1765 (or math-poly-base-pred
1766 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
1767 math-poly-base-top-expr base)))))
1768 (or (let ((math-poly-base-const-ok nil))
1769 (math-polynomial-base-rec math-poly-base-top-expr))
1770 (let ((math-poly-base-const-ok t))
1771 (math-polynomial-base-rec math-poly-base-top-expr))))
1773 (defun math-polynomial-base-rec (mpb-expr)
1774 (and (not (Math-objvecp mpb-expr))
1775 (or (and (memq (car mpb-expr) '(+ - *))
1776 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1777 (math-polynomial-base-rec (nth 2 mpb-expr))))
1778 (and (memq (car mpb-expr) '(/ neg))
1779 (math-polynomial-base-rec (nth 1 mpb-expr)))
1780 (and (eq (car mpb-expr) '^)
1781 (math-polynomial-base-rec (nth 1 mpb-expr)))
1782 (and (eq (car mpb-expr) 'calcFunc-exp)
1783 (math-polynomial-base-rec '(var e var-e)))
1784 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1785 (funcall math-poly-base-pred mpb-expr)
1788 ;;; Return non-nil if expr refers to any variables.
1789 (defun math-expr-contains-vars (expr)
1790 (or (eq (car-safe expr) 'var)
1791 (and (not (Math-primp expr))
1793 (while (and (setq expr (cdr expr))
1794 (not (math-expr-contains-vars (car expr)))))
1797 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1798 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1799 (defun math-poly-simplify (p)
1801 (if (Math-zerop (nth (1- (length p)) p))
1802 (let ((pp (copy-sequence p)))
1803 (while (and (cdr pp)
1804 (Math-zerop (nth (1- (length pp)) pp)))
1805 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1809 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1810 ;;; coefficients ac, bc. Result may be unsimplified.
1811 (defun math-poly-mix (a ac b bc)
1813 (cons (math-add (math-mul (or (car a) 0) ac)
1814 (math-mul (or (car b) 0) bc))
1815 (math-poly-mix (cdr a) ac (cdr b) bc))))
1817 (defun math-poly-zerop (a)
1819 (and (null (cdr a)) (Math-zerop (car a)))))
1821 ;;; Multiply two polynomials in list form.
1822 (defun math-poly-mul (a b)
1824 (math-poly-mix b (car a)
1825 (math-poly-mul (cdr a) (cons 0 b)) 1)))
1827 ;;; Build an expression from a polynomial list.
1828 (defun math-build-polynomial-expr (p var)
1830 (if (Math-numberp var)
1831 (math-with-extra-prec 1
1832 (let* ((rp (reverse p))
1834 (while (setq rp (cdr rp))
1835 (setq accum (math-add (car rp) (math-mul accum var))))
1837 (let* ((rp (reverse p))
1838 (n (1- (length rp)))
1839 (accum (math-mul (car rp) (math-pow var n)))
1841 (while (setq rp (cdr rp))
1843 (or (math-zerop (car rp))
1844 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1846 (math-mul (if (math-looks-negp (car rp))
1849 (math-pow var n))))))
1854 (defun math-to-simple-fraction (f)
1855 (or (and (eq (car-safe f) 'float)
1856 (or (and (>= (nth 2 f) 0)
1857 (math-scale-int (nth 1 f) (nth 2 f)))
1858 (and (integerp (nth 1 f))
1861 (math-make-frac (nth 1 f)
1862 (math-scale-int 1 (- (nth 2 f)))))))
1867 ;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
1868 ;;; calc-alg.el ends here