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