1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <belanger@truman.edu>
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 2, or (at your option)
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; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 ;; This file is autoloaded from calc-ext.el.
37 (defun calc-alg-evaluate (arg)
40 (calc-with-default-simplification
41 (let ((math-simplify-only nil
))
42 (calc-modify-simplify-mode arg
)
43 (calc-enter-result 1 "dsmp" (calc-top 1))))))
45 (defun calc-modify-simplify-mode (arg)
46 (if (= (math-abs arg
) 2)
47 (setq calc-simplify-mode
'alg
)
48 (if (>= (math-abs arg
) 3)
49 (setq calc-simplify-mode
'ext
)))
51 (setq calc-simplify-mode
(list calc-simplify-mode
))))
53 (defun calc-simplify ()
56 (calc-with-default-simplification
57 (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
59 (defun calc-simplify-extended ()
62 (calc-with-default-simplification
63 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
65 (defun calc-expand-formula (arg)
68 (calc-with-default-simplification
69 (let ((math-simplify-only nil
))
70 (calc-modify-simplify-mode arg
)
71 (calc-enter-result 1 "expf"
73 (let ((math-expand-formulas t
))
75 (let ((top (calc-top-n 1)))
76 (or (math-expand-formula top
)
79 (defun calc-factor (arg)
82 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
83 'calcFunc-factors
'calcFunc-factor
)
86 (defun calc-expand (n)
89 (calc-enter-result 1 "expa"
90 (append (list 'calcFunc-expand
92 (and n
(list (prefix-numeric-value n
)))))))
94 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
95 (defun calcFunc-powerexpand (expr)
96 (math-normalize (math-map-tree 'math-powerexpand expr
)))
98 (defun math-powerexpand (expr)
99 (if (eq (car-safe expr
) '^
)
100 (let ((n (nth 2 expr
)))
101 (cond ((and (integerp n
)
107 (setq prod
(math-mul prod a
))
113 (a (math-pow (nth 1 expr
) -
1))
114 (prod (math-pow (nth 1 expr
) -
1)))
116 (setq prod
(math-mul a prod
))
123 (defun calc-powerexpand ()
126 (calc-enter-result 1 "pexp"
127 (calcFunc-powerexpand (calc-top-n 1)))))
129 (defun calc-collect (&optional var
)
130 (interactive "sCollect terms involving: ")
132 (if (or (equal var
"") (equal var
"$") (null var
))
133 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
134 (calc-top-list-n 2)))
135 (let ((var (math-read-expr var
)))
136 (if (eq (car-safe var
) 'error
)
137 (error "Bad format in expression: %s" (nth 1 var
)))
138 (calc-enter-result 1 "clct" (list 'calcFunc-collect
142 (defun calc-apart (arg)
145 (calc-unary-op "aprt" 'calcFunc-apart arg
)))
147 (defun calc-normalize-rat (arg)
150 (calc-unary-op "nrat" 'calcFunc-nrat arg
)))
152 (defun calc-poly-gcd (arg)
155 (calc-binary-op "pgcd" 'calcFunc-pgcd arg
)))
158 (defun calc-poly-div (arg)
161 (let ((calc-poly-div-remainder nil
))
162 (calc-binary-op "pdiv" 'calcFunc-pdiv arg
)
163 (if (and calc-poly-div-remainder
(null arg
))
165 (calc-clear-command-flag 'clear-message
)
166 (calc-record calc-poly-div-remainder
"prem")
167 (if (not (Math-zerop calc-poly-div-remainder
))
168 (message "(Remainder was %s)"
169 (math-format-flat-expr calc-poly-div-remainder
0))
170 (message "(No remainder)")))))))
172 (defun calc-poly-rem (arg)
175 (calc-binary-op "prem" 'calcFunc-prem arg
)))
177 (defun calc-poly-div-rem (arg)
180 (if (calc-is-hyperbolic)
181 (calc-binary-op "pdvr" 'calcFunc-pdivide arg
)
182 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg
))))
184 (defun calc-substitute (&optional oldname newname
)
185 (interactive "sSubstitute old: ")
187 (let (old new
(num 1) expr
)
188 (if (or (equal oldname
"") (equal oldname
"$") (null oldname
))
189 (setq new
(calc-top-n 1)
194 (progn (calc-unread-command ?\C-a
)
195 (setq newname
(read-string (concat "Substitute old: "
199 (if (or (equal newname
"") (equal newname
"$") (null newname
))
200 (setq new
(calc-top-n 1)
203 (setq new
(if (stringp newname
) (math-read-expr newname
) newname
))
204 (if (eq (car-safe new
) 'error
)
205 (error "Bad format in expression: %s" (nth 1 new
)))
206 (setq expr
(calc-top-n 1)))
207 (setq old
(if (stringp oldname
) (math-read-expr oldname
) oldname
))
208 (if (eq (car-safe old
) 'error
)
209 (error "Bad format in expression: %s" (nth 1 old
)))
210 (or (math-expr-contains expr old
)
211 (error "No occurrences found")))
212 (calc-enter-result num
"sbst" (math-expr-subst expr old new
)))))
215 (defun calc-has-rules (name)
216 (setq name
(calc-var-value name
))
218 (memq (car name
) '(vec calcFunc-assign calcFunc-condition
))
221 ;; math-eval-rules-cache and math-eval-rules-cache-other are
222 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
223 (defvar math-eval-rules-cache
)
224 (defvar math-eval-rules-cache-other
)
226 (defun math-recompile-eval-rules ()
227 (setq math-eval-rules-cache
(and (calc-has-rules 'var-EvalRules
)
228 (math-compile-rewrites
229 '(var EvalRules var-EvalRules
)))
230 math-eval-rules-cache-other
(assq nil math-eval-rules-cache
)
231 math-eval-rules-cache-tag
(calc-var-value 'var-EvalRules
)))
234 ;;; Try to expand a formula according to its definition.
235 (defun math-expand-formula (expr)
238 (or (get (car expr
) 'calc-user-defn
)
239 (get (car expr
) 'math-expandable
))
240 (let ((res (let ((math-expand-formulas t
))
241 (apply (car expr
) (cdr expr
)))))
242 (and (not (eq (car-safe res
) (car expr
)))
248 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
249 (defun math-beforep (a b
) ; [Public]
250 (cond ((and (Math-realp a
) (Math-realp b
))
251 (let ((comp (math-compare a b
)))
255 (> (length (memq (car-safe a
)
256 '(bigneg nil bigpos frac float
)))
257 (length (memq (car-safe b
)
258 '(bigneg nil bigpos frac float
))))))))
259 ((equal b
'(neg (var inf var-inf
))) nil
)
260 ((equal a
'(neg (var inf var-inf
))) t
)
261 ((equal a
'(var inf var-inf
)) nil
)
262 ((equal b
'(var inf var-inf
)) t
)
264 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
))
265 (if (or (math-beforep a
(nth 2 b
)) (Math-equal a
(nth 2 b
)))
270 (if (and (eq (car-safe a
) 'intv
) (math-intv-constp a
))
271 (if (math-beforep (nth 2 a
) b
)
275 ((and (eq (car a
) 'intv
) (eq (car b
) 'intv
)
276 (math-intv-constp a
) (math-intv-constp b
))
277 (let ((comp (math-compare (nth 2 a
) (nth 2 b
))))
278 (cond ((eq comp -
1) t
)
280 ((and (memq (nth 1 a
) '(2 3)) (memq (nth 1 b
) '(0 1))) t
)
281 ((and (memq (nth 1 a
) '(0 1)) (memq (nth 1 b
) '(2 3))) nil
)
282 ((eq (setq comp
(math-compare (nth 3 a
) (nth 3 b
))) -
1) t
)
284 ((and (memq (nth 1 a
) '(0 2)) (memq (nth 1 b
) '(1 3))) t
)
286 ((not (eq (not (Math-objectp a
)) (not (Math-objectp b
))))
289 (if (eq (car b
) 'var
)
290 (string-lessp (symbol-name (nth 1 a
)) (symbol-name (nth 1 b
)))
291 (not (Math-numberp b
))))
292 ((eq (car b
) 'var
) (Math-numberp a
))
293 ((eq (car a
) (car b
))
294 (while (and (setq a
(cdr a
) b
(cdr b
)) a
295 (equal (car a
) (car b
))))
298 (math-beforep (car a
) (car b
)))))
299 (t (string-lessp (symbol-name (car a
)) (symbol-name (car b
))))))
302 (defsubst math-simplify-extended
(a)
303 (let ((math-living-dangerously t
))
306 (defalias 'calcFunc-esimplify
'math-simplify-extended
)
308 ;; math-top-only is local to math-simplify, but is used by
309 ;; math-simplify-step, which is called by math-simplify.
310 (defvar math-top-only
)
312 (defun math-simplify (top-expr)
313 (let ((math-simplifying t
)
314 (math-top-only (consp calc-simplify-mode
))
315 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
316 '((var AlgSimpRules var-AlgSimpRules
)))
317 (and math-living-dangerously
318 (calc-has-rules 'var-ExtSimpRules
)
319 '((var ExtSimpRules var-ExtSimpRules
)))
320 (and math-simplifying-units
321 (calc-has-rules 'var-UnitSimpRules
)
322 '((var UnitSimpRules var-UnitSimpRules
)))
323 (and math-integrating
324 (calc-has-rules 'var-IntegSimpRules
)
325 '((var IntegSimpRules var-IntegSimpRules
)))))
328 (let ((r simp-rules
))
329 (setq res
(math-simplify-step (math-normalize top-expr
))
330 calc-simplify-mode
'(nil)
331 top-expr
(math-normalize res
))
333 (setq top-expr
(math-rewrite top-expr
(car r
)
334 '(neg (var inf var-inf
)))
336 (calc-with-default-simplification
337 (while (let ((r simp-rules
))
338 (setq res
(math-normalize top-expr
))
340 (setq res
(math-rewrite res
(car r
))
342 (not (equal top-expr
(setq res
(math-simplify-step res
)))))
343 (setq top-expr res
)))))
346 (defalias 'calcFunc-simplify
'math-simplify
)
348 ;;; The following has a "bug" in that if any recursive simplifications
349 ;;; occur only the first handler will be tried; this doesn't really
350 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
351 (defun math-simplify-step (a)
354 (let ((aa (if (or math-top-only
355 (memq (car a
) '(calcFunc-quote calcFunc-condition
358 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
359 (and (symbolp (car aa
))
360 (let ((handler (get (car aa
) 'math-simplify
)))
363 (equal (setq aa
(or (funcall (car handler
) aa
)
366 (setq handler
(cdr handler
))))))
370 (defmacro math-defsimplify
(funcs &rest code
)
374 (list 'put
(list 'quote func
) ''math-simplify
376 (list 'get
(list 'quote func
) ''math-simplify
)
379 (append '(lambda (math-simplify-expr))
381 (if (symbolp funcs
) (list funcs
) funcs
))))
382 (put 'math-defsimplify
'lisp-indent-hook
1)
384 ;; The function created by math-defsimplify uses the variable
385 ;; math-simplify-expr, and so is used by functions in math-defsimplify
386 (defvar math-simplify-expr
)
388 (math-defsimplify (+ -
)
389 (math-simplify-plus))
391 (defun math-simplify-plus ()
392 (cond ((and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
393 (Math-numberp (nth 2 (nth 1 math-simplify-expr
)))
394 (not (Math-numberp (nth 2 math-simplify-expr
))))
395 (let ((x (nth 2 math-simplify-expr
))
396 (op (car math-simplify-expr
)))
397 (setcar (cdr (cdr math-simplify-expr
)) (nth 2 (nth 1 math-simplify-expr
)))
398 (setcar math-simplify-expr
(car (nth 1 math-simplify-expr
)))
399 (setcar (cdr (cdr (nth 1 math-simplify-expr
))) x
)
400 (setcar (nth 1 math-simplify-expr
) op
)))
401 ((and (eq (car math-simplify-expr
) '+)
402 (Math-numberp (nth 1 math-simplify-expr
))
403 (not (Math-numberp (nth 2 math-simplify-expr
))))
404 (let ((x (nth 2 math-simplify-expr
)))
405 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
406 (setcar (cdr math-simplify-expr
) x
))))
407 (let ((aa math-simplify-expr
)
409 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
410 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 math-simplify-expr
)
412 (eq (car math-simplify-expr
) '-
) t
))
414 (setcar (cdr (cdr math-simplify-expr
)) temp
)
415 (setcar math-simplify-expr
'+)
416 (setcar (cdr (cdr aaa
)) 0)))
417 (setq aa
(nth 1 aa
)))
418 (if (setq temp
(math-combine-sum aaa
(nth 2 math-simplify-expr
)
419 nil
(eq (car math-simplify-expr
) '-
) t
))
421 (setcar (cdr (cdr math-simplify-expr
)) temp
)
422 (setcar math-simplify-expr
'+)
423 (setcar (cdr aa
) 0)))
427 (math-simplify-times))
429 (defun math-simplify-times ()
430 (if (eq (car-safe (nth 2 math-simplify-expr
)) '*)
431 (and (math-beforep (nth 1 (nth 2 math-simplify-expr
)) (nth 1 math-simplify-expr
))
432 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
433 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr
)) t
))
434 (let ((x (nth 1 math-simplify-expr
)))
435 (setcar (cdr math-simplify-expr
) (nth 1 (nth 2 math-simplify-expr
)))
436 (setcar (cdr (nth 2 math-simplify-expr
)) x
)))
437 (and (math-beforep (nth 2 math-simplify-expr
) (nth 1 math-simplify-expr
))
438 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
439 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
440 (let ((x (nth 2 math-simplify-expr
)))
441 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
442 (setcar (cdr math-simplify-expr
) x
))))
443 (let ((aa math-simplify-expr
)
445 (safe t
) (scalar (math-known-scalarp (nth 1 math-simplify-expr
))))
446 (if (and (Math-ratp (nth 1 math-simplify-expr
))
447 (setq temp
(math-common-constant-factor (nth 2 math-simplify-expr
))))
449 (setcar (cdr (cdr math-simplify-expr
))
450 (math-cancel-common-factor (nth 2 math-simplify-expr
) temp
))
451 (setcar (cdr math-simplify-expr
) (math-mul (nth 1 math-simplify-expr
) temp
))))
452 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
454 (if (setq temp
(math-combine-prod (nth 1 math-simplify-expr
)
455 (nth 1 aaa
) nil nil t
))
457 (setcar (cdr math-simplify-expr
) temp
)
458 (setcar (cdr aaa
) 1)))
459 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
461 (if (and (setq temp
(math-combine-prod aaa
(nth 1 math-simplify-expr
) nil nil t
))
464 (setcar (cdr math-simplify-expr
) temp
)
465 (setcar (cdr (cdr aa
)) 1)))
466 (if (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
467 (memq (nth 1 (nth 1 math-simplify-expr
)) '(1 -
1)))
468 (math-div (math-mul (nth 2 math-simplify-expr
)
469 (nth 1 (nth 1 math-simplify-expr
)))
470 (nth 2 (nth 1 math-simplify-expr
)))
471 math-simplify-expr
)))
474 (math-simplify-divide))
476 (defun math-simplify-divide ()
477 (let ((np (cdr math-simplify-expr
))
479 (nn (and (or (eq (car math-simplify-expr
) '/)
480 (not (Math-realp (nth 2 math-simplify-expr
))))
481 (math-common-constant-factor (nth 2 math-simplify-expr
))))
485 (setq n
(and (or (eq (car math-simplify-expr
) '/)
486 (not (Math-realp (nth 1 math-simplify-expr
))))
487 (math-common-constant-factor (nth 1 math-simplify-expr
))))
488 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
490 (setcar (cdr math-simplify-expr
)
491 (math-mul (nth 2 nn
) (nth 1 math-simplify-expr
)))
492 (setcar (cdr (cdr math-simplify-expr
))
493 (math-cancel-common-factor (nth 2 math-simplify-expr
) nn
))
494 (if (and (math-negp nn
)
495 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
)))
496 (setcar math-simplify-expr
(nth 1 op
))))
497 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
499 (setcar (cdr math-simplify-expr
)
500 (math-cancel-common-factor (nth 1 math-simplify-expr
) n
))
501 (setcar (cdr (cdr math-simplify-expr
))
502 (math-cancel-common-factor (nth 2 math-simplify-expr
) n
))
503 (if (and (math-negp n
)
504 (setq op
(assq (car math-simplify-expr
)
505 calc-tweak-eqn-table
)))
506 (setcar math-simplify-expr
(nth 1 op
))))))))
507 (if (and (eq (car-safe (car np
)) '/)
508 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
510 (setq np
(cdr (nth 1 math-simplify-expr
)))
511 (while (eq (car-safe (setq n
(car np
))) '*)
512 (and (math-known-scalarp (nth 2 n
) t
)
513 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nil t
))
514 (setq np
(cdr (cdr n
))))
515 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nil t
)
517 np
(cdr (cdr (nth 1 math-simplify-expr
))))))
518 (while (eq (car-safe (setq n
(car np
))) '*)
519 (and (math-known-scalarp (nth 2 n
) t
)
520 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nover t
))
521 (setq np
(cdr (cdr n
))))
522 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nover t
)
525 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
526 ;; are local variables for math-simplify-divisor, but are used by
527 ;; math-simplify-one-divisor.
528 (defvar math-simplify-divisor-nover
)
529 (defvar math-simplify-divisor-dover
)
531 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
532 math-simplify-divisor-dover
)
533 (cond ((eq (car-safe (car dp
)) '/)
534 (math-simplify-divisor np
(cdr (car dp
))
535 math-simplify-divisor-nover
536 math-simplify-divisor-dover
)
537 (and (math-known-scalarp (nth 1 (car dp
)) t
)
538 (math-simplify-divisor np
(cdr (cdr (car dp
)))
539 math-simplify-divisor-nover
540 (not math-simplify-divisor-dover
))))
541 ((or (or (eq (car math-simplify-expr
) '/)
542 (let ((signs (math-possible-signs (car np
))))
543 (or (memq signs
'(1 4))
544 (and (memq (car math-simplify-expr
) '(calcFunc-eq calcFunc-neq
))
546 math-living-dangerously
)))
547 (math-numberp (car np
)))
550 (scalar (math-known-scalarp (car np
))))
551 (while (and (eq (car-safe (setq d
(car dp
))) '*)
553 (math-simplify-one-divisor np
(cdr d
))
554 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
557 (math-simplify-one-divisor np dp
))))))
559 (defun math-simplify-one-divisor (np dp
)
560 (let ((temp (math-combine-prod (car np
) (car dp
) math-simplify-divisor-nover
561 math-simplify-divisor-dover t
))
565 (and (not (memq (car math-simplify-expr
) '(/ calcFunc-eq calcFunc-neq
)))
566 (math-known-negp (car dp
))
567 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
))
568 (setcar math-simplify-expr
(nth 1 op
)))
569 (setcar np
(if math-simplify-divisor-nover
(math-div 1 temp
) temp
))
571 (and math-simplify-divisor-dover
(not math-simplify-divisor-nover
)
572 (eq (car math-simplify-expr
) '/)
573 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
574 (Math-integerp (nth 1 (car dp
)))
576 (setcar np
(math-mul (car np
)
577 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
578 (setcar dp
(nth 1 (car dp
))))))))
580 (defun math-common-constant-factor (expr)
581 (if (Math-realp expr
)
583 (and (not (memq expr
'(0 1 -
1)))
585 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
586 (math-common-constant-factor expr
)))
587 (if (memq (car expr
) '(+ - cplx sdev
))
588 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
589 (f2 (math-common-constant-factor (nth 2 expr
))))
591 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
593 (if (memq (car expr
) '(* polar
))
594 (math-common-constant-factor (nth 1 expr
))
595 (if (eq (car expr
) '/)
596 (or (math-common-constant-factor (nth 1 expr
))
597 (and (Math-integerp (nth 2 expr
))
598 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
600 (defun math-cancel-common-factor (expr val
)
601 (if (memq (car-safe expr
) '(+ - cplx sdev
))
603 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
604 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
606 (if (eq (car-safe expr
) '*)
607 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
608 (math-div expr val
))))
610 (defun math-frac-gcd (a b
)
615 (if (and (Math-integerp a
)
618 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
619 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
620 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
621 (math-gcd (nth 2 a
) (nth 2 b
)))))))
626 (defun math-simplify-mod ()
627 (and (Math-realp (nth 2 math-simplify-expr
))
628 (Math-posp (nth 2 math-simplify-expr
))
629 (let ((lin (math-is-linear (nth 1 math-simplify-expr
)))
632 (or (math-negp (car lin
))
633 (not (Math-lessp (car lin
) (nth 2 math-simplify-expr
))))
636 (math-mul (nth 1 lin
) (nth 2 lin
))
637 (math-mod (car lin
) (nth 2 math-simplify-expr
)))
638 (nth 2 math-simplify-expr
)))
640 (not (math-equal-int (nth 1 lin
) 1))
641 (math-num-integerp (nth 1 lin
))
642 (math-num-integerp (nth 2 math-simplify-expr
))
643 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 math-simplify-expr
)))
644 (not (math-equal-int t1
1))
649 (math-mul (math-div (nth 1 lin
) t1
)
651 (let ((calc-prefer-frac t
))
652 (math-div (car lin
) t1
)))
653 (math-div (nth 2 math-simplify-expr
) t1
))))
654 (and (math-equal-int (nth 2 math-simplify-expr
) 1)
655 (math-known-integerp (if lin
656 (math-mul (nth 1 lin
) (nth 2 lin
))
657 (nth 1 math-simplify-expr
)))
658 (if lin
(math-mod (car lin
) 1) 0))))))
660 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
661 calcFunc-gt calcFunc-leq calcFunc-geq
)
662 (if (= (length math-simplify-expr
) 3)
663 (math-simplify-ineq)))
665 (defun math-simplify-ineq ()
666 (let ((np (cdr math-simplify-expr
))
668 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
669 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr math-simplify-expr
))
672 (math-simplify-add-term np
(cdr (cdr math-simplify-expr
)) nil
673 (eq np
(cdr math-simplify-expr
)))
674 (math-simplify-divide)
675 (let ((signs (math-possible-signs (cons '-
(cdr math-simplify-expr
)))))
676 (or (cond ((eq (car math-simplify-expr
) 'calcFunc-eq
)
677 (or (and (eq signs
2) 1)
678 (and (memq signs
'(1 4 5)) 0)))
679 ((eq (car math-simplify-expr
) 'calcFunc-neq
)
680 (or (and (eq signs
2) 0)
681 (and (memq signs
'(1 4 5)) 1)))
682 ((eq (car math-simplify-expr
) 'calcFunc-lt
)
683 (or (and (eq signs
1) 1)
684 (and (memq signs
'(2 4 6)) 0)))
685 ((eq (car math-simplify-expr
) 'calcFunc-gt
)
686 (or (and (eq signs
4) 1)
687 (and (memq signs
'(1 2 3)) 0)))
688 ((eq (car math-simplify-expr
) 'calcFunc-leq
)
689 (or (and (eq signs
4) 0)
690 (and (memq signs
'(1 2 3)) 1)))
691 ((eq (car math-simplify-expr
) 'calcFunc-geq
)
692 (or (and (eq signs
1) 0)
693 (and (memq signs
'(2 4 6)) 1))))
694 math-simplify-expr
))))
696 (defun math-simplify-add-term (np dp minus lplain
)
697 (or (math-vectorp (car np
))
700 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
702 (if (setq temp
(math-combine-sum n
(nth 2 d
)
703 minus
(eq (car d
) '+) t
))
704 (if (or lplain
(eq (math-looks-negp temp
) minus
))
706 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
707 (setcar (cdr (cdr d
)) 0))
710 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
714 (if (setq temp
(math-combine-sum n d minus t t
))
717 (eq (math-looks-negp temp
) minus
)))
719 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
723 (setcar dp
(setq n
(math-neg temp
)))))))))
725 (math-defsimplify calcFunc-sin
726 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
727 (nth 1 (nth 1 math-simplify-expr
)))
728 (and (math-looks-negp (nth 1 math-simplify-expr
))
729 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 math-simplify-expr
)))))
730 (and (eq calc-angle-mode
'rad
)
731 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
733 (math-known-sin (car n
) (nth 1 n
) 120 0))))
734 (and (eq calc-angle-mode
'deg
)
735 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
737 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
738 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
739 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
740 (nth 1 (nth 1 math-simplify-expr
))))))
741 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
742 (math-div (nth 1 (nth 1 math-simplify-expr
))
744 (math-add 1 (math-sqr
745 (nth 1 (nth 1 math-simplify-expr
)))))))
746 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
747 (and m
(integerp (car m
))
748 (let ((n (car m
)) (a (nth 1 m
)))
750 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
751 (list 'calcFunc-cos a
))
752 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
753 (list 'calcFunc-sin a
))))))))
755 (math-defsimplify calcFunc-cos
756 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
757 (nth 1 (nth 1 math-simplify-expr
)))
758 (and (math-looks-negp (nth 1 math-simplify-expr
))
759 (list 'calcFunc-cos
(math-neg (nth 1 math-simplify-expr
))))
760 (and (eq calc-angle-mode
'rad
)
761 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
763 (math-known-sin (car n
) (nth 1 n
) 120 300))))
764 (and (eq calc-angle-mode
'deg
)
765 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
767 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
768 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
770 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))
771 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
775 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
776 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
777 (and m
(integerp (car m
))
778 (let ((n (car m
)) (a (nth 1 m
)))
780 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
781 (list 'calcFunc-cos a
))
782 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
783 (list 'calcFunc-sin a
))))))))
785 (math-defsimplify calcFunc-sec
786 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
787 (list 'calcFunc-sec
(math-neg (nth 1 math-simplify-expr
))))
788 (and (eq calc-angle-mode
'rad
)
789 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
791 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 300)))))
792 (and (eq calc-angle-mode
'deg
)
793 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
795 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300)))))
796 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
800 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
801 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
804 (nth 1 (nth 1 math-simplify-expr
))))
805 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
808 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
810 (math-defsimplify calcFunc-csc
811 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
812 (math-neg (list 'calcFunc-csc
(math-neg (nth 1 math-simplify-expr
)))))
813 (and (eq calc-angle-mode
'rad
)
814 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
816 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 0)))))
817 (and (eq calc-angle-mode
'deg
)
818 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
820 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0)))))
821 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
822 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
823 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
826 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
827 (nth 1 (nth 1 math-simplify-expr
)))))))
828 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
829 (math-div (list 'calcFunc-sqrt
830 (math-add 1 (math-sqr
831 (nth 1 (nth 1 math-simplify-expr
)))))
832 (nth 1 (nth 1 math-simplify-expr
))))))
834 (defun math-should-expand-trig (x &optional hyperbolic
)
835 (let ((m (math-is-multiple x
)))
836 (and math-living-dangerously
837 m
(or (and (integerp (car m
)) (> (car m
) 1))
838 (equal (car m
) '(frac 1 2)))
840 (memq (car-safe (nth 1 m
))
842 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
843 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
844 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
845 (eq hyperbolic
'exp
)))
848 (defun math-known-sin (plus n mul off
)
849 (setq n
(math-mul n mul
))
850 (and (math-num-integerp n
)
851 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
853 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
857 (if (math-zerop plus
)
858 (and (or calc-symbolic-mode
862 (10 .
(/ (calcFunc-sqrt
863 (- 2 (calcFunc-sqrt 3))) 2))
864 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
865 (15 .
(/ (calcFunc-sqrt
866 (- 2 (calcFunc-sqrt 2))) 2))
868 (24 .
(* (^
(/ 1 2) (/ 3 2))
870 (- 5 (calcFunc-sqrt 5)))))
871 (30 .
(/ (calcFunc-sqrt 2) 2))
872 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
873 (40 .
(/ (calcFunc-sqrt 3) 2))
874 (45 .
(/ (calcFunc-sqrt
875 (+ 2 (calcFunc-sqrt 2))) 2))
876 (48 .
(* (^
(/ 1 2) (/ 3 2))
878 (+ 5 (calcFunc-sqrt 5)))))
879 (50 .
(/ (calcFunc-sqrt
880 (+ 2 (calcFunc-sqrt 3))) 2))
882 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
883 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
886 (math-defsimplify calcFunc-tan
887 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
888 (nth 1 (nth 1 math-simplify-expr
)))
889 (and (math-looks-negp (nth 1 math-simplify-expr
))
890 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 math-simplify-expr
)))))
891 (and (eq calc-angle-mode
'rad
)
892 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
894 (math-known-tan (car n
) (nth 1 n
) 120))))
895 (and (eq calc-angle-mode
'deg
)
896 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
898 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
899 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
900 (math-div (nth 1 (nth 1 math-simplify-expr
))
902 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
903 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
904 (math-div (list 'calcFunc-sqrt
905 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
906 (nth 1 (nth 1 math-simplify-expr
))))
907 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
909 (if (equal (car m
) '(frac 1 2))
910 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
911 (list 'calcFunc-sin
(nth 1 m
)))
912 (math-div (list 'calcFunc-sin
(nth 1 math-simplify-expr
))
913 (list 'calcFunc-cos
(nth 1 math-simplify-expr
))))))))
915 (math-defsimplify calcFunc-cot
916 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
917 (math-neg (list 'calcFunc-cot
(math-neg (nth 1 math-simplify-expr
)))))
918 (and (eq calc-angle-mode
'rad
)
919 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
921 (math-div 1 (math-known-tan (car n
) (nth 1 n
) 120)))))
922 (and (eq calc-angle-mode
'deg
)
923 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
925 (math-div 1 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3))))))
926 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
927 (math-div (list 'calcFunc-sqrt
928 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
929 (nth 1 (nth 1 math-simplify-expr
))))
930 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
931 (math-div (nth 1 (nth 1 math-simplify-expr
))
933 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
934 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
935 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
937 (defun math-known-tan (plus n mul
)
938 (setq n
(math-mul n mul
))
939 (and (math-num-integerp n
)
940 (setq n
(math-mod (math-trunc n
) 120))
942 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
944 (if (math-zerop plus
)
945 (and (or calc-symbolic-mode
947 (cdr (assq n
'( (0 .
0)
948 (10 .
(- 2 (calcFunc-sqrt 3)))
950 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
951 (15 .
(- (calcFunc-sqrt 2) 1))
952 (20 .
(/ (calcFunc-sqrt 3) 3))
954 (- 5 (* 2 (calcFunc-sqrt 5)))))
957 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
958 (40 .
(calcFunc-sqrt 3))
959 (45 .
(+ (calcFunc-sqrt 2) 1))
961 (+ 5 (* 2 (calcFunc-sqrt 5)))))
962 (50 .
(+ 2 (calcFunc-sqrt 3)))
963 (60 .
(var uinf var-uinf
))))))
964 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
965 ((eq n
60) (math-normalize (list '/ -
1
966 (list 'calcFunc-tan plus
))))
969 (math-defsimplify calcFunc-sinh
970 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
971 (nth 1 (nth 1 math-simplify-expr
)))
972 (and (math-looks-negp (nth 1 math-simplify-expr
))
973 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 math-simplify-expr
)))))
974 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
975 math-living-dangerously
977 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
978 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
979 math-living-dangerously
980 (math-div (nth 1 (nth 1 math-simplify-expr
))
982 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
983 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
984 (and m
(integerp (car m
))
985 (let ((n (car m
)) (a (nth 1 m
)))
988 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
989 (list 'calcFunc-cosh a
))
990 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
991 (list 'calcFunc-sinh a
)))))))))
993 (math-defsimplify calcFunc-cosh
994 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
995 (nth 1 (nth 1 math-simplify-expr
)))
996 (and (math-looks-negp (nth 1 math-simplify-expr
))
997 (list 'calcFunc-cosh
(math-neg (nth 1 math-simplify-expr
))))
998 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
999 math-living-dangerously
1000 (list 'calcFunc-sqrt
1001 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1002 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1003 math-living-dangerously
1005 (list 'calcFunc-sqrt
1006 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1007 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1008 (and m
(integerp (car m
))
1009 (let ((n (car m
)) (a (nth 1 m
)))
1012 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1013 (list 'calcFunc-cosh a
))
1014 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1015 (list 'calcFunc-sinh a
)))))))))
1017 (math-defsimplify calcFunc-tanh
1018 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1019 (nth 1 (nth 1 math-simplify-expr
)))
1020 (and (math-looks-negp (nth 1 math-simplify-expr
))
1021 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 math-simplify-expr
)))))
1022 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1023 math-living-dangerously
1024 (math-div (nth 1 (nth 1 math-simplify-expr
))
1025 (list 'calcFunc-sqrt
1026 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1027 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1028 math-living-dangerously
1029 (math-div (list 'calcFunc-sqrt
1030 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1031 (nth 1 (nth 1 math-simplify-expr
))))
1032 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1034 (if (equal (car m
) '(frac 1 2))
1035 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
1036 (list 'calcFunc-sinh
(nth 1 m
)))
1037 (math-div (list 'calcFunc-sinh
(nth 1 math-simplify-expr
))
1038 (list 'calcFunc-cosh
(nth 1 math-simplify-expr
))))))))
1040 (math-defsimplify calcFunc-sech
1041 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1042 (list 'calcFunc-sech
(math-neg (nth 1 math-simplify-expr
))))
1043 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1044 math-living-dangerously
1047 (list 'calcFunc-sqrt
1048 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1049 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1050 math-living-dangerously
1051 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))) 1)
1052 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1053 math-living-dangerously
1054 (list 'calcFunc-sqrt
1055 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
1057 (math-defsimplify calcFunc-csch
1058 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1059 (math-neg (list 'calcFunc-csch
(math-neg (nth 1 math-simplify-expr
)))))
1060 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1061 math-living-dangerously
1062 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
1063 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1064 math-living-dangerously
1067 (list 'calcFunc-sqrt
1068 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1069 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1070 math-living-dangerously
1071 (math-div (list 'calcFunc-sqrt
1072 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
1073 (nth 1 (nth 1 math-simplify-expr
))))))
1075 (math-defsimplify calcFunc-coth
1076 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1077 (math-neg (list 'calcFunc-coth
(math-neg (nth 1 math-simplify-expr
)))))
1078 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1079 math-living-dangerously
1080 (math-div (list 'calcFunc-sqrt
1081 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1082 (nth 1 (nth 1 math-simplify-expr
))))
1083 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1084 math-living-dangerously
1085 (math-div (nth 1 (nth 1 math-simplify-expr
))
1086 (list 'calcFunc-sqrt
1087 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1088 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1089 math-living-dangerously
1090 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
1092 (math-defsimplify calcFunc-arcsin
1093 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1094 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 math-simplify-expr
)))))
1095 (and (eq (nth 1 math-simplify-expr
) 1)
1096 (math-quarter-circle t
))
1097 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1098 (math-div (math-half-circle t
) 6))
1099 (and math-living-dangerously
1100 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1101 (nth 1 (nth 1 math-simplify-expr
)))
1102 (and math-living-dangerously
1103 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1104 (math-sub (math-quarter-circle t
)
1105 (nth 1 (nth 1 math-simplify-expr
))))))
1107 (math-defsimplify calcFunc-arccos
1108 (or (and (eq (nth 1 math-simplify-expr
) 0)
1109 (math-quarter-circle t
))
1110 (and (eq (nth 1 math-simplify-expr
) -
1)
1111 (math-half-circle t
))
1112 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1113 (math-div (math-half-circle t
) 3))
1114 (and (equal (nth 1 math-simplify-expr
) '(frac -
1 2))
1115 (math-div (math-mul (math-half-circle t
) 2) 3))
1116 (and math-living-dangerously
1117 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1118 (nth 1 (nth 1 math-simplify-expr
)))
1119 (and math-living-dangerously
1120 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1121 (math-sub (math-quarter-circle t
)
1122 (nth 1 (nth 1 math-simplify-expr
))))))
1124 (math-defsimplify calcFunc-arctan
1125 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1126 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 math-simplify-expr
)))))
1127 (and (eq (nth 1 math-simplify-expr
) 1)
1128 (math-div (math-half-circle t
) 4))
1129 (and math-living-dangerously
1130 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tan
)
1131 (nth 1 (nth 1 math-simplify-expr
)))))
1133 (math-defsimplify calcFunc-arcsinh
1134 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1135 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 math-simplify-expr
)))))
1136 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sinh
)
1137 (or math-living-dangerously
1138 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1139 (nth 1 (nth 1 math-simplify-expr
)))))
1141 (math-defsimplify calcFunc-arccosh
1142 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1143 (or math-living-dangerously
1144 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1145 (nth 1 (nth 1 math-simplify-expr
))))
1147 (math-defsimplify calcFunc-arctanh
1148 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1149 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 math-simplify-expr
)))))
1150 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tanh
)
1151 (or math-living-dangerously
1152 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1153 (nth 1 (nth 1 math-simplify-expr
)))))
1155 (math-defsimplify calcFunc-sqrt
1156 (math-simplify-sqrt))
1158 (defun math-simplify-sqrt ()
1159 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
1160 (math-div (list 'calcFunc-sqrt
1161 (math-mul (nth 1 (nth 1 math-simplify-expr
))
1162 (nth 2 (nth 1 math-simplify-expr
))))
1163 (nth 2 (nth 1 math-simplify-expr
))))
1164 (let ((fac (if (math-objectp (nth 1 math-simplify-expr
))
1165 (math-squared-factor (nth 1 math-simplify-expr
))
1166 (math-common-constant-factor (nth 1 math-simplify-expr
)))))
1167 (and fac
(not (eq fac
1))
1168 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
1170 (list 'calcFunc-sqrt
1171 (math-cancel-common-factor
1172 (nth 1 math-simplify-expr
) fac
))))))
1173 (and math-living-dangerously
1174 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1175 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 1)
1176 (eq (car-safe (nth 2 (nth 1 math-simplify-expr
))) '^
)
1177 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr
))) 2)
1178 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1181 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr
))))))
1182 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1185 (nth 1 (nth 1 (nth 2
1186 (nth 1 math-simplify-expr
))))))))
1187 (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1188 (math-equal-int (nth 2 (nth 1 math-simplify-expr
)) 1)
1189 (eq (car-safe (nth 1 (nth 1 math-simplify-expr
))) '^
)
1190 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr
))) 2)
1191 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr
))))
1193 (list 'calcFunc-sinh
1194 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr
)))))))
1195 (and (eq (car-safe (nth 1 math-simplify-expr
)) '+)
1196 (let ((a (nth 1 (nth 1 math-simplify-expr
)))
1197 (b (nth 2 (nth 1 math-simplify-expr
))))
1198 (and (or (and (math-equal-int a
1)
1199 (setq a b b
(nth 1 (nth 1 math-simplify-expr
))))
1200 (math-equal-int b
1))
1201 (eq (car-safe a
) '^
)
1202 (math-equal-int (nth 2 a
) 2)
1203 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
1204 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
1205 (and (eq (car-safe (nth 1 a
)) 'calcFunc-csch
)
1206 (list 'calcFunc-coth
(nth 1 (nth 1 a
))))
1207 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
1208 (list '/ 1 (list 'calcFunc-cos
1209 (nth 1 (nth 1 a
)))))
1210 (and (eq (car-safe (nth 1 a
)) 'calcFunc-cot
)
1211 (list '/ 1 (list 'calcFunc-sin
1212 (nth 1 (nth 1 a
)))))))))
1213 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1215 (nth 1 (nth 1 math-simplify-expr
))
1216 (math-div (nth 2 (nth 1 math-simplify-expr
)) 2)))
1217 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1218 (list '^
(nth 1 (nth 1 math-simplify-expr
)) (math-div 1 4)))
1219 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1220 (list (car (nth 1 math-simplify-expr
))
1221 (list 'calcFunc-sqrt
(nth 1 (nth 1 math-simplify-expr
)))
1222 (list 'calcFunc-sqrt
(nth 2 (nth 1 math-simplify-expr
)))))
1223 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
1224 (not (math-any-floats (nth 1 math-simplify-expr
)))
1225 (let ((f (calcFunc-factors (calcFunc-expand
1226 (nth 1 math-simplify-expr
)))))
1227 (and (math-vectorp f
)
1228 (or (> (length f
) 2)
1229 (> (nth 2 (nth 1 f
)) 1))
1230 (let ((out 1) (rest 1) (sums 1) fac pow
)
1231 (while (setq f
(cdr f
))
1232 (setq fac
(nth 1 (car f
))
1233 pow
(nth 2 (car f
)))
1235 (setq out
(math-mul out
(math-pow
1239 (if (memq (car-safe fac
) '(+ -
))
1240 (setq sums
(math-mul-thru sums fac
))
1241 (setq rest
(math-mul rest fac
)))))
1242 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1245 (list 'calcFunc-sqrt
1246 (math-mul sums rest
))))))))))))
1248 ;;; Rather than factoring x into primes, just check for the first ten primes.
1249 (defun math-squared-factor (x)
1250 (if (Math-integerp x
)
1251 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1255 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1257 fac
(math-mul fac
(car prsqr
)))
1258 (setq prsqr
(cdr prsqr
))))
1261 (math-defsimplify calcFunc-exp
1262 (math-simplify-exp (nth 1 math-simplify-expr
)))
1264 (defun math-simplify-exp (x)
1265 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1267 (and math-living-dangerously
1268 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1270 (list 'calcFunc-sqrt
1271 (math-add (math-sqr (nth 1 x
)) 1))))
1272 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1274 (list 'calcFunc-sqrt
1275 (math-sub (math-sqr (nth 1 x
)) 1))))
1276 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1277 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1278 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1279 (let ((m (math-should-expand-trig x
'exp
)))
1280 (and m
(integerp (car m
))
1281 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1282 (and calc-symbolic-mode
1283 (math-known-imagp x
)
1284 (let* ((ip (calcFunc-im x
))
1285 (n (math-linear-in ip
'(var pi var-pi
)))
1288 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1289 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1290 (list '+ c
(list '* s
'(var i var-i
))))))))
1292 (math-defsimplify calcFunc-ln
1293 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1294 (or math-living-dangerously
1295 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1296 (nth 1 (nth 1 math-simplify-expr
)))
1297 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1298 (equal (nth 1 (nth 1 math-simplify-expr
)) '(var e var-e
))
1299 (or math-living-dangerously
1300 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1301 (nth 2 (nth 1 math-simplify-expr
)))
1302 (and calc-symbolic-mode
1303 (math-known-negp (nth 1 math-simplify-expr
))
1304 (math-add (list 'calcFunc-ln
(math-neg (nth 1 math-simplify-expr
)))
1305 '(* (var pi var-pi
) (var i var-i
))))
1306 (and calc-symbolic-mode
1307 (math-known-imagp (nth 1 math-simplify-expr
))
1308 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr
)))
1309 (ips (math-possible-signs ip
)))
1310 (or (and (memq ips
'(4 6))
1311 (math-add (list 'calcFunc-ln ip
)
1312 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1313 (and (memq ips
'(1 3))
1314 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1315 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1318 (math-simplify-pow))
1320 (defun math-simplify-pow ()
1321 (or (and math-living-dangerously
1322 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1324 (nth 1 (nth 1 math-simplify-expr
))
1325 (math-mul (nth 2 math-simplify-expr
)
1326 (nth 2 (nth 1 math-simplify-expr
)))))
1327 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1329 (nth 1 (nth 1 math-simplify-expr
))
1330 (math-div (nth 2 math-simplify-expr
) 2)))
1331 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1332 (list (car (nth 1 math-simplify-expr
))
1333 (list '^
(nth 1 (nth 1 math-simplify-expr
))
1334 (nth 2 math-simplify-expr
))
1335 (list '^
(nth 2 (nth 1 math-simplify-expr
))
1336 (nth 2 math-simplify-expr
))))))
1337 (and (math-equal-int (nth 1 math-simplify-expr
) 10)
1338 (eq (car-safe (nth 2 math-simplify-expr
)) 'calcFunc-log10
)
1339 (nth 1 (nth 2 math-simplify-expr
)))
1340 (and (equal (nth 1 math-simplify-expr
) '(var e var-e
))
1341 (math-simplify-exp (nth 2 math-simplify-expr
)))
1342 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1343 (not math-integrating
)
1344 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 math-simplify-expr
))
1345 (nth 2 math-simplify-expr
))))
1346 (and (equal (nth 1 math-simplify-expr
) '(var i var-i
))
1348 (math-num-integerp (nth 2 math-simplify-expr
))
1349 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr
)) 4)))
1351 ((eq x
1) (nth 1 math-simplify-expr
))
1353 ((eq x
3) (math-neg (nth 1 math-simplify-expr
))))))
1354 (and math-integrating
1355 (integerp (nth 2 math-simplify-expr
))
1356 (>= (nth 2 math-simplify-expr
) 2)
1357 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1358 (math-mul (math-pow (nth 1 math-simplify-expr
)
1359 (- (nth 2 math-simplify-expr
) 2))
1363 (nth 1 (nth 1 math-simplify-expr
)))))))
1364 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1365 (math-mul (math-pow (nth 1 math-simplify-expr
)
1366 (- (nth 2 math-simplify-expr
) 2))
1369 (list 'calcFunc-sinh
1370 (nth 1 (nth 1 math-simplify-expr
)))))))))
1371 (and (eq (car-safe (nth 2 math-simplify-expr
)) 'frac
)
1372 (Math-ratp (nth 1 math-simplify-expr
))
1373 (Math-posp (nth 1 math-simplify-expr
))
1374 (if (equal (nth 2 math-simplify-expr
) '(frac 1 2))
1375 (list 'calcFunc-sqrt
(nth 1 math-simplify-expr
))
1376 (let ((flr (math-floor (nth 2 math-simplify-expr
))))
1377 (and (not (Math-zerop flr
))
1378 (list '* (list '^
(nth 1 math-simplify-expr
) flr
)
1379 (list '^
(nth 1 math-simplify-expr
)
1380 (math-sub (nth 2 math-simplify-expr
) flr
)))))))
1381 (and (eq (math-quarter-integer (nth 2 math-simplify-expr
)) 2)
1382 (let ((temp (math-simplify-sqrt)))
1384 (list '^ temp
(math-mul (nth 2 math-simplify-expr
) 2)))))))
1386 (math-defsimplify calcFunc-log10
1387 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1388 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 10)
1389 (or math-living-dangerously
1390 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1391 (nth 2 (nth 1 math-simplify-expr
))))
1394 (math-defsimplify calcFunc-erf
1395 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1396 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 math-simplify-expr
)))))
1397 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1398 (list 'calcFunc-conj
1399 (list 'calcFunc-erf
(nth 1 (nth 1 math-simplify-expr
)))))))
1401 (math-defsimplify calcFunc-erfc
1402 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1403 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 math-simplify-expr
)))))
1404 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1405 (list 'calcFunc-conj
1406 (list 'calcFunc-erfc
(nth 1 (nth 1 math-simplify-expr
)))))))
1409 (defun math-linear-in (expr term
&optional always
)
1410 (if (math-expr-contains expr term
)
1411 (let* ((calc-prefer-frac t
)
1412 (p (math-is-polynomial expr term
1)))
1415 (and always
(list expr
0))))
1417 (defun math-multiple-of (expr term
)
1418 (let ((p (math-linear-in expr term
)))
1420 (math-zerop (car p
))
1423 ; not perfect, but it'll do
1424 (defun math-integer-plus (expr)
1425 (cond ((Math-integerp expr
)
1427 ((and (memq (car expr
) '(+ -
))
1428 (Math-integerp (nth 1 expr
)))
1429 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1431 ((and (memq (car expr
) '(+ -
))
1432 (Math-integerp (nth 2 expr
)))
1434 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1437 (defun math-is-linear (expr &optional always
)
1440 (if (eq (car-safe expr
) '+)
1441 (if (Math-objectp (nth 1 expr
))
1442 (setq offset
(nth 1 expr
)
1444 (if (Math-objectp (nth 2 expr
))
1445 (setq offset
(nth 2 expr
)
1446 expr
(nth 1 expr
))))
1447 (if (eq (car-safe expr
) '-
)
1448 (if (Math-objectp (nth 1 expr
))
1449 (setq offset
(nth 1 expr
)
1450 expr
(math-neg (nth 2 expr
)))
1451 (if (Math-objectp (nth 2 expr
))
1452 (setq offset
(math-neg (nth 2 expr
))
1453 expr
(nth 1 expr
))))))
1454 (setq coef
(math-is-multiple expr always
))
1456 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1460 (defun math-is-multiple (expr &optional always
)
1461 (or (if (eq (car-safe expr
) '*)
1462 (if (Math-objectp (nth 1 expr
))
1463 (list (nth 1 expr
) (nth 2 expr
)))
1464 (if (eq (car-safe expr
) '/)
1465 (if (and (Math-objectp (nth 1 expr
))
1466 (not (math-equal-int (nth 1 expr
) 1)))
1467 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1468 (if (Math-objectp (nth 2 expr
))
1469 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1470 (let ((res (math-is-multiple (nth 1 expr
))))
1473 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1474 (setq res
(math-is-multiple (nth 2 expr
)))
1476 (list (math-div 1 (car res
))
1477 (math-div (nth 1 expr
)
1478 (nth 2 (nth 2 expr
)))))))))
1479 (if (eq (car-safe expr
) 'neg
)
1480 (list -
1 (nth 1 expr
)))))
1481 (if (Math-objvecp expr
)
1487 (defun calcFunc-lin (expr &optional var
)
1489 (let ((res (math-linear-in expr var t
)))
1490 (or res
(math-reject-arg expr
"Linear term expected"))
1491 (list 'vec
(car res
) (nth 1 res
) var
))
1492 (let ((res (math-is-linear expr t
)))
1493 (or res
(math-reject-arg expr
"Linear term expected"))
1496 (defun calcFunc-linnt (expr &optional var
)
1498 (let ((res (math-linear-in expr var
)))
1499 (or res
(math-reject-arg expr
"Linear term expected"))
1500 (list 'vec
(car res
) (nth 1 res
) var
))
1501 (let ((res (math-is-linear expr
)))
1502 (or res
(math-reject-arg expr
"Linear term expected"))
1505 (defun calcFunc-islin (expr &optional var
)
1506 (if (and (Math-objvecp expr
) (not var
))
1508 (calcFunc-lin expr var
)
1511 (defun calcFunc-islinnt (expr &optional var
)
1512 (if (Math-objvecp expr
)
1514 (calcFunc-linnt expr var
)
1520 ;;; Simple operations on expressions.
1522 ;;; Return number of occurrences of thing in expr, or nil if none.
1523 (defun math-expr-contains-count (expr thing
)
1524 (cond ((equal expr thing
) 1)
1525 ((Math-primp expr
) nil
)
1528 (while (setq expr
(cdr expr
))
1529 (setq num
(+ num
(or (math-expr-contains-count
1530 (car expr
) thing
) 0))))
1534 (defun math-expr-contains (expr thing
)
1535 (cond ((equal expr thing
) 1)
1536 ((Math-primp expr
) nil
)
1538 (while (and (setq expr
(cdr expr
))
1539 (not (math-expr-contains (car expr
) thing
))))
1542 ;;; Return non-nil if any variable of thing occurs in expr.
1543 (defun math-expr-depends (expr thing
)
1544 (if (Math-primp thing
)
1545 (and (eq (car-safe thing
) 'var
)
1546 (math-expr-contains expr thing
))
1547 (while (and (setq thing
(cdr thing
))
1548 (not (math-expr-depends expr
(car thing
)))))
1551 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1553 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1554 ;; for math-expr-subst, but used by math-expr-subst-rec.
1555 (defvar math-expr-subst-old
)
1556 (defvar math-expr-subst-new
)
1558 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new
)
1559 (math-expr-subst-rec expr
))
1561 (defalias 'calcFunc-subst
'math-expr-subst
)
1563 (defun math-expr-subst-rec (expr)
1564 (cond ((equal expr math-expr-subst-old
) math-expr-subst-new
)
1565 ((Math-primp expr
) expr
)
1566 ((memq (car expr
) '(calcFunc-deriv
1568 (if (= (length expr
) 2)
1569 (if (equal (nth 1 expr
) math-expr-subst-old
)
1570 (append expr
(list math-expr-subst-new
))
1572 (list (car expr
) (nth 1 expr
)
1573 (math-expr-subst-rec (nth 2 expr
)))))
1576 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1578 ;;; Various measures of the size of an expression.
1579 (defun math-expr-weight (expr)
1580 (if (Math-primp expr
)
1583 (while (setq expr
(cdr expr
))
1584 (setq w
(+ w
(math-expr-weight (car expr
)))))
1587 (defun math-expr-height (expr)
1588 (if (Math-primp expr
)
1591 (while (setq expr
(cdr expr
))
1592 (setq h
(max h
(math-expr-height (car expr
)))))
1598 ;;; Polynomial operations (to support the integrator and solve-for).
1600 (defun calcFunc-collect (expr base
)
1601 (let ((p (math-is-polynomial expr base
50 t
)))
1603 (math-normalize ; fix selection bug
1604 (math-build-polynomial-expr p base
))
1607 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1608 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1609 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1611 ;; The variables math-is-poly-degree and math-is-poly-loose are local to
1612 ;; math-is-polynomial, but are used by math-is-poly-rec
1613 (defvar math-is-poly-degree
)
1614 (defvar math-is-poly-loose
)
1616 (defun math-is-polynomial (expr var
&optional math-is-poly-degree math-is-poly-loose
)
1617 (let* ((math-poly-base-variable (if math-is-poly-loose
1618 (if (eq math-is-poly-loose
'gen
) var
'(var XXX XXX
))
1619 math-poly-base-variable
))
1620 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1621 (and (or (null math-is-poly-degree
)
1622 (<= (length poly
) (1+ math-is-poly-degree
)))
1625 (defun math-is-poly-rec (expr negpow
)
1627 (or (cond ((or (equal expr var
)
1628 (eq (car-safe expr
) '^
))
1631 (or (equal expr var
)
1632 (setq pow
(nth 2 expr
)
1634 (or (eq math-poly-mult-powers
1)
1635 (setq pow
(let ((m (math-is-multiple pow
1)))
1636 (and (eq (car-safe (car m
)) 'cplx
)
1637 (Math-zerop (nth 1 (car m
)))
1638 (setq m
(list (nth 2 (car m
))
1641 (and (if math-poly-mult-powers
1642 (equal math-poly-mult-powers
1644 (setq math-poly-mult-powers
(nth 1 m
)))
1645 (or (equal expr var
)
1646 (eq math-poly-mult-powers
1))
1650 (setq pow
(math-to-simple-fraction pow
))
1651 (and (eq (car-safe pow
) 'frac
)
1652 math-poly-frac-powers
1654 (setq math-poly-frac-powers
1655 (calcFunc-lcm math-poly-frac-powers
1657 (or (memq math-poly-frac-powers
'(1 nil
))
1658 (setq pow
(math-mul pow math-poly-frac-powers
)))
1664 (let ((p1 (if (equal expr var
)
1666 (math-is-poly-rec expr nil
)))
1670 (or (null math-is-poly-degree
)
1671 (<= (* (1- (length p1
)) n
) math-is-poly-degree
))
1674 (setq accum
(math-poly-mul accum p1
)
1678 (math-is-poly-rec expr nil
)
1679 (setq math-poly-neg-powers
1680 (cons (math-pow expr
(- pow
))
1681 math-poly-neg-powers
))
1682 (list (list '^ expr pow
))))))))
1683 ((Math-objectp expr
)
1685 ((memq (car expr
) '(+ -
))
1686 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1688 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1690 (math-poly-mix p1
1 p2
1691 (if (eq (car expr
) '+) 1 -
1)))))))
1692 ((eq (car expr
) 'neg
)
1693 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1695 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1697 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1699 (or (null math-is-poly-degree
)
1700 (<= (- (+ (length p1
) (length p2
)) 2)
1701 math-is-poly-degree
))
1702 (math-poly-mul p1 p2
))))))
1704 (and (or (not (math-poly-depends (nth 2 expr
) var
))
1706 (math-is-poly-rec (nth 2 expr
) nil
)
1707 (setq math-poly-neg-powers
1708 (cons (nth 2 expr
) math-poly-neg-powers
))))
1709 (not (Math-zerop (nth 2 expr
)))
1710 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1711 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1713 ((and (eq (car expr
) 'calcFunc-exp
)
1714 (equal var
'(var e var-e
)))
1715 (math-is-poly-rec (list '^ var
(nth 1 expr
)) negpow
))
1716 ((and (eq (car expr
) 'calcFunc-sqrt
)
1717 math-poly-frac-powers
)
1718 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1720 (and (or (not (math-poly-depends expr var
))
1722 (not (eq (car expr
) 'vec
))
1725 ;;; Check if expr is a polynomial in var; if so, return its degree.
1726 (defun math-polynomial-p (expr var
)
1727 (cond ((equal expr var
) 1)
1728 ((Math-primp expr
) 0)
1729 ((memq (car expr
) '(+ -
))
1730 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1732 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1735 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1737 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1739 ((eq (car expr
) 'neg
)
1740 (math-polynomial-p (nth 1 expr
) var
))
1741 ((and (eq (car expr
) '/)
1742 (not (math-poly-depends (nth 2 expr
) var
)))
1743 (math-polynomial-p (nth 1 expr
) var
))
1744 ((and (eq (car expr
) '^
)
1745 (natnump (nth 2 expr
)))
1746 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1747 (and p1
(* p1
(nth 2 expr
)))))
1748 ((math-poly-depends expr var
) nil
)
1751 (defun math-poly-depends (expr var
)
1752 (if math-poly-base-variable
1753 (math-expr-contains expr math-poly-base-variable
)
1754 (math-expr-depends expr var
)))
1756 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1757 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1758 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1759 (defvar math-poly-base-const-ok
)
1760 (defvar math-poly-base-pred
)
1762 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1763 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1764 ;; by math-polynomial-base.
1766 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred
)
1767 (or math-poly-base-pred
1768 (setq math-poly-base-pred
(function (lambda (base) (math-polynomial-p
1769 math-poly-base-top-expr base
)))))
1770 (or (let ((math-poly-base-const-ok nil
))
1771 (math-polynomial-base-rec math-poly-base-top-expr
))
1772 (let ((math-poly-base-const-ok t
))
1773 (math-polynomial-base-rec math-poly-base-top-expr
))))
1775 (defun math-polynomial-base-rec (mpb-expr)
1776 (and (not (Math-objvecp mpb-expr
))
1777 (or (and (memq (car mpb-expr
) '(+ -
*))
1778 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1779 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1780 (and (memq (car mpb-expr
) '(/ neg
))
1781 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1782 (and (eq (car mpb-expr
) '^
)
1783 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1784 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1785 (math-polynomial-base-rec '(var e var-e
)))
1786 (and (or math-poly-base-const-ok
(math-expr-contains-vars mpb-expr
))
1787 (funcall math-poly-base-pred mpb-expr
)
1790 ;;; Return non-nil if expr refers to any variables.
1791 (defun math-expr-contains-vars (expr)
1792 (or (eq (car-safe expr
) 'var
)
1793 (and (not (Math-primp expr
))
1795 (while (and (setq expr
(cdr expr
))
1796 (not (math-expr-contains-vars (car expr
)))))
1799 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1800 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1801 (defun math-poly-simplify (p)
1803 (if (Math-zerop (nth (1- (length p
)) p
))
1804 (let ((pp (copy-sequence p
)))
1805 (while (and (cdr pp
)
1806 (Math-zerop (nth (1- (length pp
)) pp
)))
1807 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1811 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1812 ;;; coefficients ac, bc. Result may be unsimplified.
1813 (defun math-poly-mix (a ac b bc
)
1815 (cons (math-add (math-mul (or (car a
) 0) ac
)
1816 (math-mul (or (car b
) 0) bc
))
1817 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1819 (defun math-poly-zerop (a)
1821 (and (null (cdr a
)) (Math-zerop (car a
)))))
1823 ;;; Multiply two polynomials in list form.
1824 (defun math-poly-mul (a b
)
1826 (math-poly-mix b
(car a
)
1827 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1829 ;;; Build an expression from a polynomial list.
1830 (defun math-build-polynomial-expr (p var
)
1832 (if (Math-numberp var
)
1833 (math-with-extra-prec 1
1834 (let* ((rp (reverse p
))
1836 (while (setq rp
(cdr rp
))
1837 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1839 (let* ((rp (reverse p
))
1840 (n (1- (length rp
)))
1841 (accum (math-mul (car rp
) (math-pow var n
)))
1843 (while (setq rp
(cdr rp
))
1845 (or (math-zerop (car rp
))
1846 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1848 (math-mul (if (math-looks-negp (car rp
))
1851 (math-pow var n
))))))
1856 (defun math-to-simple-fraction (f)
1857 (or (and (eq (car-safe f
) 'float
)
1858 (or (and (>= (nth 2 f
) 0)
1859 (math-scale-int (nth 1 f
) (nth 2 f
)))
1860 (and (integerp (nth 1 f
))
1863 (math-make-frac (nth 1 f
)
1864 (math-scale-int 1 (- (nth 2 f
)))))))
1869 ;;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
1870 ;;; calc-alg.el ends here
