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