1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
36 (defun calc-alg-evaluate (arg)
39 (calc-with-default-simplification
40 (let ((math-simplify-only nil))
41 (calc-modify-simplify-mode arg)
42 (calc-enter-result 1 "dsmp" (calc-top 1))))))
44 (defun calc-modify-simplify-mode (arg)
45 (if (= (math-abs arg) 2)
46 (setq calc-simplify-mode 'alg)
47 (if (>= (math-abs arg) 3)
48 (setq calc-simplify-mode 'ext)))
50 (setq calc-simplify-mode (list calc-simplify-mode))))
52 (defun calc-simplify ()
55 (calc-with-default-simplification
56 (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
58 (defun calc-simplify-extended ()
61 (calc-with-default-simplification
62 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
64 (defun calc-expand-formula (arg)
67 (calc-with-default-simplification
68 (let ((math-simplify-only nil))
69 (calc-modify-simplify-mode arg)
70 (calc-enter-result 1 "expf"
72 (let ((math-expand-formulas t))
74 (let ((top (calc-top-n 1)))
75 (or (math-expand-formula top)
78 (defun calc-factor (arg)
81 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
82 'calcFunc-factors 'calcFunc-factor)
85 (defun calc-expand (n)
88 (calc-enter-result 1 "expa"
89 (append (list 'calcFunc-expand
91 (and n (list (prefix-numeric-value n)))))))
93 (defun calc-collect (&optional var)
94 (interactive "sCollect terms involving: ")
96 (if (or (equal var "") (equal var "$") (null var))
97 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
99 (let ((var (math-read-expr var)))
100 (if (eq (car-safe var) 'error)
101 (error "Bad format in expression: %s" (nth 1 var)))
102 (calc-enter-result 1 "clct" (list 'calcFunc-collect
106 (defun calc-apart (arg)
109 (calc-unary-op "aprt" 'calcFunc-apart arg)))
111 (defun calc-normalize-rat (arg)
114 (calc-unary-op "nrat" 'calcFunc-nrat arg)))
116 (defun calc-poly-gcd (arg)
119 (calc-binary-op "pgcd" 'calcFunc-pgcd arg)))
122 (defun calc-poly-div (arg)
125 (let ((calc-poly-div-remainder nil))
126 (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
127 (if (and calc-poly-div-remainder (null arg))
129 (calc-clear-command-flag 'clear-message)
130 (calc-record calc-poly-div-remainder "prem")
131 (if (not (Math-zerop calc-poly-div-remainder))
132 (message "(Remainder was %s)"
133 (math-format-flat-expr calc-poly-div-remainder 0))
134 (message "(No remainder)")))))))
136 (defun calc-poly-rem (arg)
139 (calc-binary-op "prem" 'calcFunc-prem arg)))
141 (defun calc-poly-div-rem (arg)
144 (if (calc-is-hyperbolic)
145 (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
146 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))))
148 (defun calc-substitute (&optional oldname newname)
149 (interactive "sSubstitute old: ")
151 (let (old new (num 1) expr)
152 (if (or (equal oldname "") (equal oldname "$") (null oldname))
153 (setq new (calc-top-n 1)
158 (progn (calc-unread-command ?\C-a)
159 (setq newname (read-string (concat "Substitute old: "
163 (if (or (equal newname "") (equal newname "$") (null newname))
164 (setq new (calc-top-n 1)
167 (setq new (if (stringp newname) (math-read-expr newname) newname))
168 (if (eq (car-safe new) 'error)
169 (error "Bad format in expression: %s" (nth 1 new)))
170 (setq expr (calc-top-n 1)))
171 (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
172 (if (eq (car-safe old) 'error)
173 (error "Bad format in expression: %s" (nth 1 old)))
174 (or (math-expr-contains expr old)
175 (error "No occurrences found")))
176 (calc-enter-result num "sbst" (math-expr-subst expr old new)))))
179 (defun calc-has-rules (name)
180 (setq name (calc-var-value name))
182 (memq (car name) '(vec calcFunc-assign calcFunc-condition))
185 ;; math-eval-rules-cache and math-eval-rules-cache-other are
186 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
187 (defvar math-eval-rules-cache)
188 (defvar math-eval-rules-cache-other)
190 (defun math-recompile-eval-rules ()
191 (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
192 (math-compile-rewrites
193 '(var EvalRules var-EvalRules)))
194 math-eval-rules-cache-other (assq nil math-eval-rules-cache)
195 math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)))
198 ;;; Try to expand a formula according to its definition.
199 (defun math-expand-formula (expr)
202 (or (get (car expr) 'calc-user-defn)
203 (get (car expr) 'math-expandable))
204 (let ((res (let ((math-expand-formulas t))
205 (apply (car expr) (cdr expr)))))
206 (and (not (eq (car-safe res) (car expr)))
212 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
213 (defun math-beforep (a b) ; [Public]
214 (cond ((and (Math-realp a) (Math-realp b))
215 (let ((comp (math-compare a b)))
219 (> (length (memq (car-safe a)
220 '(bigneg nil bigpos frac float)))
221 (length (memq (car-safe b)
222 '(bigneg nil bigpos frac float))))))))
223 ((equal b '(neg (var inf var-inf))) nil)
224 ((equal a '(neg (var inf var-inf))) t)
225 ((equal a '(var inf var-inf)) nil)
226 ((equal b '(var inf var-inf)) t)
228 (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
229 (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
234 (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
235 (if (math-beforep (nth 2 a) b)
239 ((and (eq (car a) 'intv) (eq (car b) 'intv)
240 (math-intv-constp a) (math-intv-constp b))
241 (let ((comp (math-compare (nth 2 a) (nth 2 b))))
242 (cond ((eq comp -1) t)
244 ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
245 ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
246 ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
248 ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
250 ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
253 (if (eq (car b) 'var)
254 (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
255 (not (Math-numberp b))))
256 ((eq (car b) 'var) (Math-numberp a))
257 ((eq (car a) (car b))
258 (while (and (setq a (cdr a) b (cdr b)) a
259 (equal (car a) (car b))))
262 (math-beforep (car a) (car b)))))
263 (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))))
266 (defsubst math-simplify-extended (a)
267 (let ((math-living-dangerously t))
270 (defalias 'calcFunc-esimplify 'math-simplify-extended)
272 ;; math-top-only is local to math-simplify, but is used by
273 ;; math-simplify-step, which is called by math-simplify.
274 (defvar math-top-only)
276 (defun math-simplify (top-expr)
277 (let ((math-simplifying t)
278 (math-top-only (consp calc-simplify-mode))
279 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
280 '((var AlgSimpRules var-AlgSimpRules)))
281 (and math-living-dangerously
282 (calc-has-rules 'var-ExtSimpRules)
283 '((var ExtSimpRules var-ExtSimpRules)))
284 (and math-simplifying-units
285 (calc-has-rules 'var-UnitSimpRules)
286 '((var UnitSimpRules var-UnitSimpRules)))
287 (and math-integrating
288 (calc-has-rules 'var-IntegSimpRules)
289 '((var IntegSimpRules var-IntegSimpRules)))))
292 (let ((r simp-rules))
293 (setq res (math-simplify-step (math-normalize top-expr))
294 calc-simplify-mode '(nil)
295 top-expr (math-normalize res))
297 (setq top-expr (math-rewrite top-expr (car r)
298 '(neg (var inf var-inf)))
300 (calc-with-default-simplification
301 (while (let ((r simp-rules))
302 (setq res (math-normalize top-expr))
304 (setq res (math-rewrite res (car r))
306 (not (equal top-expr (setq res (math-simplify-step res)))))
307 (setq top-expr res)))))
310 (defalias 'calcFunc-simplify 'math-simplify)
312 ;;; The following has a "bug" in that if any recursive simplifications
313 ;;; occur only the first handler will be tried; this doesn't really
314 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
315 (defun math-simplify-step (a)
318 (let ((aa (if (or math-top-only
319 (memq (car a) '(calcFunc-quote calcFunc-condition
322 (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
323 (and (symbolp (car aa))
324 (let ((handler (get (car aa) 'math-simplify)))
327 (equal (setq aa (or (funcall (car handler) aa)
330 (setq handler (cdr handler))))))
334 (defmacro math-defsimplify (funcs &rest code)
338 (list 'put (list 'quote func) ''math-simplify
340 (list 'get (list 'quote func) ''math-simplify)
343 (append '(lambda (math-simplify-expr))
345 (if (symbolp funcs) (list funcs) funcs))))
346 (put 'math-defsimplify 'lisp-indent-hook 1)
348 ;; The function created by math-defsimplify uses the variable
349 ;; math-simplify-expr, and so is used by functions in math-defsimplify
350 (defvar math-simplify-expr)
352 (math-defsimplify (+ -)
353 (math-simplify-plus))
355 (defun math-simplify-plus ()
356 (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
357 (Math-numberp (nth 2 (nth 1 math-simplify-expr)))
358 (not (Math-numberp (nth 2 math-simplify-expr))))
359 (let ((x (nth 2 math-simplify-expr))
360 (op (car math-simplify-expr)))
361 (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr)))
362 (setcar math-simplify-expr (car (nth 1 math-simplify-expr)))
363 (setcar (cdr (cdr (nth 1 math-simplify-expr))) x)
364 (setcar (nth 1 math-simplify-expr) op)))
365 ((and (eq (car math-simplify-expr) '+)
366 (Math-numberp (nth 1 math-simplify-expr))
367 (not (Math-numberp (nth 2 math-simplify-expr))))
368 (let ((x (nth 2 math-simplify-expr)))
369 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
370 (setcar (cdr math-simplify-expr) x))))
371 (let ((aa math-simplify-expr)
373 (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
374 (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr)
376 (eq (car math-simplify-expr) '-) t))
378 (setcar (cdr (cdr math-simplify-expr)) temp)
379 (setcar math-simplify-expr '+)
380 (setcar (cdr (cdr aaa)) 0)))
381 (setq aa (nth 1 aa)))
382 (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr)
383 nil (eq (car math-simplify-expr) '-) t))
385 (setcar (cdr (cdr math-simplify-expr)) temp)
386 (setcar math-simplify-expr '+)
387 (setcar (cdr aa) 0)))
391 (math-simplify-times))
393 (defun math-simplify-times ()
394 (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
395 (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr))
396 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
397 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t))
398 (let ((x (nth 1 math-simplify-expr)))
399 (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr)))
400 (setcar (cdr (nth 2 math-simplify-expr)) x)))
401 (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr))
402 (or (math-known-scalarp (nth 1 math-simplify-expr) t)
403 (math-known-scalarp (nth 2 math-simplify-expr) t))
404 (let ((x (nth 2 math-simplify-expr)))
405 (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr))
406 (setcar (cdr math-simplify-expr) x))))
407 (let ((aa math-simplify-expr)
409 (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr))))
410 (if (and (Math-ratp (nth 1 math-simplify-expr))
411 (setq temp (math-common-constant-factor (nth 2 math-simplify-expr))))
413 (setcar (cdr (cdr math-simplify-expr))
414 (math-cancel-common-factor (nth 2 math-simplify-expr) temp))
415 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp))))
416 (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
418 (if (setq temp (math-combine-prod (nth 1 math-simplify-expr)
419 (nth 1 aaa) nil nil t))
421 (setcar (cdr math-simplify-expr) temp)
422 (setcar (cdr aaa) 1)))
423 (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
425 (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t))
428 (setcar (cdr math-simplify-expr) temp)
429 (setcar (cdr (cdr aa)) 1)))
430 (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
431 (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1)))
432 (math-div (math-mul (nth 2 math-simplify-expr)
433 (nth 1 (nth 1 math-simplify-expr)))
434 (nth 2 (nth 1 math-simplify-expr)))
435 math-simplify-expr)))
438 (math-simplify-divide))
440 (defun math-simplify-divide ()
441 (let ((np (cdr math-simplify-expr))
443 (nn (and (or (eq (car math-simplify-expr) '/)
444 (not (Math-realp (nth 2 math-simplify-expr))))
445 (math-common-constant-factor (nth 2 math-simplify-expr))))
449 (setq n (and (or (eq (car math-simplify-expr) '/)
450 (not (Math-realp (nth 1 math-simplify-expr))))
451 (math-common-constant-factor (nth 1 math-simplify-expr))))
452 (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
454 (setcar (cdr math-simplify-expr)
455 (math-mul (nth 2 nn) (nth 1 math-simplify-expr)))
456 (setcar (cdr (cdr math-simplify-expr))
457 (math-cancel-common-factor (nth 2 math-simplify-expr) nn))
458 (if (and (math-negp nn)
459 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)))
460 (setcar math-simplify-expr (nth 1 op))))
461 (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
463 (setcar (cdr math-simplify-expr)
464 (math-cancel-common-factor (nth 1 math-simplify-expr) n))
465 (setcar (cdr (cdr math-simplify-expr))
466 (math-cancel-common-factor (nth 2 math-simplify-expr) n))
467 (if (and (math-negp n)
468 (setq op (assq (car math-simplify-expr)
469 calc-tweak-eqn-table)))
470 (setcar math-simplify-expr (nth 1 op))))))))
471 (if (and (eq (car-safe (car np)) '/)
472 (math-known-scalarp (nth 2 math-simplify-expr) t))
474 (setq np (cdr (nth 1 math-simplify-expr)))
475 (while (eq (car-safe (setq n (car np))) '*)
476 (and (math-known-scalarp (nth 2 n) t)
477 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t))
478 (setq np (cdr (cdr n))))
479 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t)
481 np (cdr (cdr (nth 1 math-simplify-expr))))))
482 (while (eq (car-safe (setq n (car np))) '*)
483 (and (math-known-scalarp (nth 2 n) t)
484 (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t))
485 (setq np (cdr (cdr n))))
486 (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t)
489 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
490 ;; are local variables for math-simplify-divisor, but are used by
491 ;; math-simplify-one-divisor.
492 (defvar math-simplify-divisor-nover)
493 (defvar math-simplify-divisor-dover)
495 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
496 math-simplify-divisor-dover)
497 (cond ((eq (car-safe (car dp)) '/)
498 (math-simplify-divisor np (cdr (car dp))
499 math-simplify-divisor-nover
500 math-simplify-divisor-dover)
501 (and (math-known-scalarp (nth 1 (car dp)) t)
502 (math-simplify-divisor np (cdr (cdr (car dp)))
503 math-simplify-divisor-nover
504 (not math-simplify-divisor-dover))))
505 ((or (or (eq (car math-simplify-expr) '/)
506 (let ((signs (math-possible-signs (car np))))
507 (or (memq signs '(1 4))
508 (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq))
510 math-living-dangerously)))
511 (math-numberp (car np)))
514 (scalar (math-known-scalarp (car np))))
515 (while (and (eq (car-safe (setq d (car dp))) '*)
517 (math-simplify-one-divisor np (cdr d))
518 (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
521 (math-simplify-one-divisor np dp))))))
523 (defun math-simplify-one-divisor (np dp)
524 (let ((temp (math-combine-prod (car np) (car dp) math-simplify-divisor-nover
525 math-simplify-divisor-dover t))
529 (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq)))
530 (math-known-negp (car dp))
531 (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))
532 (setcar math-simplify-expr (nth 1 op)))
533 (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp))
535 (and math-simplify-divisor-dover (not math-simplify-divisor-nover)
536 (eq (car math-simplify-expr) '/)
537 (eq (car-safe (car dp)) 'calcFunc-sqrt)
538 (Math-integerp (nth 1 (car dp)))
540 (setcar np (math-mul (car np)
541 (list 'calcFunc-sqrt (nth 1 (car dp)))))
542 (setcar dp (nth 1 (car dp))))))))
544 (defun math-common-constant-factor (expr)
545 (if (Math-realp expr)
547 (and (not (memq expr '(0 1 -1)))
549 (if (math-ratp (setq expr (math-to-simple-fraction expr)))
550 (math-common-constant-factor expr)))
551 (if (memq (car expr) '(+ - cplx sdev))
552 (let ((f1 (math-common-constant-factor (nth 1 expr)))
553 (f2 (math-common-constant-factor (nth 2 expr))))
555 (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
557 (if (memq (car expr) '(* polar))
558 (math-common-constant-factor (nth 1 expr))
559 (if (eq (car expr) '/)
560 (or (math-common-constant-factor (nth 1 expr))
561 (and (Math-integerp (nth 2 expr))
562 (list 'frac 1 (math-abs (nth 2 expr))))))))))
564 (defun math-cancel-common-factor (expr val)
565 (if (memq (car-safe expr) '(+ - cplx sdev))
567 (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
568 (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
570 (if (eq (car-safe expr) '*)
571 (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
572 (math-div expr val))))
574 (defun math-frac-gcd (a b)
579 (if (and (Math-integerp a)
582 (and (Math-integerp a) (setq a (list 'frac a 1)))
583 (and (Math-integerp b) (setq b (list 'frac b 1)))
584 (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
585 (math-gcd (nth 2 a) (nth 2 b)))))))
590 (defun math-simplify-mod ()
591 (and (Math-realp (nth 2 math-simplify-expr))
592 (Math-posp (nth 2 math-simplify-expr))
593 (let ((lin (math-is-linear (nth 1 math-simplify-expr)))
596 (or (math-negp (car lin))
597 (not (Math-lessp (car lin) (nth 2 math-simplify-expr))))
600 (math-mul (nth 1 lin) (nth 2 lin))
601 (math-mod (car lin) (nth 2 math-simplify-expr)))
602 (nth 2 math-simplify-expr)))
604 (not (math-equal-int (nth 1 lin) 1))
605 (math-num-integerp (nth 1 lin))
606 (math-num-integerp (nth 2 math-simplify-expr))
607 (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr)))
608 (not (math-equal-int t1 1))
613 (math-mul (math-div (nth 1 lin) t1)
615 (let ((calc-prefer-frac t))
616 (math-div (car lin) t1)))
617 (math-div (nth 2 math-simplify-expr) t1))))
618 (and (math-equal-int (nth 2 math-simplify-expr) 1)
619 (math-known-integerp (if lin
620 (math-mul (nth 1 lin) (nth 2 lin))
621 (nth 1 math-simplify-expr)))
622 (if lin (math-mod (car lin) 1) 0))))))
624 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
625 calcFunc-gt calcFunc-leq calcFunc-geq)
626 (if (= (length math-simplify-expr) 3)
627 (math-simplify-ineq)))
629 (defun math-simplify-ineq ()
630 (let ((np (cdr math-simplify-expr))
632 (while (memq (car-safe (setq n (car np))) '(+ -))
633 (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr))
636 (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil
637 (eq np (cdr math-simplify-expr)))
638 (math-simplify-divide)
639 (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr)))))
640 (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq)
641 (or (and (eq signs 2) 1)
642 (and (memq signs '(1 4 5)) 0)))
643 ((eq (car math-simplify-expr) 'calcFunc-neq)
644 (or (and (eq signs 2) 0)
645 (and (memq signs '(1 4 5)) 1)))
646 ((eq (car math-simplify-expr) 'calcFunc-lt)
647 (or (and (eq signs 1) 1)
648 (and (memq signs '(2 4 6)) 0)))
649 ((eq (car math-simplify-expr) 'calcFunc-gt)
650 (or (and (eq signs 4) 1)
651 (and (memq signs '(1 2 3)) 0)))
652 ((eq (car math-simplify-expr) 'calcFunc-leq)
653 (or (and (eq signs 4) 0)
654 (and (memq signs '(1 2 3)) 1)))
655 ((eq (car math-simplify-expr) 'calcFunc-geq)
656 (or (and (eq signs 1) 0)
657 (and (memq signs '(2 4 6)) 1))))
658 math-simplify-expr))))
660 (defun math-simplify-add-term (np dp minus lplain)
661 (or (math-vectorp (car np))
664 (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
666 (if (setq temp (math-combine-sum n (nth 2 d)
667 minus (eq (car d) '+) t))
668 (if (or lplain (eq (math-looks-negp temp) minus))
670 (setcar np (setq n (if minus (math-neg temp) temp)))
671 (setcar (cdr (cdr d)) 0))
674 (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
678 (if (setq temp (math-combine-sum n d minus t t))
681 (eq (math-looks-negp temp) minus)))
683 (setcar np (setq n (if minus (math-neg temp) temp)))
687 (setcar dp (setq n (math-neg temp)))))))))
689 (math-defsimplify calcFunc-sin
690 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
691 (nth 1 (nth 1 math-simplify-expr)))
692 (and (math-looks-negp (nth 1 math-simplify-expr))
693 (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr)))))
694 (and (eq calc-angle-mode 'rad)
695 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
697 (math-known-sin (car n) (nth 1 n) 120 0))))
698 (and (eq calc-angle-mode 'deg)
699 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
701 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
702 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
703 (list 'calcFunc-sqrt (math-sub 1 (math-sqr
704 (nth 1 (nth 1 math-simplify-expr))))))
705 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
706 (math-div (nth 1 (nth 1 math-simplify-expr))
708 (math-add 1 (math-sqr
709 (nth 1 (nth 1 math-simplify-expr)))))))
710 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
711 (and m (integerp (car m))
712 (let ((n (car m)) (a (nth 1 m)))
714 (list '* (list 'calcFunc-sin (list '* (1- n) a))
715 (list 'calcFunc-cos a))
716 (list '* (list 'calcFunc-cos (list '* (1- n) a))
717 (list 'calcFunc-sin a))))))))
719 (math-defsimplify calcFunc-cos
720 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
721 (nth 1 (nth 1 math-simplify-expr)))
722 (and (math-looks-negp (nth 1 math-simplify-expr))
723 (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr))))
724 (and (eq calc-angle-mode 'rad)
725 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
727 (math-known-sin (car n) (nth 1 n) 120 300))))
728 (and (eq calc-angle-mode 'deg)
729 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
731 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
732 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
734 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))
735 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
739 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
740 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
741 (and m (integerp (car m))
742 (let ((n (car m)) (a (nth 1 m)))
744 (list '* (list 'calcFunc-cos (list '* (1- n) a))
745 (list 'calcFunc-cos a))
746 (list '* (list 'calcFunc-sin (list '* (1- n) a))
747 (list 'calcFunc-sin a))))))))
749 (defun math-should-expand-trig (x &optional hyperbolic)
750 (let ((m (math-is-multiple x)))
751 (and math-living-dangerously
752 m (or (and (integerp (car m)) (> (car m) 1))
753 (equal (car m) '(frac 1 2)))
755 (memq (car-safe (nth 1 m))
757 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
758 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
759 (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
760 (eq hyperbolic 'exp)))
763 (defun math-known-sin (plus n mul off)
764 (setq n (math-mul n mul))
765 (and (math-num-integerp n)
766 (setq n (math-mod (math-add (math-trunc n) off) 240))
768 (and (setq n (math-known-sin plus (- n 120) 1 0))
772 (if (math-zerop plus)
773 (and (or calc-symbolic-mode
777 (10 . (/ (calcFunc-sqrt
778 (- 2 (calcFunc-sqrt 3))) 2))
779 (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
780 (15 . (/ (calcFunc-sqrt
781 (- 2 (calcFunc-sqrt 2))) 2))
783 (24 . (* (^ (/ 1 2) (/ 3 2))
785 (- 5 (calcFunc-sqrt 5)))))
786 (30 . (/ (calcFunc-sqrt 2) 2))
787 (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
788 (40 . (/ (calcFunc-sqrt 3) 2))
789 (45 . (/ (calcFunc-sqrt
790 (+ 2 (calcFunc-sqrt 2))) 2))
791 (48 . (* (^ (/ 1 2) (/ 3 2))
793 (+ 5 (calcFunc-sqrt 5)))))
794 (50 . (/ (calcFunc-sqrt
795 (+ 2 (calcFunc-sqrt 3))) 2))
797 (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
798 ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
801 (math-defsimplify calcFunc-tan
802 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan)
803 (nth 1 (nth 1 math-simplify-expr)))
804 (and (math-looks-negp (nth 1 math-simplify-expr))
805 (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr)))))
806 (and (eq calc-angle-mode 'rad)
807 (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi))))
809 (math-known-tan (car n) (nth 1 n) 120))))
810 (and (eq calc-angle-mode 'deg)
811 (let ((n (math-integer-plus (nth 1 math-simplify-expr))))
813 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
814 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin)
815 (math-div (nth 1 (nth 1 math-simplify-expr))
817 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
818 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos)
819 (math-div (list 'calcFunc-sqrt
820 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))
821 (nth 1 (nth 1 math-simplify-expr))))
822 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr))))
824 (if (equal (car m) '(frac 1 2))
825 (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
826 (list 'calcFunc-sin (nth 1 m)))
827 (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr))
828 (list 'calcFunc-cos (nth 1 math-simplify-expr))))))))
830 (defun math-known-tan (plus n mul)
831 (setq n (math-mul n mul))
832 (and (math-num-integerp n)
833 (setq n (math-mod (math-trunc n) 120))
835 (and (setq n (math-known-tan plus (- 120 n) 1))
837 (if (math-zerop plus)
838 (and (or calc-symbolic-mode
840 (cdr (assq n '( (0 . 0)
841 (10 . (- 2 (calcFunc-sqrt 3)))
843 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
844 (15 . (- (calcFunc-sqrt 2) 1))
845 (20 . (/ (calcFunc-sqrt 3) 3))
847 (- 5 (* 2 (calcFunc-sqrt 5)))))
850 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
851 (40 . (calcFunc-sqrt 3))
852 (45 . (+ (calcFunc-sqrt 2) 1))
854 (+ 5 (* 2 (calcFunc-sqrt 5)))))
855 (50 . (+ 2 (calcFunc-sqrt 3)))
856 (60 . (var uinf var-uinf))))))
857 (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
858 ((eq n 60) (math-normalize (list '/ -1
859 (list 'calcFunc-tan plus))))
862 (math-defsimplify calcFunc-sinh
863 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
864 (nth 1 (nth 1 math-simplify-expr)))
865 (and (math-looks-negp (nth 1 math-simplify-expr))
866 (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr)))))
867 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
868 math-living-dangerously
870 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
871 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
872 math-living-dangerously
873 (math-div (nth 1 (nth 1 math-simplify-expr))
875 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
876 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
877 (and m (integerp (car m))
878 (let ((n (car m)) (a (nth 1 m)))
881 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
882 (list 'calcFunc-cosh a))
883 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
884 (list 'calcFunc-sinh a)))))))))
886 (math-defsimplify calcFunc-cosh
887 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
888 (nth 1 (nth 1 math-simplify-expr)))
889 (and (math-looks-negp (nth 1 math-simplify-expr))
890 (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr))))
891 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
892 math-living-dangerously
894 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))
895 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
896 math-living-dangerously
899 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))
900 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
901 (and m (integerp (car m))
902 (let ((n (car m)) (a (nth 1 m)))
905 (list '* (list 'calcFunc-cosh (list '* (1- n) a))
906 (list 'calcFunc-cosh a))
907 (list '* (list 'calcFunc-sinh (list '* (1- n) a))
908 (list 'calcFunc-sinh a)))))))))
910 (math-defsimplify calcFunc-tanh
911 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh)
912 (nth 1 (nth 1 math-simplify-expr)))
913 (and (math-looks-negp (nth 1 math-simplify-expr))
914 (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr)))))
915 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh)
916 math-living-dangerously
917 (math-div (nth 1 (nth 1 math-simplify-expr))
919 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))))
920 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh)
921 math-living-dangerously
922 (math-div (list 'calcFunc-sqrt
923 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))
924 (nth 1 (nth 1 math-simplify-expr))))
925 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t)))
927 (if (equal (car m) '(frac 1 2))
928 (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
929 (list 'calcFunc-sinh (nth 1 m)))
930 (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr))
931 (list 'calcFunc-cosh (nth 1 math-simplify-expr))))))))
933 (math-defsimplify calcFunc-arcsin
934 (or (and (math-looks-negp (nth 1 math-simplify-expr))
935 (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr)))))
936 (and (eq (nth 1 math-simplify-expr) 1)
937 (math-quarter-circle t))
938 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
939 (math-div (math-half-circle t) 6))
940 (and math-living-dangerously
941 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
942 (nth 1 (nth 1 math-simplify-expr)))
943 (and math-living-dangerously
944 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
945 (math-sub (math-quarter-circle t)
946 (nth 1 (nth 1 math-simplify-expr))))))
948 (math-defsimplify calcFunc-arccos
949 (or (and (eq (nth 1 math-simplify-expr) 0)
950 (math-quarter-circle t))
951 (and (eq (nth 1 math-simplify-expr) -1)
952 (math-half-circle t))
953 (and (equal (nth 1 math-simplify-expr) '(frac 1 2))
954 (math-div (math-half-circle t) 3))
955 (and (equal (nth 1 math-simplify-expr) '(frac -1 2))
956 (math-div (math-mul (math-half-circle t) 2) 3))
957 (and math-living-dangerously
958 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
959 (nth 1 (nth 1 math-simplify-expr)))
960 (and math-living-dangerously
961 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin)
962 (math-sub (math-quarter-circle t)
963 (nth 1 (nth 1 math-simplify-expr))))))
965 (math-defsimplify calcFunc-arctan
966 (or (and (math-looks-negp (nth 1 math-simplify-expr))
967 (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr)))))
968 (and (eq (nth 1 math-simplify-expr) 1)
969 (math-div (math-half-circle t) 4))
970 (and math-living-dangerously
971 (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan)
972 (nth 1 (nth 1 math-simplify-expr)))))
974 (math-defsimplify calcFunc-arcsinh
975 (or (and (math-looks-negp (nth 1 math-simplify-expr))
976 (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr)))))
977 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh)
978 (or math-living-dangerously
979 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
980 (nth 1 (nth 1 math-simplify-expr)))))
982 (math-defsimplify calcFunc-arccosh
983 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
984 (or math-living-dangerously
985 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
986 (nth 1 (nth 1 math-simplify-expr))))
988 (math-defsimplify calcFunc-arctanh
989 (or (and (math-looks-negp (nth 1 math-simplify-expr))
990 (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr)))))
991 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh)
992 (or math-living-dangerously
993 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
994 (nth 1 (nth 1 math-simplify-expr)))))
996 (math-defsimplify calcFunc-sqrt
997 (math-simplify-sqrt))
999 (defun math-simplify-sqrt ()
1000 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac)
1001 (math-div (list 'calcFunc-sqrt
1002 (math-mul (nth 1 (nth 1 math-simplify-expr))
1003 (nth 2 (nth 1 math-simplify-expr))))
1004 (nth 2 (nth 1 math-simplify-expr))))
1005 (let ((fac (if (math-objectp (nth 1 math-simplify-expr))
1006 (math-squared-factor (nth 1 math-simplify-expr))
1007 (math-common-constant-factor (nth 1 math-simplify-expr)))))
1008 (and fac (not (eq fac 1))
1009 (math-mul (math-normalize (list 'calcFunc-sqrt fac))
1011 (list 'calcFunc-sqrt
1012 (math-cancel-common-factor
1013 (nth 1 math-simplify-expr) fac))))))
1014 (and math-living-dangerously
1015 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1016 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1)
1017 (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^)
1018 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2)
1019 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1022 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr))))))
1023 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr))))
1026 (nth 1 (nth 1 (nth 2
1027 (nth 1 math-simplify-expr))))))))
1028 (and (eq (car-safe (nth 1 math-simplify-expr)) '-)
1029 (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1)
1030 (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^)
1031 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2)
1032 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr))))
1034 (list 'calcFunc-sinh
1035 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr)))))))
1036 (and (eq (car-safe (nth 1 math-simplify-expr)) '+)
1037 (let ((a (nth 1 (nth 1 math-simplify-expr)))
1038 (b (nth 2 (nth 1 math-simplify-expr))))
1039 (and (or (and (math-equal-int a 1)
1040 (setq a b b (nth 1 (nth 1 math-simplify-expr))))
1041 (math-equal-int b 1))
1042 (eq (car-safe a) '^)
1043 (math-equal-int (nth 2 a) 2)
1044 (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
1045 (list 'calcFunc-cosh (nth 1 (nth 1 a))))
1046 (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
1047 (list '/ 1 (list 'calcFunc-cos
1048 (nth 1 (nth 1 a)))))))))
1049 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1051 (nth 1 (nth 1 math-simplify-expr))
1052 (math-div (nth 2 (nth 1 math-simplify-expr)) 2)))
1053 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1054 (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4)))
1055 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1056 (list (car (nth 1 math-simplify-expr))
1057 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1058 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))))
1059 (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -))
1060 (not (math-any-floats (nth 1 math-simplify-expr)))
1061 (let ((f (calcFunc-factors (calcFunc-expand
1062 (nth 1 math-simplify-expr)))))
1063 (and (math-vectorp f)
1064 (or (> (length f) 2)
1065 (> (nth 2 (nth 1 f)) 1))
1066 (let ((out 1) (rest 1) (sums 1) fac pow)
1067 (while (setq f (cdr f))
1068 (setq fac (nth 1 (car f))
1069 pow (nth 2 (car f)))
1071 (setq out (math-mul out (math-pow
1075 (if (memq (car-safe fac) '(+ -))
1076 (setq sums (math-mul-thru sums fac))
1077 (setq rest (math-mul rest fac)))))
1078 (and (not (and (eq out 1) (memq rest '(1 -1))))
1081 (list 'calcFunc-sqrt
1082 (math-mul sums rest))))))))))))
1084 ;;; Rather than factoring x into primes, just check for the first ten primes.
1085 (defun math-squared-factor (x)
1086 (if (Math-integerp x)
1087 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1091 (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
1093 fac (math-mul fac (car prsqr)))
1094 (setq prsqr (cdr prsqr))))
1097 (math-defsimplify calcFunc-exp
1098 (math-simplify-exp (nth 1 math-simplify-expr)))
1100 (defun math-simplify-exp (x)
1101 (or (and (eq (car-safe x) 'calcFunc-ln)
1103 (and math-living-dangerously
1104 (or (and (eq (car-safe x) 'calcFunc-arcsinh)
1106 (list 'calcFunc-sqrt
1107 (math-add (math-sqr (nth 1 x)) 1))))
1108 (and (eq (car-safe x) 'calcFunc-arccosh)
1110 (list 'calcFunc-sqrt
1111 (math-sub (math-sqr (nth 1 x)) 1))))
1112 (and (eq (car-safe x) 'calcFunc-arctanh)
1113 (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
1114 (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
1115 (let ((m (math-should-expand-trig x 'exp)))
1116 (and m (integerp (car m))
1117 (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
1118 (and calc-symbolic-mode
1119 (math-known-imagp x)
1120 (let* ((ip (calcFunc-im x))
1121 (n (math-linear-in ip '(var pi var-pi)))
1124 (setq s (math-known-sin (car n) (nth 1 n) 120 0))
1125 (setq c (math-known-sin (car n) (nth 1 n) 120 300))
1126 (list '+ c (list '* s '(var i var-i))))))))
1128 (math-defsimplify calcFunc-ln
1129 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1130 (or math-living-dangerously
1131 (math-known-realp (nth 1 (nth 1 math-simplify-expr))))
1132 (nth 1 (nth 1 math-simplify-expr)))
1133 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1134 (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e))
1135 (or math-living-dangerously
1136 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1137 (nth 2 (nth 1 math-simplify-expr)))
1138 (and calc-symbolic-mode
1139 (math-known-negp (nth 1 math-simplify-expr))
1140 (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr)))
1141 '(* (var pi var-pi) (var i var-i))))
1142 (and calc-symbolic-mode
1143 (math-known-imagp (nth 1 math-simplify-expr))
1144 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr)))
1145 (ips (math-possible-signs ip)))
1146 (or (and (memq ips '(4 6))
1147 (math-add (list 'calcFunc-ln ip)
1148 '(/ (* (var pi var-pi) (var i var-i)) 2)))
1149 (and (memq ips '(1 3))
1150 (math-sub (list 'calcFunc-ln (math-neg ip))
1151 '(/ (* (var pi var-pi) (var i var-i)) 2))))))))
1154 (math-simplify-pow))
1156 (defun math-simplify-pow ()
1157 (or (and math-living-dangerously
1158 (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1160 (nth 1 (nth 1 math-simplify-expr))
1161 (math-mul (nth 2 math-simplify-expr)
1162 (nth 2 (nth 1 math-simplify-expr)))))
1163 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt)
1165 (nth 1 (nth 1 math-simplify-expr))
1166 (math-div (nth 2 math-simplify-expr) 2)))
1167 (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1168 (list (car (nth 1 math-simplify-expr))
1169 (list '^ (nth 1 (nth 1 math-simplify-expr))
1170 (nth 2 math-simplify-expr))
1171 (list '^ (nth 2 (nth 1 math-simplify-expr))
1172 (nth 2 math-simplify-expr))))))
1173 (and (math-equal-int (nth 1 math-simplify-expr) 10)
1174 (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10)
1175 (nth 1 (nth 2 math-simplify-expr)))
1176 (and (equal (nth 1 math-simplify-expr) '(var e var-e))
1177 (math-simplify-exp (nth 2 math-simplify-expr)))
1178 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp)
1179 (not math-integrating)
1180 (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr))
1181 (nth 2 math-simplify-expr))))
1182 (and (equal (nth 1 math-simplify-expr) '(var i var-i))
1184 (math-num-integerp (nth 2 math-simplify-expr))
1185 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4)))
1187 ((eq x 1) (nth 1 math-simplify-expr))
1189 ((eq x 3) (math-neg (nth 1 math-simplify-expr))))))
1190 (and math-integrating
1191 (integerp (nth 2 math-simplify-expr))
1192 (>= (nth 2 math-simplify-expr) 2)
1193 (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos)
1194 (math-mul (math-pow (nth 1 math-simplify-expr)
1195 (- (nth 2 math-simplify-expr) 2))
1199 (nth 1 (nth 1 math-simplify-expr)))))))
1200 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh)
1201 (math-mul (math-pow (nth 1 math-simplify-expr)
1202 (- (nth 2 math-simplify-expr) 2))
1205 (list 'calcFunc-sinh
1206 (nth 1 (nth 1 math-simplify-expr)))))))))
1207 (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac)
1208 (Math-ratp (nth 1 math-simplify-expr))
1209 (Math-posp (nth 1 math-simplify-expr))
1210 (if (equal (nth 2 math-simplify-expr) '(frac 1 2))
1211 (list 'calcFunc-sqrt (nth 1 math-simplify-expr))
1212 (let ((flr (math-floor (nth 2 math-simplify-expr))))
1213 (and (not (Math-zerop flr))
1214 (list '* (list '^ (nth 1 math-simplify-expr) flr)
1215 (list '^ (nth 1 math-simplify-expr)
1216 (math-sub (nth 2 math-simplify-expr) flr)))))))
1217 (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2)
1218 (let ((temp (math-simplify-sqrt)))
1220 (list '^ temp (math-mul (nth 2 math-simplify-expr) 2)))))))
1222 (math-defsimplify calcFunc-log10
1223 (and (eq (car-safe (nth 1 math-simplify-expr)) '^)
1224 (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10)
1225 (or math-living-dangerously
1226 (math-known-realp (nth 2 (nth 1 math-simplify-expr))))
1227 (nth 2 (nth 1 math-simplify-expr))))
1230 (math-defsimplify calcFunc-erf
1231 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1232 (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr)))))
1233 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1234 (list 'calcFunc-conj
1235 (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr)))))))
1237 (math-defsimplify calcFunc-erfc
1238 (or (and (math-looks-negp (nth 1 math-simplify-expr))
1239 (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr)))))
1240 (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj)
1241 (list 'calcFunc-conj
1242 (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr)))))))
1245 (defun math-linear-in (expr term &optional always)
1246 (if (math-expr-contains expr term)
1247 (let* ((calc-prefer-frac t)
1248 (p (math-is-polynomial expr term 1)))
1251 (and always (list expr 0))))
1253 (defun math-multiple-of (expr term)
1254 (let ((p (math-linear-in expr term)))
1256 (math-zerop (car p))
1259 ; not perfect, but it'll do
1260 (defun math-integer-plus (expr)
1261 (cond ((Math-integerp expr)
1263 ((and (memq (car expr) '(+ -))
1264 (Math-integerp (nth 1 expr)))
1265 (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
1267 ((and (memq (car expr) '(+ -))
1268 (Math-integerp (nth 2 expr)))
1270 (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
1273 (defun math-is-linear (expr &optional always)
1276 (if (eq (car-safe expr) '+)
1277 (if (Math-objectp (nth 1 expr))
1278 (setq offset (nth 1 expr)
1280 (if (Math-objectp (nth 2 expr))
1281 (setq offset (nth 2 expr)
1282 expr (nth 1 expr))))
1283 (if (eq (car-safe expr) '-)
1284 (if (Math-objectp (nth 1 expr))
1285 (setq offset (nth 1 expr)
1286 expr (math-neg (nth 2 expr)))
1287 (if (Math-objectp (nth 2 expr))
1288 (setq offset (math-neg (nth 2 expr))
1289 expr (nth 1 expr))))))
1290 (setq coef (math-is-multiple expr always))
1292 (list offset (or (car coef) 1) (or (nth 1 coef) expr))
1296 (defun math-is-multiple (expr &optional always)
1297 (or (if (eq (car-safe expr) '*)
1298 (if (Math-objectp (nth 1 expr))
1299 (list (nth 1 expr) (nth 2 expr)))
1300 (if (eq (car-safe expr) '/)
1301 (if (and (Math-objectp (nth 1 expr))
1302 (not (math-equal-int (nth 1 expr) 1)))
1303 (list (nth 1 expr) (math-div 1 (nth 2 expr)))
1304 (if (Math-objectp (nth 2 expr))
1305 (list (math-div 1 (nth 2 expr)) (nth 1 expr))
1306 (let ((res (math-is-multiple (nth 1 expr))))
1309 (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
1310 (setq res (math-is-multiple (nth 2 expr)))
1312 (list (math-div 1 (car res))
1313 (math-div (nth 1 expr)
1314 (nth 2 (nth 2 expr)))))))))
1315 (if (eq (car-safe expr) 'neg)
1316 (list -1 (nth 1 expr)))))
1317 (if (Math-objvecp expr)
1323 (defun calcFunc-lin (expr &optional var)
1325 (let ((res (math-linear-in expr var t)))
1326 (or res (math-reject-arg expr "Linear term expected"))
1327 (list 'vec (car res) (nth 1 res) var))
1328 (let ((res (math-is-linear expr t)))
1329 (or res (math-reject-arg expr "Linear term expected"))
1332 (defun calcFunc-linnt (expr &optional var)
1334 (let ((res (math-linear-in expr var)))
1335 (or res (math-reject-arg expr "Linear term expected"))
1336 (list 'vec (car res) (nth 1 res) var))
1337 (let ((res (math-is-linear expr)))
1338 (or res (math-reject-arg expr "Linear term expected"))
1341 (defun calcFunc-islin (expr &optional var)
1342 (if (and (Math-objvecp expr) (not var))
1344 (calcFunc-lin expr var)
1347 (defun calcFunc-islinnt (expr &optional var)
1348 (if (Math-objvecp expr)
1350 (calcFunc-linnt expr var)
1356 ;;; Simple operations on expressions.
1358 ;;; Return number of occurrences of thing in expr, or nil if none.
1359 (defun math-expr-contains-count (expr thing)
1360 (cond ((equal expr thing) 1)
1361 ((Math-primp expr) nil)
1364 (while (setq expr (cdr expr))
1365 (setq num (+ num (or (math-expr-contains-count
1366 (car expr) thing) 0))))
1370 (defun math-expr-contains (expr thing)
1371 (cond ((equal expr thing) 1)
1372 ((Math-primp expr) nil)
1374 (while (and (setq expr (cdr expr))
1375 (not (math-expr-contains (car expr) thing))))
1378 ;;; Return non-nil if any variable of thing occurs in expr.
1379 (defun math-expr-depends (expr thing)
1380 (if (Math-primp thing)
1381 (and (eq (car-safe thing) 'var)
1382 (math-expr-contains expr thing))
1383 (while (and (setq thing (cdr thing))
1384 (not (math-expr-depends expr (car thing)))))
1387 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1389 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1390 ;; for math-expr-subst, but used by math-expr-subst-rec.
1391 (defvar math-expr-subst-old)
1392 (defvar math-expr-subst-new)
1394 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new)
1395 (math-expr-subst-rec expr))
1397 (defalias 'calcFunc-subst 'math-expr-subst)
1399 (defun math-expr-subst-rec (expr)
1400 (cond ((equal expr math-expr-subst-old) math-expr-subst-new)
1401 ((Math-primp expr) expr)
1402 ((memq (car expr) '(calcFunc-deriv
1404 (if (= (length expr) 2)
1405 (if (equal (nth 1 expr) math-expr-subst-old)
1406 (append expr (list math-expr-subst-new))
1408 (list (car expr) (nth 1 expr)
1409 (math-expr-subst-rec (nth 2 expr)))))
1412 (mapcar 'math-expr-subst-rec (cdr expr))))))
1414 ;;; Various measures of the size of an expression.
1415 (defun math-expr-weight (expr)
1416 (if (Math-primp expr)
1419 (while (setq expr (cdr expr))
1420 (setq w (+ w (math-expr-weight (car expr)))))
1423 (defun math-expr-height (expr)
1424 (if (Math-primp expr)
1427 (while (setq expr (cdr expr))
1428 (setq h (max h (math-expr-height (car expr)))))
1434 ;;; Polynomial operations (to support the integrator and solve-for).
1436 (defun calcFunc-collect (expr base)
1437 (let ((p (math-is-polynomial expr base 50 t)))
1439 (math-normalize ; fix selection bug
1440 (math-build-polynomial-expr p base))
1443 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1444 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1445 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1447 ;; The variables math-is-poly-degree and math-is-poly-loose are local to
1448 ;; math-is-polynomial, but are used by math-is-poly-rec
1449 (defvar math-is-poly-degree)
1450 (defvar math-is-poly-loose)
1452 (defun math-is-polynomial (expr var &optional math-is-poly-degree math-is-poly-loose)
1453 (let* ((math-poly-base-variable (if math-is-poly-loose
1454 (if (eq math-is-poly-loose 'gen) var '(var XXX XXX))
1455 math-poly-base-variable))
1456 (poly (math-is-poly-rec expr math-poly-neg-powers)))
1457 (and (or (null math-is-poly-degree)
1458 (<= (length poly) (1+ math-is-poly-degree)))
1461 (defun math-is-poly-rec (expr negpow)
1463 (or (cond ((or (equal expr var)
1464 (eq (car-safe expr) '^))
1467 (or (equal expr var)
1468 (setq pow (nth 2 expr)
1470 (or (eq math-poly-mult-powers 1)
1471 (setq pow (let ((m (math-is-multiple pow 1)))
1472 (and (eq (car-safe (car m)) 'cplx)
1473 (Math-zerop (nth 1 (car m)))
1474 (setq m (list (nth 2 (car m))
1477 (and (if math-poly-mult-powers
1478 (equal math-poly-mult-powers
1480 (setq math-poly-mult-powers (nth 1 m)))
1481 (or (equal expr var)
1482 (eq math-poly-mult-powers 1))
1486 (setq pow (math-to-simple-fraction pow))
1487 (and (eq (car-safe pow) 'frac)
1488 math-poly-frac-powers
1490 (setq math-poly-frac-powers
1491 (calcFunc-lcm math-poly-frac-powers
1493 (or (memq math-poly-frac-powers '(1 nil))
1494 (setq pow (math-mul pow math-poly-frac-powers)))
1500 (let ((p1 (if (equal expr var)
1502 (math-is-poly-rec expr nil)))
1506 (or (null math-is-poly-degree)
1507 (<= (* (1- (length p1)) n) math-is-poly-degree))
1510 (setq accum (math-poly-mul accum p1)
1514 (math-is-poly-rec expr nil)
1515 (setq math-poly-neg-powers
1516 (cons (math-pow expr (- pow))
1517 math-poly-neg-powers))
1518 (list (list '^ expr pow))))))))
1519 ((Math-objectp expr)
1521 ((memq (car expr) '(+ -))
1522 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1524 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1526 (math-poly-mix p1 1 p2
1527 (if (eq (car expr) '+) 1 -1)))))))
1528 ((eq (car expr) 'neg)
1529 (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow)))
1531 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1533 (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
1535 (or (null math-is-poly-degree)
1536 (<= (- (+ (length p1) (length p2)) 2)
1537 math-is-poly-degree))
1538 (math-poly-mul p1 p2))))))
1540 (and (or (not (math-poly-depends (nth 2 expr) var))
1542 (math-is-poly-rec (nth 2 expr) nil)
1543 (setq math-poly-neg-powers
1544 (cons (nth 2 expr) math-poly-neg-powers))))
1545 (not (Math-zerop (nth 2 expr)))
1546 (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
1547 (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
1549 ((and (eq (car expr) 'calcFunc-exp)
1550 (equal var '(var e var-e)))
1551 (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
1552 ((and (eq (car expr) 'calcFunc-sqrt)
1553 math-poly-frac-powers)
1554 (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
1556 (and (or (not (math-poly-depends expr var))
1558 (not (eq (car expr) 'vec))
1561 ;;; Check if expr is a polynomial in var; if so, return its degree.
1562 (defun math-polynomial-p (expr var)
1563 (cond ((equal expr var) 1)
1564 ((Math-primp expr) 0)
1565 ((memq (car expr) '(+ -))
1566 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1568 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1571 (let ((p1 (math-polynomial-p (nth 1 expr) var))
1573 (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
1575 ((eq (car expr) 'neg)
1576 (math-polynomial-p (nth 1 expr) var))
1577 ((and (eq (car expr) '/)
1578 (not (math-poly-depends (nth 2 expr) var)))
1579 (math-polynomial-p (nth 1 expr) var))
1580 ((and (eq (car expr) '^)
1581 (natnump (nth 2 expr)))
1582 (let ((p1 (math-polynomial-p (nth 1 expr) var)))
1583 (and p1 (* p1 (nth 2 expr)))))
1584 ((math-poly-depends expr var) nil)
1587 (defun math-poly-depends (expr var)
1588 (if math-poly-base-variable
1589 (math-expr-contains expr math-poly-base-variable)
1590 (math-expr-depends expr var)))
1592 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1593 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1594 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1595 (defvar math-poly-base-const-ok)
1596 (defvar math-poly-base-pred)
1598 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1599 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1600 ;; by math-polynomial-base.
1602 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred)
1603 (or math-poly-base-pred
1604 (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p
1605 math-poly-base-top-expr base)))))
1606 (or (let ((math-poly-base-const-ok nil))
1607 (math-polynomial-base-rec math-poly-base-top-expr))
1608 (let ((math-poly-base-const-ok t))
1609 (math-polynomial-base-rec math-poly-base-top-expr))))
1611 (defun math-polynomial-base-rec (mpb-expr)
1612 (and (not (Math-objvecp mpb-expr))
1613 (or (and (memq (car mpb-expr) '(+ - *))
1614 (or (math-polynomial-base-rec (nth 1 mpb-expr))
1615 (math-polynomial-base-rec (nth 2 mpb-expr))))
1616 (and (memq (car mpb-expr) '(/ neg))
1617 (math-polynomial-base-rec (nth 1 mpb-expr)))
1618 (and (eq (car mpb-expr) '^)
1619 (math-polynomial-base-rec (nth 1 mpb-expr)))
1620 (and (eq (car mpb-expr) 'calcFunc-exp)
1621 (math-polynomial-base-rec '(var e var-e)))
1622 (and (or math-poly-base-const-ok (math-expr-contains-vars mpb-expr))
1623 (funcall math-poly-base-pred mpb-expr)
1626 ;;; Return non-nil if expr refers to any variables.
1627 (defun math-expr-contains-vars (expr)
1628 (or (eq (car-safe expr) 'var)
1629 (and (not (Math-primp expr))
1631 (while (and (setq expr (cdr expr))
1632 (not (math-expr-contains-vars (car expr)))))
1635 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1636 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1637 (defun math-poly-simplify (p)
1639 (if (Math-zerop (nth (1- (length p)) p))
1640 (let ((pp (copy-sequence p)))
1641 (while (and (cdr pp)
1642 (Math-zerop (nth (1- (length pp)) pp)))
1643 (setcdr (nthcdr (- (length pp) 2) pp) nil))
1647 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1648 ;;; coefficients ac, bc. Result may be unsimplified.
1649 (defun math-poly-mix (a ac b bc)
1651 (cons (math-add (math-mul (or (car a) 0) ac)
1652 (math-mul (or (car b) 0) bc))
1653 (math-poly-mix (cdr a) ac (cdr b) bc))))
1655 (defun math-poly-zerop (a)
1657 (and (null (cdr a)) (Math-zerop (car a)))))
1659 ;;; Multiply two polynomials in list form.
1660 (defun math-poly-mul (a b)
1662 (math-poly-mix b (car a)
1663 (math-poly-mul (cdr a) (cons 0 b)) 1)))
1665 ;;; Build an expression from a polynomial list.
1666 (defun math-build-polynomial-expr (p var)
1668 (if (Math-numberp var)
1669 (math-with-extra-prec 1
1670 (let* ((rp (reverse p))
1672 (while (setq rp (cdr rp))
1673 (setq accum (math-add (car rp) (math-mul accum var))))
1675 (let* ((rp (reverse p))
1676 (n (1- (length rp)))
1677 (accum (math-mul (car rp) (math-pow var n)))
1679 (while (setq rp (cdr rp))
1681 (or (math-zerop (car rp))
1682 (setq accum (list (if (math-looks-negp (car rp)) '- '+)
1684 (math-mul (if (math-looks-negp (car rp))
1687 (math-pow var n))))))
1692 (defun math-to-simple-fraction (f)
1693 (or (and (eq (car-safe f) 'float)
1694 (or (and (>= (nth 2 f) 0)
1695 (math-scale-int (nth 1 f) (nth 2 f)))
1696 (and (integerp (nth 1 f))
1699 (math-make-frac (nth 1 f)
1700 (math-scale-int 1 (- (nth 2 f)))))))
1705 ;;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
1706 ;;; calc-alg.el ends here