1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This file is autoloaded from calc-ext.el.
34 (defun calc-alg-evaluate (arg)
37 (calc-with-default-simplification
38 (let ((math-simplify-only nil
))
39 (calc-modify-simplify-mode arg
)
40 (calc-enter-result 1 "dsmp" (calc-top 1))))))
42 (defun calc-modify-simplify-mode (arg)
43 (if (= (math-abs arg
) 2)
44 (setq calc-simplify-mode
'alg
)
45 (if (>= (math-abs arg
) 3)
46 (setq calc-simplify-mode
'ext
)))
48 (setq calc-simplify-mode
(list calc-simplify-mode
))))
50 (defun calc-simplify ()
53 (let ((top (calc-top-n 1)))
56 (let ((calc-simplify-mode nil
))
57 (math-normalize (math-trig-rewrite top
)))))
58 (if (calc-is-hyperbolic)
60 (let ((calc-simplify-mode nil
))
61 (math-normalize (math-hyperbolic-trig-rewrite top
)))))
62 (calc-with-default-simplification
63 (calc-enter-result 1 "simp" (math-simplify top
))))))
65 (defun calc-simplify-extended ()
68 (calc-with-default-simplification
69 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
71 (defun calc-expand-formula (arg)
74 (calc-with-default-simplification
75 (let ((math-simplify-only nil
))
76 (calc-modify-simplify-mode arg
)
77 (calc-enter-result 1 "expf"
79 (let ((math-expand-formulas t
))
81 (let ((top (calc-top-n 1)))
82 (or (math-expand-formula top
)
85 (defun calc-factor (arg)
88 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
89 'calcFunc-factors
'calcFunc-factor
)
92 (defun calc-expand (n)
95 (calc-enter-result 1 "expa"
96 (append (list 'calcFunc-expand
98 (and n
(list (prefix-numeric-value n
)))))))
100 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
101 (defun calcFunc-powerexpand (expr)
102 (math-normalize (math-map-tree 'math-powerexpand expr
)))
104 (defun math-powerexpand (expr)
105 (if (eq (car-safe expr
) '^
)
106 (let ((n (nth 2 expr
)))
107 (cond ((and (integerp n
)
113 (setq prod
(math-mul prod a
))
119 (a (math-pow (nth 1 expr
) -
1))
120 (prod (math-pow (nth 1 expr
) -
1)))
122 (setq prod
(math-mul a prod
))
129 (defun calc-powerexpand ()
132 (calc-enter-result 1 "pexp"
133 (calcFunc-powerexpand (calc-top-n 1)))))
135 (defun calc-collect (&optional var
)
136 (interactive "sCollect terms involving: ")
138 (if (or (equal var
"") (equal var
"$") (null var
))
139 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
140 (calc-top-list-n 2)))
141 (let ((var (math-read-expr var
)))
142 (if (eq (car-safe var
) 'error
)
143 (error "Bad format in expression: %s" (nth 1 var
)))
144 (calc-enter-result 1 "clct" (list 'calcFunc-collect
148 (defun calc-apart (arg)
151 (calc-unary-op "aprt" 'calcFunc-apart arg
)))
153 (defun calc-normalize-rat (arg)
156 (calc-unary-op "nrat" 'calcFunc-nrat arg
)))
158 (defun calc-poly-gcd (arg)
161 (calc-binary-op "pgcd" 'calcFunc-pgcd arg
)))
164 (defun calc-poly-div (arg)
167 (let ((calc-poly-div-remainder nil
))
168 (calc-binary-op "pdiv" 'calcFunc-pdiv arg
)
169 (if (and calc-poly-div-remainder
(null arg
))
171 (calc-clear-command-flag 'clear-message
)
172 (calc-record calc-poly-div-remainder
"prem")
173 (if (not (Math-zerop calc-poly-div-remainder
))
174 (message "(Remainder was %s)"
175 (math-format-flat-expr calc-poly-div-remainder
0))
176 (message "(No remainder)")))))))
178 (defun calc-poly-rem (arg)
181 (calc-binary-op "prem" 'calcFunc-prem arg
)))
183 (defun calc-poly-div-rem (arg)
186 (if (calc-is-hyperbolic)
187 (calc-binary-op "pdvr" 'calcFunc-pdivide arg
)
188 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg
))))
190 (defun calc-substitute (&optional oldname newname
)
191 (interactive "sSubstitute old: ")
193 (let (old new
(num 1) expr
)
194 (if (or (equal oldname
"") (equal oldname
"$") (null oldname
))
195 (setq new
(calc-top-n 1)
200 (progn (calc-unread-command ?\C-a
)
201 (setq newname
(read-string (concat "Substitute old: "
205 (if (or (equal newname
"") (equal newname
"$") (null newname
))
206 (setq new
(calc-top-n 1)
209 (setq new
(if (stringp newname
) (math-read-expr newname
) newname
))
210 (if (eq (car-safe new
) 'error
)
211 (error "Bad format in expression: %s" (nth 1 new
)))
212 (setq expr
(calc-top-n 1)))
213 (setq old
(if (stringp oldname
) (math-read-expr oldname
) oldname
))
214 (if (eq (car-safe old
) 'error
)
215 (error "Bad format in expression: %s" (nth 1 old
)))
216 (or (math-expr-contains expr old
)
217 (error "No occurrences found")))
218 (calc-enter-result num
"sbst" (math-expr-subst expr old new
)))))
221 (defun calc-has-rules (name)
222 (setq name
(calc-var-value name
))
224 (memq (car name
) '(vec calcFunc-assign calcFunc-condition
))
227 ;; math-eval-rules-cache and math-eval-rules-cache-other are
228 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
229 (defvar math-eval-rules-cache
)
230 (defvar math-eval-rules-cache-other
)
232 (defun math-recompile-eval-rules ()
233 (setq math-eval-rules-cache
(and (calc-has-rules 'var-EvalRules
)
234 (math-compile-rewrites
235 '(var EvalRules var-EvalRules
)))
236 math-eval-rules-cache-other
(assq nil math-eval-rules-cache
)
237 math-eval-rules-cache-tag
(calc-var-value 'var-EvalRules
)))
240 ;;; Try to expand a formula according to its definition.
241 (defun math-expand-formula (expr)
244 (or (get (car expr
) 'calc-user-defn
)
245 (get (car expr
) 'math-expandable
))
246 (let ((res (let ((math-expand-formulas t
))
247 (apply (car expr
) (cdr expr
)))))
248 (and (not (eq (car-safe res
) (car expr
)))
254 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
255 (defun math-beforep (a b
) ; [Public]
256 (cond ((and (Math-realp a
) (Math-realp b
))
257 (let ((comp (math-compare a b
)))
261 (> (length (memq (car-safe a
)
262 '(bigneg nil bigpos frac float
)))
263 (length (memq (car-safe b
)
264 '(bigneg nil bigpos frac float
))))))))
265 ((equal b
'(neg (var inf var-inf
))) nil
)
266 ((equal a
'(neg (var inf var-inf
))) t
)
267 ((equal a
'(var inf var-inf
)) nil
)
268 ((equal b
'(var inf var-inf
)) t
)
270 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
))
271 (if (or (math-beforep a
(nth 2 b
)) (Math-equal a
(nth 2 b
)))
276 (if (and (eq (car-safe a
) 'intv
) (math-intv-constp a
))
277 (if (math-beforep (nth 2 a
) b
)
281 ((and (eq (car a
) 'intv
) (eq (car b
) 'intv
)
282 (math-intv-constp a
) (math-intv-constp b
))
283 (let ((comp (math-compare (nth 2 a
) (nth 2 b
))))
284 (cond ((eq comp -
1) t
)
286 ((and (memq (nth 1 a
) '(2 3)) (memq (nth 1 b
) '(0 1))) t
)
287 ((and (memq (nth 1 a
) '(0 1)) (memq (nth 1 b
) '(2 3))) nil
)
288 ((eq (setq comp
(math-compare (nth 3 a
) (nth 3 b
))) -
1) t
)
290 ((and (memq (nth 1 a
) '(0 2)) (memq (nth 1 b
) '(1 3))) t
)
292 ((not (eq (not (Math-objectp a
)) (not (Math-objectp b
))))
295 (if (eq (car b
) 'var
)
296 (string-lessp (symbol-name (nth 1 a
)) (symbol-name (nth 1 b
)))
297 (not (Math-numberp b
))))
298 ((eq (car b
) 'var
) (Math-numberp a
))
299 ((eq (car a
) (car b
))
300 (while (and (setq a
(cdr a
) b
(cdr b
)) a
301 (equal (car a
) (car b
))))
304 (math-beforep (car a
) (car b
)))))
305 (t (string-lessp (symbol-name (car a
)) (symbol-name (car b
))))))
308 (defsubst math-simplify-extended
(a)
309 (let ((math-living-dangerously t
))
312 (defalias 'calcFunc-esimplify
'math-simplify-extended
)
314 ;;; Rewrite the trig functions in a form easier to simplify.
315 (defun math-trig-rewrite (fn)
316 "Rewrite trigonometric functions in terms of sines and cosines."
320 ((eq (car-safe fn
) 'calcFunc-sec
)
321 (list '/ 1 (cons 'calcFunc-cos
(math-trig-rewrite (cdr fn
)))))
322 ((eq (car-safe fn
) 'calcFunc-csc
)
323 (list '/ 1 (cons 'calcFunc-sin
(math-trig-rewrite (cdr fn
)))))
324 ((eq (car-safe fn
) 'calcFunc-tan
)
325 (let ((newfn (math-trig-rewrite (cdr fn
))))
326 (list '/ (cons 'calcFunc-sin newfn
)
327 (cons 'calcFunc-cos newfn
))))
328 ((eq (car-safe fn
) 'calcFunc-cot
)
329 (let ((newfn (math-trig-rewrite (cdr fn
))))
330 (list '/ (cons 'calcFunc-cos newfn
)
331 (cons 'calcFunc-sin newfn
))))
333 (mapcar 'math-trig-rewrite fn
))))
335 (defun math-hyperbolic-trig-rewrite (fn)
336 "Rewrite hyperbolic functions in terms of sinhs and coshs."
340 ((eq (car-safe fn
) 'calcFunc-sech
)
341 (list '/ 1 (cons 'calcFunc-cosh
(math-hyperbolic-trig-rewrite (cdr fn
)))))
342 ((eq (car-safe fn
) 'calcFunc-csch
)
343 (list '/ 1 (cons 'calcFunc-sinh
(math-hyperbolic-trig-rewrite (cdr fn
)))))
344 ((eq (car-safe fn
) 'calcFunc-tanh
)
345 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn
))))
346 (list '/ (cons 'calcFunc-sinh newfn
)
347 (cons 'calcFunc-cosh newfn
))))
348 ((eq (car-safe fn
) 'calcFunc-coth
)
349 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn
))))
350 (list '/ (cons 'calcFunc-cosh newfn
)
351 (cons 'calcFunc-sinh newfn
))))
353 (mapcar 'math-hyperbolic-trig-rewrite fn
))))
355 ;; math-top-only is local to math-simplify, but is used by
356 ;; math-simplify-step, which is called by math-simplify.
357 (defvar math-top-only
)
359 (defun math-simplify (top-expr)
360 (let ((math-simplifying t
)
361 (math-top-only (consp calc-simplify-mode
))
362 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
363 '((var AlgSimpRules var-AlgSimpRules
)))
364 (and math-living-dangerously
365 (calc-has-rules 'var-ExtSimpRules
)
366 '((var ExtSimpRules var-ExtSimpRules
)))
367 (and math-simplifying-units
368 (calc-has-rules 'var-UnitSimpRules
)
369 '((var UnitSimpRules var-UnitSimpRules
)))
370 (and math-integrating
371 (calc-has-rules 'var-IntegSimpRules
)
372 '((var IntegSimpRules var-IntegSimpRules
)))))
375 (let ((r simp-rules
))
376 (setq res
(math-simplify-step (math-normalize top-expr
))
377 calc-simplify-mode
'(nil)
378 top-expr
(math-normalize res
))
380 (setq top-expr
(math-rewrite top-expr
(car r
)
381 '(neg (var inf var-inf
)))
383 (calc-with-default-simplification
384 (while (let ((r simp-rules
))
385 (setq res
(math-normalize top-expr
))
387 (setq res
(math-rewrite res
(car r
))
389 (not (equal top-expr
(setq res
(math-simplify-step res
)))))
390 (setq top-expr res
)))))
393 (defalias 'calcFunc-simplify
'math-simplify
)
395 ;;; The following has a "bug" in that if any recursive simplifications
396 ;;; occur only the first handler will be tried; this doesn't really
397 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
398 (defun math-simplify-step (a)
401 (let ((aa (if (or math-top-only
402 (memq (car a
) '(calcFunc-quote calcFunc-condition
405 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
406 (and (symbolp (car aa
))
407 (let ((handler (get (car aa
) 'math-simplify
)))
410 (equal (setq aa
(or (funcall (car handler
) aa
)
413 (setq handler
(cdr handler
))))))
417 (defmacro math-defsimplify
(funcs &rest code
)
419 (mapcar #'(lambda (func)
420 `(put ',func
'math-simplify
422 (get ',func
'math-simplify
)
424 #'(lambda (math-simplify-expr) ,@code
)))))
425 (if (symbolp funcs
) (list funcs
) funcs
))))
426 (put 'math-defsimplify
'lisp-indent-hook
1)
428 ;; The function created by math-defsimplify uses the variable
429 ;; math-simplify-expr, and so is used by functions in math-defsimplify
430 (defvar math-simplify-expr
)
432 (math-defsimplify (+ -
)
433 (math-simplify-plus))
435 (defun math-simplify-plus ()
436 (cond ((and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
437 (Math-numberp (nth 2 (nth 1 math-simplify-expr
)))
438 (not (Math-numberp (nth 2 math-simplify-expr
))))
439 (let ((x (nth 2 math-simplify-expr
))
440 (op (car math-simplify-expr
)))
441 (setcar (cdr (cdr math-simplify-expr
)) (nth 2 (nth 1 math-simplify-expr
)))
442 (setcar math-simplify-expr
(car (nth 1 math-simplify-expr
)))
443 (setcar (cdr (cdr (nth 1 math-simplify-expr
))) x
)
444 (setcar (nth 1 math-simplify-expr
) op
)))
445 ((and (eq (car math-simplify-expr
) '+)
446 (Math-numberp (nth 1 math-simplify-expr
))
447 (not (Math-numberp (nth 2 math-simplify-expr
))))
448 (let ((x (nth 2 math-simplify-expr
)))
449 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
450 (setcar (cdr math-simplify-expr
) x
))))
451 (let ((aa math-simplify-expr
)
453 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
454 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 math-simplify-expr
)
456 (eq (car math-simplify-expr
) '-
) t
))
458 (setcar (cdr (cdr math-simplify-expr
)) temp
)
459 (setcar math-simplify-expr
'+)
460 (setcar (cdr (cdr aaa
)) 0)))
461 (setq aa
(nth 1 aa
)))
462 (if (setq temp
(math-combine-sum aaa
(nth 2 math-simplify-expr
)
463 nil
(eq (car math-simplify-expr
) '-
) t
))
465 (setcar (cdr (cdr math-simplify-expr
)) temp
)
466 (setcar math-simplify-expr
'+)
467 (setcar (cdr aa
) 0)))
471 (math-simplify-times))
473 (defun math-simplify-times ()
474 (if (eq (car-safe (nth 2 math-simplify-expr
)) '*)
475 (and (math-beforep (nth 1 (nth 2 math-simplify-expr
)) (nth 1 math-simplify-expr
))
476 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
477 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr
)) t
))
478 (let ((x (nth 1 math-simplify-expr
)))
479 (setcar (cdr math-simplify-expr
) (nth 1 (nth 2 math-simplify-expr
)))
480 (setcar (cdr (nth 2 math-simplify-expr
)) x
)))
481 (and (math-beforep (nth 2 math-simplify-expr
) (nth 1 math-simplify-expr
))
482 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
483 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
484 (let ((x (nth 2 math-simplify-expr
)))
485 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
486 (setcar (cdr math-simplify-expr
) x
))))
487 (let ((aa math-simplify-expr
)
489 (safe t
) (scalar (math-known-scalarp (nth 1 math-simplify-expr
))))
490 (if (and (Math-ratp (nth 1 math-simplify-expr
))
491 (setq temp
(math-common-constant-factor (nth 2 math-simplify-expr
))))
493 (setcar (cdr (cdr math-simplify-expr
))
494 (math-cancel-common-factor (nth 2 math-simplify-expr
) temp
))
495 (setcar (cdr math-simplify-expr
) (math-mul (nth 1 math-simplify-expr
) temp
))))
496 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
498 (if (setq temp
(math-combine-prod (nth 1 math-simplify-expr
)
499 (nth 1 aaa
) nil nil t
))
501 (setcar (cdr math-simplify-expr
) temp
)
502 (setcar (cdr aaa
) 1)))
503 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
505 (if (and (setq temp
(math-combine-prod aaa
(nth 1 math-simplify-expr
) nil nil t
))
508 (setcar (cdr math-simplify-expr
) temp
)
509 (setcar (cdr (cdr aa
)) 1)))
510 (if (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
511 (memq (nth 1 (nth 1 math-simplify-expr
)) '(1 -
1)))
512 (math-div (math-mul (nth 2 math-simplify-expr
)
513 (nth 1 (nth 1 math-simplify-expr
)))
514 (nth 2 (nth 1 math-simplify-expr
)))
515 math-simplify-expr
)))
518 (math-simplify-divide))
520 (defun math-simplify-divide ()
521 (let ((np (cdr math-simplify-expr
))
523 (nn (and (or (eq (car math-simplify-expr
) '/)
524 (not (Math-realp (nth 2 math-simplify-expr
))))
525 (math-common-constant-factor (nth 2 math-simplify-expr
))))
529 (setq n
(and (or (eq (car math-simplify-expr
) '/)
530 (not (Math-realp (nth 1 math-simplify-expr
))))
531 (math-common-constant-factor (nth 1 math-simplify-expr
))))
532 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
534 (setcar (cdr math-simplify-expr
)
535 (math-mul (nth 2 nn
) (nth 1 math-simplify-expr
)))
536 (setcar (cdr (cdr math-simplify-expr
))
537 (math-cancel-common-factor (nth 2 math-simplify-expr
) nn
))
538 (if (and (math-negp nn
)
539 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
)))
540 (setcar math-simplify-expr
(nth 1 op
))))
541 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
543 (setcar (cdr math-simplify-expr
)
544 (math-cancel-common-factor (nth 1 math-simplify-expr
) n
))
545 (setcar (cdr (cdr math-simplify-expr
))
546 (math-cancel-common-factor (nth 2 math-simplify-expr
) n
))
547 (if (and (math-negp n
)
548 (setq op
(assq (car math-simplify-expr
)
549 calc-tweak-eqn-table
)))
550 (setcar math-simplify-expr
(nth 1 op
))))))))
551 (if (and (eq (car-safe (car np
)) '/)
552 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
554 (setq np
(cdr (nth 1 math-simplify-expr
)))
555 (while (eq (car-safe (setq n
(car np
))) '*)
556 (and (math-known-scalarp (nth 2 n
) t
)
557 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nil t
))
558 (setq np
(cdr (cdr n
))))
559 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nil t
)
561 np
(cdr (cdr (nth 1 math-simplify-expr
))))))
562 (while (eq (car-safe (setq n
(car np
))) '*)
563 (and (math-known-scalarp (nth 2 n
) t
)
564 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nover t
))
565 (setq np
(cdr (cdr n
))))
566 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nover t
)
569 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
570 ;; are local variables for math-simplify-divisor, but are used by
571 ;; math-simplify-one-divisor.
572 (defvar math-simplify-divisor-nover
)
573 (defvar math-simplify-divisor-dover
)
575 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
576 math-simplify-divisor-dover
)
577 (cond ((eq (car-safe (car dp
)) '/)
578 (math-simplify-divisor np
(cdr (car dp
))
579 math-simplify-divisor-nover
580 math-simplify-divisor-dover
)
581 (and (math-known-scalarp (nth 1 (car dp
)) t
)
582 (math-simplify-divisor np
(cdr (cdr (car dp
)))
583 math-simplify-divisor-nover
584 (not math-simplify-divisor-dover
))))
585 ((or (or (eq (car math-simplify-expr
) '/)
586 (let ((signs (math-possible-signs (car np
))))
587 (or (memq signs
'(1 4))
588 (and (memq (car math-simplify-expr
) '(calcFunc-eq calcFunc-neq
))
590 math-living-dangerously
)))
591 (math-numberp (car np
)))
594 (scalar (math-known-scalarp (car np
))))
595 (while (and (eq (car-safe (setq d
(car dp
))) '*)
597 (math-simplify-one-divisor np
(cdr d
))
598 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
601 (math-simplify-one-divisor np dp
))))))
603 (defun math-simplify-one-divisor (np dp
)
604 (let ((temp (math-combine-prod (car np
) (car dp
) math-simplify-divisor-nover
605 math-simplify-divisor-dover t
))
609 (and (not (memq (car math-simplify-expr
) '(/ calcFunc-eq calcFunc-neq
)))
610 (math-known-negp (car dp
))
611 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
))
612 (setcar math-simplify-expr
(nth 1 op
)))
613 (setcar np
(if math-simplify-divisor-nover
(math-div 1 temp
) temp
))
615 (and math-simplify-divisor-dover
(not math-simplify-divisor-nover
)
616 (eq (car math-simplify-expr
) '/)
617 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
618 (Math-integerp (nth 1 (car dp
)))
620 (setcar np
(math-mul (car np
)
621 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
622 (setcar dp
(nth 1 (car dp
))))))))
624 (defun math-common-constant-factor (expr)
625 (if (Math-realp expr
)
627 (and (not (memq expr
'(0 1 -
1)))
629 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
630 (math-common-constant-factor expr
)))
631 (if (memq (car expr
) '(+ - cplx sdev
))
632 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
633 (f2 (math-common-constant-factor (nth 2 expr
))))
635 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
637 (if (memq (car expr
) '(* polar
))
638 (math-common-constant-factor (nth 1 expr
))
639 (if (eq (car expr
) '/)
640 (or (math-common-constant-factor (nth 1 expr
))
641 (and (Math-integerp (nth 2 expr
))
642 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
644 (defun math-cancel-common-factor (expr val
)
645 (if (memq (car-safe expr
) '(+ - cplx sdev
))
647 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
648 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
650 (if (eq (car-safe expr
) '*)
651 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
652 (math-div expr val
))))
654 (defun math-frac-gcd (a b
)
659 (if (and (Math-integerp a
)
662 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
663 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
664 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
665 (math-gcd (nth 2 a
) (nth 2 b
)))))))
670 (defun math-simplify-mod ()
671 (and (Math-realp (nth 2 math-simplify-expr
))
672 (Math-posp (nth 2 math-simplify-expr
))
673 (let ((lin (math-is-linear (nth 1 math-simplify-expr
)))
676 (or (math-negp (car lin
))
677 (not (Math-lessp (car lin
) (nth 2 math-simplify-expr
))))
680 (math-mul (nth 1 lin
) (nth 2 lin
))
681 (math-mod (car lin
) (nth 2 math-simplify-expr
)))
682 (nth 2 math-simplify-expr
)))
684 (not (math-equal-int (nth 1 lin
) 1))
685 (math-num-integerp (nth 1 lin
))
686 (math-num-integerp (nth 2 math-simplify-expr
))
687 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 math-simplify-expr
)))
688 (not (math-equal-int t1
1))
693 (math-mul (math-div (nth 1 lin
) t1
)
695 (let ((calc-prefer-frac t
))
696 (math-div (car lin
) t1
)))
697 (math-div (nth 2 math-simplify-expr
) t1
))))
698 (and (math-equal-int (nth 2 math-simplify-expr
) 1)
699 (math-known-integerp (if lin
700 (math-mul (nth 1 lin
) (nth 2 lin
))
701 (nth 1 math-simplify-expr
)))
702 (if lin
(math-mod (car lin
) 1) 0))))))
704 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
705 calcFunc-gt calcFunc-leq calcFunc-geq
)
706 (if (= (length math-simplify-expr
) 3)
707 (math-simplify-ineq)))
709 (defun math-simplify-ineq ()
710 (let ((np (cdr math-simplify-expr
))
712 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
713 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr math-simplify-expr
))
716 (math-simplify-add-term np
(cdr (cdr math-simplify-expr
)) nil
717 (eq np
(cdr math-simplify-expr
)))
718 (math-simplify-divide)
719 (let ((signs (math-possible-signs (cons '-
(cdr math-simplify-expr
)))))
720 (or (cond ((eq (car math-simplify-expr
) 'calcFunc-eq
)
721 (or (and (eq signs
2) 1)
722 (and (memq signs
'(1 4 5)) 0)))
723 ((eq (car math-simplify-expr
) 'calcFunc-neq
)
724 (or (and (eq signs
2) 0)
725 (and (memq signs
'(1 4 5)) 1)))
726 ((eq (car math-simplify-expr
) 'calcFunc-lt
)
727 (or (and (eq signs
1) 1)
728 (and (memq signs
'(2 4 6)) 0)))
729 ((eq (car math-simplify-expr
) 'calcFunc-gt
)
730 (or (and (eq signs
4) 1)
731 (and (memq signs
'(1 2 3)) 0)))
732 ((eq (car math-simplify-expr
) 'calcFunc-leq
)
733 (or (and (eq signs
4) 0)
734 (and (memq signs
'(1 2 3)) 1)))
735 ((eq (car math-simplify-expr
) 'calcFunc-geq
)
736 (or (and (eq signs
1) 0)
737 (and (memq signs
'(2 4 6)) 1))))
738 math-simplify-expr
))))
740 (defun math-simplify-add-term (np dp minus lplain
)
741 (or (math-vectorp (car np
))
744 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
746 (if (setq temp
(math-combine-sum n
(nth 2 d
)
747 minus
(eq (car d
) '+) t
))
748 (if (or lplain
(eq (math-looks-negp temp
) minus
))
750 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
751 (setcar (cdr (cdr d
)) 0))
754 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
758 (if (setq temp
(math-combine-sum n d minus t t
))
761 (eq (math-looks-negp temp
) minus
)))
763 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
767 (setcar dp
(setq n
(math-neg temp
)))))))))
769 (math-defsimplify calcFunc-sin
770 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
771 (nth 1 (nth 1 math-simplify-expr
)))
772 (and (math-looks-negp (nth 1 math-simplify-expr
))
773 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 math-simplify-expr
)))))
774 (and (eq calc-angle-mode
'rad
)
775 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
777 (math-known-sin (car n
) (nth 1 n
) 120 0))))
778 (and (eq calc-angle-mode
'deg
)
779 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
781 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
782 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
783 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
784 (nth 1 (nth 1 math-simplify-expr
))))))
785 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
786 (math-div (nth 1 (nth 1 math-simplify-expr
))
788 (math-add 1 (math-sqr
789 (nth 1 (nth 1 math-simplify-expr
)))))))
790 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
791 (and m
(integerp (car m
))
792 (let ((n (car m
)) (a (nth 1 m
)))
794 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
795 (list 'calcFunc-cos a
))
796 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
797 (list 'calcFunc-sin a
))))))))
799 (math-defsimplify calcFunc-cos
800 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
801 (nth 1 (nth 1 math-simplify-expr
)))
802 (and (math-looks-negp (nth 1 math-simplify-expr
))
803 (list 'calcFunc-cos
(math-neg (nth 1 math-simplify-expr
))))
804 (and (eq calc-angle-mode
'rad
)
805 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
807 (math-known-sin (car n
) (nth 1 n
) 120 300))))
808 (and (eq calc-angle-mode
'deg
)
809 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
811 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
812 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
814 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))
815 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
819 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
820 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
821 (and m
(integerp (car m
))
822 (let ((n (car m
)) (a (nth 1 m
)))
824 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
825 (list 'calcFunc-cos a
))
826 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
827 (list 'calcFunc-sin a
))))))))
829 (math-defsimplify calcFunc-sec
830 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
831 (list 'calcFunc-sec
(math-neg (nth 1 math-simplify-expr
))))
832 (and (eq calc-angle-mode
'rad
)
833 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
835 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 300)))))
836 (and (eq calc-angle-mode
'deg
)
837 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
839 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300)))))
840 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
844 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
845 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
848 (nth 1 (nth 1 math-simplify-expr
))))
849 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
852 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
854 (math-defsimplify calcFunc-csc
855 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
856 (math-neg (list 'calcFunc-csc
(math-neg (nth 1 math-simplify-expr
)))))
857 (and (eq calc-angle-mode
'rad
)
858 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
860 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 0)))))
861 (and (eq calc-angle-mode
'deg
)
862 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
864 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0)))))
865 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
866 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
867 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
870 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
871 (nth 1 (nth 1 math-simplify-expr
)))))))
872 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
873 (math-div (list 'calcFunc-sqrt
874 (math-add 1 (math-sqr
875 (nth 1 (nth 1 math-simplify-expr
)))))
876 (nth 1 (nth 1 math-simplify-expr
))))))
878 (defun math-should-expand-trig (x &optional hyperbolic
)
879 (let ((m (math-is-multiple x
)))
880 (and math-living-dangerously
881 m
(or (and (integerp (car m
)) (> (car m
) 1))
882 (equal (car m
) '(frac 1 2)))
884 (memq (car-safe (nth 1 m
))
886 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
887 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
888 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
889 (eq hyperbolic
'exp
)))
892 (defun math-known-sin (plus n mul off
)
893 (setq n
(math-mul n mul
))
894 (and (math-num-integerp n
)
895 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
897 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
901 (if (math-zerop plus
)
902 (and (or calc-symbolic-mode
906 (10 .
(/ (calcFunc-sqrt
907 (- 2 (calcFunc-sqrt 3))) 2))
908 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
909 (15 .
(/ (calcFunc-sqrt
910 (- 2 (calcFunc-sqrt 2))) 2))
912 (24 .
(* (^
(/ 1 2) (/ 3 2))
914 (- 5 (calcFunc-sqrt 5)))))
915 (30 .
(/ (calcFunc-sqrt 2) 2))
916 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
917 (40 .
(/ (calcFunc-sqrt 3) 2))
918 (45 .
(/ (calcFunc-sqrt
919 (+ 2 (calcFunc-sqrt 2))) 2))
920 (48 .
(* (^
(/ 1 2) (/ 3 2))
922 (+ 5 (calcFunc-sqrt 5)))))
923 (50 .
(/ (calcFunc-sqrt
924 (+ 2 (calcFunc-sqrt 3))) 2))
926 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
927 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
930 (math-defsimplify calcFunc-tan
931 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
932 (nth 1 (nth 1 math-simplify-expr
)))
933 (and (math-looks-negp (nth 1 math-simplify-expr
))
934 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 math-simplify-expr
)))))
935 (and (eq calc-angle-mode
'rad
)
936 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
938 (math-known-tan (car n
) (nth 1 n
) 120))))
939 (and (eq calc-angle-mode
'deg
)
940 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
942 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
943 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
944 (math-div (nth 1 (nth 1 math-simplify-expr
))
946 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
947 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
948 (math-div (list 'calcFunc-sqrt
949 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
950 (nth 1 (nth 1 math-simplify-expr
))))
951 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
953 (if (equal (car m
) '(frac 1 2))
954 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
955 (list 'calcFunc-sin
(nth 1 m
)))
956 (math-div (list 'calcFunc-sin
(nth 1 math-simplify-expr
))
957 (list 'calcFunc-cos
(nth 1 math-simplify-expr
))))))))
959 (math-defsimplify calcFunc-cot
960 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
961 (math-neg (list 'calcFunc-cot
(math-neg (nth 1 math-simplify-expr
)))))
962 (and (eq calc-angle-mode
'rad
)
963 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
965 (math-div 1 (math-known-tan (car n
) (nth 1 n
) 120)))))
966 (and (eq calc-angle-mode
'deg
)
967 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
969 (math-div 1 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3))))))
970 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
971 (math-div (list 'calcFunc-sqrt
972 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
973 (nth 1 (nth 1 math-simplify-expr
))))
974 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
975 (math-div (nth 1 (nth 1 math-simplify-expr
))
977 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
978 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
979 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
981 (defun math-known-tan (plus n mul
)
982 (setq n
(math-mul n mul
))
983 (and (math-num-integerp n
)
984 (setq n
(math-mod (math-trunc n
) 120))
986 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
988 (if (math-zerop plus
)
989 (and (or calc-symbolic-mode
991 (cdr (assq n
'( (0 .
0)
992 (10 .
(- 2 (calcFunc-sqrt 3)))
994 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
995 (15 .
(- (calcFunc-sqrt 2) 1))
996 (20 .
(/ (calcFunc-sqrt 3) 3))
998 (- 5 (* 2 (calcFunc-sqrt 5)))))
1000 (36 .
(calcFunc-sqrt
1001 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1002 (40 .
(calcFunc-sqrt 3))
1003 (45 .
(+ (calcFunc-sqrt 2) 1))
1004 (48 .
(calcFunc-sqrt
1005 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1006 (50 .
(+ 2 (calcFunc-sqrt 3)))
1007 (60 .
(var uinf var-uinf
))))))
1008 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
1009 ((eq n
60) (math-normalize (list '/ -
1
1010 (list 'calcFunc-tan plus
))))
1013 (math-defsimplify calcFunc-sinh
1014 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1015 (nth 1 (nth 1 math-simplify-expr
)))
1016 (and (math-looks-negp (nth 1 math-simplify-expr
))
1017 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 math-simplify-expr
)))))
1018 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1019 math-living-dangerously
1020 (list 'calcFunc-sqrt
1021 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1022 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1023 math-living-dangerously
1024 (math-div (nth 1 (nth 1 math-simplify-expr
))
1025 (list 'calcFunc-sqrt
1026 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1027 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1028 (and m
(integerp (car m
))
1029 (let ((n (car m
)) (a (nth 1 m
)))
1032 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1033 (list 'calcFunc-cosh a
))
1034 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1035 (list 'calcFunc-sinh a
)))))))))
1037 (math-defsimplify calcFunc-cosh
1038 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1039 (nth 1 (nth 1 math-simplify-expr
)))
1040 (and (math-looks-negp (nth 1 math-simplify-expr
))
1041 (list 'calcFunc-cosh
(math-neg (nth 1 math-simplify-expr
))))
1042 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1043 math-living-dangerously
1044 (list 'calcFunc-sqrt
1045 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1046 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1047 math-living-dangerously
1049 (list 'calcFunc-sqrt
1050 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1051 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1052 (and m
(integerp (car m
))
1053 (let ((n (car m
)) (a (nth 1 m
)))
1056 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1057 (list 'calcFunc-cosh a
))
1058 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1059 (list 'calcFunc-sinh a
)))))))))
1061 (math-defsimplify calcFunc-tanh
1062 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1063 (nth 1 (nth 1 math-simplify-expr
)))
1064 (and (math-looks-negp (nth 1 math-simplify-expr
))
1065 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 math-simplify-expr
)))))
1066 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1067 math-living-dangerously
1068 (math-div (nth 1 (nth 1 math-simplify-expr
))
1069 (list 'calcFunc-sqrt
1070 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1071 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1072 math-living-dangerously
1073 (math-div (list 'calcFunc-sqrt
1074 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1075 (nth 1 (nth 1 math-simplify-expr
))))
1076 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1078 (if (equal (car m
) '(frac 1 2))
1079 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
1080 (list 'calcFunc-sinh
(nth 1 m
)))
1081 (math-div (list 'calcFunc-sinh
(nth 1 math-simplify-expr
))
1082 (list 'calcFunc-cosh
(nth 1 math-simplify-expr
))))))))
1084 (math-defsimplify calcFunc-sech
1085 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1086 (list 'calcFunc-sech
(math-neg (nth 1 math-simplify-expr
))))
1087 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1088 math-living-dangerously
1091 (list 'calcFunc-sqrt
1092 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1093 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1094 math-living-dangerously
1095 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))) 1)
1096 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1097 math-living-dangerously
1098 (list 'calcFunc-sqrt
1099 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
1101 (math-defsimplify calcFunc-csch
1102 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1103 (math-neg (list 'calcFunc-csch
(math-neg (nth 1 math-simplify-expr
)))))
1104 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1105 math-living-dangerously
1106 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
1107 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1108 math-living-dangerously
1111 (list 'calcFunc-sqrt
1112 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1113 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1114 math-living-dangerously
1115 (math-div (list 'calcFunc-sqrt
1116 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
1117 (nth 1 (nth 1 math-simplify-expr
))))))
1119 (math-defsimplify calcFunc-coth
1120 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1121 (math-neg (list 'calcFunc-coth
(math-neg (nth 1 math-simplify-expr
)))))
1122 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1123 math-living-dangerously
1124 (math-div (list 'calcFunc-sqrt
1125 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1126 (nth 1 (nth 1 math-simplify-expr
))))
1127 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1128 math-living-dangerously
1129 (math-div (nth 1 (nth 1 math-simplify-expr
))
1130 (list 'calcFunc-sqrt
1131 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1132 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1133 math-living-dangerously
1134 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
1136 (math-defsimplify calcFunc-arcsin
1137 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1138 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 math-simplify-expr
)))))
1139 (and (eq (nth 1 math-simplify-expr
) 1)
1140 (math-quarter-circle t
))
1141 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1142 (math-div (math-half-circle t
) 6))
1143 (and math-living-dangerously
1144 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1145 (nth 1 (nth 1 math-simplify-expr
)))
1146 (and math-living-dangerously
1147 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1148 (math-sub (math-quarter-circle t
)
1149 (nth 1 (nth 1 math-simplify-expr
))))))
1151 (math-defsimplify calcFunc-arccos
1152 (or (and (eq (nth 1 math-simplify-expr
) 0)
1153 (math-quarter-circle t
))
1154 (and (eq (nth 1 math-simplify-expr
) -
1)
1155 (math-half-circle t
))
1156 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1157 (math-div (math-half-circle t
) 3))
1158 (and (equal (nth 1 math-simplify-expr
) '(frac -
1 2))
1159 (math-div (math-mul (math-half-circle t
) 2) 3))
1160 (and math-living-dangerously
1161 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1162 (nth 1 (nth 1 math-simplify-expr
)))
1163 (and math-living-dangerously
1164 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1165 (math-sub (math-quarter-circle t
)
1166 (nth 1 (nth 1 math-simplify-expr
))))))
1168 (math-defsimplify calcFunc-arctan
1169 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1170 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 math-simplify-expr
)))))
1171 (and (eq (nth 1 math-simplify-expr
) 1)
1172 (math-div (math-half-circle t
) 4))
1173 (and math-living-dangerously
1174 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tan
)
1175 (nth 1 (nth 1 math-simplify-expr
)))))
1177 (math-defsimplify calcFunc-arcsinh
1178 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1179 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 math-simplify-expr
)))))
1180 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sinh
)
1181 (or math-living-dangerously
1182 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1183 (nth 1 (nth 1 math-simplify-expr
)))))
1185 (math-defsimplify calcFunc-arccosh
1186 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1187 (or math-living-dangerously
1188 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1189 (nth 1 (nth 1 math-simplify-expr
))))
1191 (math-defsimplify calcFunc-arctanh
1192 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1193 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 math-simplify-expr
)))))
1194 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tanh
)
1195 (or math-living-dangerously
1196 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1197 (nth 1 (nth 1 math-simplify-expr
)))))
1199 (math-defsimplify calcFunc-sqrt
1200 (math-simplify-sqrt))
1202 (defun math-simplify-sqrt ()
1203 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
1204 (math-div (list 'calcFunc-sqrt
1205 (math-mul (nth 1 (nth 1 math-simplify-expr
))
1206 (nth 2 (nth 1 math-simplify-expr
))))
1207 (nth 2 (nth 1 math-simplify-expr
))))
1208 (let ((fac (if (math-objectp (nth 1 math-simplify-expr
))
1209 (math-squared-factor (nth 1 math-simplify-expr
))
1210 (math-common-constant-factor (nth 1 math-simplify-expr
)))))
1211 (and fac
(not (eq fac
1))
1212 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
1214 (list 'calcFunc-sqrt
1215 (math-cancel-common-factor
1216 (nth 1 math-simplify-expr
) fac
))))))
1217 (and math-living-dangerously
1218 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1219 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 1)
1220 (eq (car-safe (nth 2 (nth 1 math-simplify-expr
))) '^
)
1221 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr
))) 2)
1222 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1225 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr
))))))
1226 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1229 (nth 1 (nth 1 (nth 2
1230 (nth 1 math-simplify-expr
))))))))
1231 (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1232 (math-equal-int (nth 2 (nth 1 math-simplify-expr
)) 1)
1233 (eq (car-safe (nth 1 (nth 1 math-simplify-expr
))) '^
)
1234 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr
))) 2)
1235 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr
))))
1237 (list 'calcFunc-sinh
1238 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr
)))))))
1239 (and (eq (car-safe (nth 1 math-simplify-expr
)) '+)
1240 (let ((a (nth 1 (nth 1 math-simplify-expr
)))
1241 (b (nth 2 (nth 1 math-simplify-expr
))))
1242 (and (or (and (math-equal-int a
1)
1243 (setq a b b
(nth 1 (nth 1 math-simplify-expr
))))
1244 (math-equal-int b
1))
1245 (eq (car-safe a
) '^
)
1246 (math-equal-int (nth 2 a
) 2)
1247 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
1248 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
1249 (and (eq (car-safe (nth 1 a
)) 'calcFunc-csch
)
1250 (list 'calcFunc-coth
(nth 1 (nth 1 a
))))
1251 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
1252 (list '/ 1 (list 'calcFunc-cos
1253 (nth 1 (nth 1 a
)))))
1254 (and (eq (car-safe (nth 1 a
)) 'calcFunc-cot
)
1255 (list '/ 1 (list 'calcFunc-sin
1256 (nth 1 (nth 1 a
)))))))))
1257 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1259 (nth 1 (nth 1 math-simplify-expr
))
1260 (math-div (nth 2 (nth 1 math-simplify-expr
)) 2)))
1261 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1262 (list '^
(nth 1 (nth 1 math-simplify-expr
)) (math-div 1 4)))
1263 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1264 (list (car (nth 1 math-simplify-expr
))
1265 (list 'calcFunc-sqrt
(nth 1 (nth 1 math-simplify-expr
)))
1266 (list 'calcFunc-sqrt
(nth 2 (nth 1 math-simplify-expr
)))))
1267 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
1268 (not (math-any-floats (nth 1 math-simplify-expr
)))
1269 (let ((f (calcFunc-factors (calcFunc-expand
1270 (nth 1 math-simplify-expr
)))))
1271 (and (math-vectorp f
)
1272 (or (> (length f
) 2)
1273 (> (nth 2 (nth 1 f
)) 1))
1274 (let ((out 1) (rest 1) (sums 1) fac pow
)
1275 (while (setq f
(cdr f
))
1276 (setq fac
(nth 1 (car f
))
1277 pow
(nth 2 (car f
)))
1279 (setq out
(math-mul out
(math-pow
1283 (if (memq (car-safe fac
) '(+ -
))
1284 (setq sums
(math-mul-thru sums fac
))
1285 (setq rest
(math-mul rest fac
)))))
1286 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1289 (list 'calcFunc-sqrt
1290 (math-mul sums rest
))))))))))))
1292 ;;; Rather than factoring x into primes, just check for the first ten primes.
1293 (defun math-squared-factor (x)
1294 (if (Math-integerp x
)
1295 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1299 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1301 fac
(math-mul fac
(car prsqr
)))
1302 (setq prsqr
(cdr prsqr
))))
1305 (math-defsimplify calcFunc-exp
1306 (math-simplify-exp (nth 1 math-simplify-expr
)))
1308 (defun math-simplify-exp (x)
1309 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1311 (and math-living-dangerously
1312 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1314 (list 'calcFunc-sqrt
1315 (math-add (math-sqr (nth 1 x
)) 1))))
1316 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1318 (list 'calcFunc-sqrt
1319 (math-sub (math-sqr (nth 1 x
)) 1))))
1320 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1321 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1322 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1323 (let ((m (math-should-expand-trig x
'exp
)))
1324 (and m
(integerp (car m
))
1325 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1326 (and calc-symbolic-mode
1327 (math-known-imagp x
)
1328 (let* ((ip (calcFunc-im x
))
1329 (n (math-linear-in ip
'(var pi var-pi
)))
1332 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1333 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1334 (list '+ c
(list '* s
'(var i var-i
))))))))
1336 (math-defsimplify calcFunc-ln
1337 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1338 (or math-living-dangerously
1339 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1340 (nth 1 (nth 1 math-simplify-expr
)))
1341 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1342 (equal (nth 1 (nth 1 math-simplify-expr
)) '(var e var-e
))
1343 (or math-living-dangerously
1344 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1345 (nth 2 (nth 1 math-simplify-expr
)))
1346 (and calc-symbolic-mode
1347 (math-known-negp (nth 1 math-simplify-expr
))
1348 (math-add (list 'calcFunc-ln
(math-neg (nth 1 math-simplify-expr
)))
1349 '(* (var pi var-pi
) (var i var-i
))))
1350 (and calc-symbolic-mode
1351 (math-known-imagp (nth 1 math-simplify-expr
))
1352 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr
)))
1353 (ips (math-possible-signs ip
)))
1354 (or (and (memq ips
'(4 6))
1355 (math-add (list 'calcFunc-ln ip
)
1356 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1357 (and (memq ips
'(1 3))
1358 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1359 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1362 (math-simplify-pow))
1364 (defun math-simplify-pow ()
1365 (or (and math-living-dangerously
1366 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1368 (nth 1 (nth 1 math-simplify-expr
))
1369 (math-mul (nth 2 math-simplify-expr
)
1370 (nth 2 (nth 1 math-simplify-expr
)))))
1371 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1373 (nth 1 (nth 1 math-simplify-expr
))
1374 (math-div (nth 2 math-simplify-expr
) 2)))
1375 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1376 (list (car (nth 1 math-simplify-expr
))
1377 (list '^
(nth 1 (nth 1 math-simplify-expr
))
1378 (nth 2 math-simplify-expr
))
1379 (list '^
(nth 2 (nth 1 math-simplify-expr
))
1380 (nth 2 math-simplify-expr
))))))
1381 (and (math-equal-int (nth 1 math-simplify-expr
) 10)
1382 (eq (car-safe (nth 2 math-simplify-expr
)) 'calcFunc-log10
)
1383 (nth 1 (nth 2 math-simplify-expr
)))
1384 (and (equal (nth 1 math-simplify-expr
) '(var e var-e
))
1385 (math-simplify-exp (nth 2 math-simplify-expr
)))
1386 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1387 (not math-integrating
)
1388 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 math-simplify-expr
))
1389 (nth 2 math-simplify-expr
))))
1390 (and (equal (nth 1 math-simplify-expr
) '(var i var-i
))
1392 (math-num-integerp (nth 2 math-simplify-expr
))
1393 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr
)) 4)))
1395 ((eq x
1) (nth 1 math-simplify-expr
))
1397 ((eq x
3) (math-neg (nth 1 math-simplify-expr
))))))
1398 (and math-integrating
1399 (integerp (nth 2 math-simplify-expr
))
1400 (>= (nth 2 math-simplify-expr
) 2)
1401 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1402 (math-mul (math-pow (nth 1 math-simplify-expr
)
1403 (- (nth 2 math-simplify-expr
) 2))
1407 (nth 1 (nth 1 math-simplify-expr
)))))))
1408 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1409 (math-mul (math-pow (nth 1 math-simplify-expr
)
1410 (- (nth 2 math-simplify-expr
) 2))
1413 (list 'calcFunc-sinh
1414 (nth 1 (nth 1 math-simplify-expr
)))))))))
1415 (and (eq (car-safe (nth 2 math-simplify-expr
)) 'frac
)
1416 (Math-ratp (nth 1 math-simplify-expr
))
1417 (Math-posp (nth 1 math-simplify-expr
))
1418 (if (equal (nth 2 math-simplify-expr
) '(frac 1 2))
1419 (list 'calcFunc-sqrt
(nth 1 math-simplify-expr
))
1420 (let ((flr (math-floor (nth 2 math-simplify-expr
))))
1421 (and (not (Math-zerop flr
))
1422 (list '* (list '^
(nth 1 math-simplify-expr
) flr
)
1423 (list '^
(nth 1 math-simplify-expr
)
1424 (math-sub (nth 2 math-simplify-expr
) flr
)))))))
1425 (and (eq (math-quarter-integer (nth 2 math-simplify-expr
)) 2)
1426 (let ((temp (math-simplify-sqrt)))
1428 (list '^ temp
(math-mul (nth 2 math-simplify-expr
) 2)))))))
1430 (math-defsimplify calcFunc-log10
1431 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1432 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 10)
1433 (or math-living-dangerously
1434 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1435 (nth 2 (nth 1 math-simplify-expr
))))
1438 (math-defsimplify calcFunc-erf
1439 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1440 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 math-simplify-expr
)))))
1441 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1442 (list 'calcFunc-conj
1443 (list 'calcFunc-erf
(nth 1 (nth 1 math-simplify-expr
)))))))
1445 (math-defsimplify calcFunc-erfc
1446 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1447 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 math-simplify-expr
)))))
1448 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1449 (list 'calcFunc-conj
1450 (list 'calcFunc-erfc
(nth 1 (nth 1 math-simplify-expr
)))))))
1453 (defun math-linear-in (expr term
&optional always
)
1454 (if (math-expr-contains expr term
)
1455 (let* ((calc-prefer-frac t
)
1456 (p (math-is-polynomial expr term
1)))
1459 (and always
(list expr
0))))
1461 (defun math-multiple-of (expr term
)
1462 (let ((p (math-linear-in expr term
)))
1464 (math-zerop (car p
))
1467 ; not perfect, but it'll do
1468 (defun math-integer-plus (expr)
1469 (cond ((Math-integerp expr
)
1471 ((and (memq (car expr
) '(+ -
))
1472 (Math-integerp (nth 1 expr
)))
1473 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1475 ((and (memq (car expr
) '(+ -
))
1476 (Math-integerp (nth 2 expr
)))
1478 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1481 (defun math-is-linear (expr &optional always
)
1484 (if (eq (car-safe expr
) '+)
1485 (if (Math-objectp (nth 1 expr
))
1486 (setq offset
(nth 1 expr
)
1488 (if (Math-objectp (nth 2 expr
))
1489 (setq offset
(nth 2 expr
)
1490 expr
(nth 1 expr
))))
1491 (if (eq (car-safe expr
) '-
)
1492 (if (Math-objectp (nth 1 expr
))
1493 (setq offset
(nth 1 expr
)
1494 expr
(math-neg (nth 2 expr
)))
1495 (if (Math-objectp (nth 2 expr
))
1496 (setq offset
(math-neg (nth 2 expr
))
1497 expr
(nth 1 expr
))))))
1498 (setq coef
(math-is-multiple expr always
))
1500 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1504 (defun math-is-multiple (expr &optional always
)
1505 (or (if (eq (car-safe expr
) '*)
1506 (if (Math-objectp (nth 1 expr
))
1507 (list (nth 1 expr
) (nth 2 expr
)))
1508 (if (eq (car-safe expr
) '/)
1509 (if (and (Math-objectp (nth 1 expr
))
1510 (not (math-equal-int (nth 1 expr
) 1)))
1511 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1512 (if (Math-objectp (nth 2 expr
))
1513 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1514 (let ((res (math-is-multiple (nth 1 expr
))))
1517 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1518 (setq res
(math-is-multiple (nth 2 expr
)))
1520 (list (math-div 1 (car res
))
1521 (math-div (nth 1 expr
)
1522 (nth 2 (nth 2 expr
)))))))))
1523 (if (eq (car-safe expr
) 'neg
)
1524 (list -
1 (nth 1 expr
)))))
1525 (if (Math-objvecp expr
)
1531 (defun calcFunc-lin (expr &optional var
)
1533 (let ((res (math-linear-in expr var t
)))
1534 (or res
(math-reject-arg expr
"Linear term expected"))
1535 (list 'vec
(car res
) (nth 1 res
) var
))
1536 (let ((res (math-is-linear expr t
)))
1537 (or res
(math-reject-arg expr
"Linear term expected"))
1540 (defun calcFunc-linnt (expr &optional var
)
1542 (let ((res (math-linear-in expr var
)))
1543 (or res
(math-reject-arg expr
"Linear term expected"))
1544 (list 'vec
(car res
) (nth 1 res
) var
))
1545 (let ((res (math-is-linear expr
)))
1546 (or res
(math-reject-arg expr
"Linear term expected"))
1549 (defun calcFunc-islin (expr &optional var
)
1550 (if (and (Math-objvecp expr
) (not var
))
1552 (calcFunc-lin expr var
)
1555 (defun calcFunc-islinnt (expr &optional var
)
1556 (if (Math-objvecp expr
)
1558 (calcFunc-linnt expr var
)
1564 ;;; Simple operations on expressions.
1566 ;;; Return number of occurrences of thing in expr, or nil if none.
1567 (defun math-expr-contains-count (expr thing
)
1568 (cond ((equal expr thing
) 1)
1569 ((Math-primp expr
) nil
)
1572 (while (setq expr
(cdr expr
))
1573 (setq num
(+ num
(or (math-expr-contains-count
1574 (car expr
) thing
) 0))))
1578 (defun math-expr-contains (expr thing
)
1579 (cond ((equal expr thing
) 1)
1580 ((Math-primp expr
) nil
)
1582 (while (and (setq expr
(cdr expr
))
1583 (not (math-expr-contains (car expr
) thing
))))
1586 ;;; Return non-nil if any variable of thing occurs in expr.
1587 (defun math-expr-depends (expr thing
)
1588 (if (Math-primp thing
)
1589 (and (eq (car-safe thing
) 'var
)
1590 (math-expr-contains expr thing
))
1591 (while (and (setq thing
(cdr thing
))
1592 (not (math-expr-depends expr
(car thing
)))))
1595 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1597 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1598 ;; for math-expr-subst, but used by math-expr-subst-rec.
1599 (defvar math-expr-subst-old
)
1600 (defvar math-expr-subst-new
)
1602 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new
)
1603 (math-expr-subst-rec expr
))
1605 (defalias 'calcFunc-subst
'math-expr-subst
)
1607 (defun math-expr-subst-rec (expr)
1608 (cond ((equal expr math-expr-subst-old
) math-expr-subst-new
)
1609 ((Math-primp expr
) expr
)
1610 ((memq (car expr
) '(calcFunc-deriv
1612 (if (= (length expr
) 2)
1613 (if (equal (nth 1 expr
) math-expr-subst-old
)
1614 (append expr
(list math-expr-subst-new
))
1616 (list (car expr
) (nth 1 expr
)
1617 (math-expr-subst-rec (nth 2 expr
)))))
1620 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1622 ;;; Various measures of the size of an expression.
1623 (defun math-expr-weight (expr)
1624 (if (Math-primp expr
)
1627 (while (setq expr
(cdr expr
))
1628 (setq w
(+ w
(math-expr-weight (car expr
)))))
1631 (defun math-expr-height (expr)
1632 (if (Math-primp expr
)
1635 (while (setq expr
(cdr expr
))
1636 (setq h
(max h
(math-expr-height (car expr
)))))
1642 ;;; Polynomial operations (to support the integrator and solve-for).
1644 (defun calcFunc-collect (expr base
)
1645 (let ((p (math-is-polynomial expr base
50 t
)))
1647 (math-build-polynomial-expr (mapcar 'math-normalize p
) base
)
1650 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1651 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1652 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1654 ;; These variables are local to math-is-polynomial, but are used by
1655 ;; math-is-poly-rec.
1656 (defvar math-is-poly-degree
)
1657 (defvar math-is-poly-loose
)
1660 (defun math-is-polynomial (expr math-var
&optional math-is-poly-degree math-is-poly-loose
)
1661 (let* ((math-poly-base-variable (if math-is-poly-loose
1662 (if (eq math-is-poly-loose
'gen
) math-var
'(var XXX XXX
))
1663 math-poly-base-variable
))
1664 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1665 (and (or (null math-is-poly-degree
)
1666 (<= (length poly
) (1+ math-is-poly-degree
)))
1669 (defun math-is-poly-rec (expr negpow
)
1671 (or (cond ((or (equal expr math-var
)
1672 (eq (car-safe expr
) '^
))
1675 (or (equal expr math-var
)
1676 (setq pow
(nth 2 expr
)
1678 (or (eq math-poly-mult-powers
1)
1679 (setq pow
(let ((m (math-is-multiple pow
1)))
1680 (and (eq (car-safe (car m
)) 'cplx
)
1681 (Math-zerop (nth 1 (car m
)))
1682 (setq m
(list (nth 2 (car m
))
1685 (and (if math-poly-mult-powers
1686 (equal math-poly-mult-powers
1688 (setq math-poly-mult-powers
(nth 1 m
)))
1689 (or (equal expr math-var
)
1690 (eq math-poly-mult-powers
1))
1694 (setq pow
(math-to-simple-fraction pow
))
1695 (and (eq (car-safe pow
) 'frac
)
1696 math-poly-frac-powers
1697 (equal expr math-var
)
1698 (setq math-poly-frac-powers
1699 (calcFunc-lcm math-poly-frac-powers
1701 (or (memq math-poly-frac-powers
'(1 nil
))
1702 (setq pow
(math-mul pow math-poly-frac-powers
)))
1705 (equal expr math-var
))
1708 (let ((p1 (if (equal expr math-var
)
1710 (math-is-poly-rec expr nil
)))
1714 (or (null math-is-poly-degree
)
1715 (<= (* (1- (length p1
)) n
) math-is-poly-degree
))
1718 (setq accum
(math-poly-mul accum p1
)
1722 (math-is-poly-rec expr nil
)
1723 (setq math-poly-neg-powers
1724 (cons (math-pow expr
(- pow
))
1725 math-poly-neg-powers
))
1726 (list (list '^ expr pow
))))))))
1727 ((Math-objectp expr
)
1729 ((memq (car expr
) '(+ -
))
1730 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1732 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1734 (math-poly-mix p1
1 p2
1735 (if (eq (car expr
) '+) 1 -
1)))))))
1736 ((eq (car expr
) 'neg
)
1737 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1739 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1741 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1743 (or (null math-is-poly-degree
)
1744 (<= (- (+ (length p1
) (length p2
)) 2)
1745 math-is-poly-degree
))
1746 (math-poly-mul p1 p2
))))))
1748 (and (or (not (math-poly-depends (nth 2 expr
) math-var
))
1750 (math-is-poly-rec (nth 2 expr
) nil
)
1751 (setq math-poly-neg-powers
1752 (cons (nth 2 expr
) math-poly-neg-powers
))))
1753 (not (Math-zerop (nth 2 expr
)))
1754 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1755 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1757 ((and (eq (car expr
) 'calcFunc-exp
)
1758 (equal math-var
'(var e var-e
)))
1759 (math-is-poly-rec (list '^ math-var
(nth 1 expr
)) negpow
))
1760 ((and (eq (car expr
) 'calcFunc-sqrt
)
1761 math-poly-frac-powers
)
1762 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1764 (and (or (not (math-poly-depends expr math-var
))
1766 (not (eq (car expr
) 'vec
))
1769 ;;; Check if expr is a polynomial in var; if so, return its degree.
1770 (defun math-polynomial-p (expr var
)
1771 (cond ((equal expr var
) 1)
1772 ((Math-primp expr
) 0)
1773 ((memq (car expr
) '(+ -
))
1774 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1776 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1779 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1781 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1783 ((eq (car expr
) 'neg
)
1784 (math-polynomial-p (nth 1 expr
) var
))
1785 ((and (eq (car expr
) '/)
1786 (not (math-poly-depends (nth 2 expr
) var
)))
1787 (math-polynomial-p (nth 1 expr
) var
))
1788 ((and (eq (car expr
) '^
)
1789 (natnump (nth 2 expr
)))
1790 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1791 (and p1
(* p1
(nth 2 expr
)))))
1792 ((math-poly-depends expr var
) nil
)
1795 (defun math-poly-depends (expr var
)
1796 (if math-poly-base-variable
1797 (math-expr-contains expr math-poly-base-variable
)
1798 (math-expr-depends expr var
)))
1800 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1801 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1802 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1803 (defvar math-poly-base-const-ok
)
1804 (defvar math-poly-base-pred
)
1806 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1807 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1808 ;; by math-polynomial-base.
1810 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred
)
1811 (or math-poly-base-pred
1812 (setq math-poly-base-pred
(function (lambda (base) (math-polynomial-p
1813 math-poly-base-top-expr base
)))))
1814 (or (let ((math-poly-base-const-ok nil
))
1815 (math-polynomial-base-rec math-poly-base-top-expr
))
1816 (let ((math-poly-base-const-ok t
))
1817 (math-polynomial-base-rec math-poly-base-top-expr
))))
1819 (defun math-polynomial-base-rec (mpb-expr)
1820 (and (not (Math-objvecp mpb-expr
))
1821 (or (and (memq (car mpb-expr
) '(+ -
*))
1822 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1823 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1824 (and (memq (car mpb-expr
) '(/ neg
))
1825 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1826 (and (eq (car mpb-expr
) '^
)
1827 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1828 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1829 (math-polynomial-base-rec '(var e var-e
)))
1830 (and (or math-poly-base-const-ok
(math-expr-contains-vars mpb-expr
))
1831 (funcall math-poly-base-pred mpb-expr
)
1834 ;;; Return non-nil if expr refers to any variables.
1835 (defun math-expr-contains-vars (expr)
1836 (or (eq (car-safe expr
) 'var
)
1837 (and (not (Math-primp expr
))
1839 (while (and (setq expr
(cdr expr
))
1840 (not (math-expr-contains-vars (car expr
)))))
1843 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1844 ;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
1845 (defun math-poly-simplify (p)
1847 (if (Math-zerop (nth (1- (length p
)) p
))
1848 (let ((pp (copy-sequence p
)))
1849 (while (and (cdr pp
)
1850 (Math-zerop (nth (1- (length pp
)) pp
)))
1851 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1855 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1856 ;;; coefficients ac, bc. Result may be unsimplified.
1857 (defun math-poly-mix (a ac b bc
)
1859 (cons (math-add (math-mul (or (car a
) 0) ac
)
1860 (math-mul (or (car b
) 0) bc
))
1861 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1863 (defun math-poly-zerop (a)
1865 (and (null (cdr a
)) (Math-zerop (car a
)))))
1867 ;;; Multiply two polynomials in list form.
1868 (defun math-poly-mul (a b
)
1870 (math-poly-mix b
(car a
)
1871 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1873 ;;; Build an expression from a polynomial list.
1874 (defun math-build-polynomial-expr (p var
)
1876 (if (Math-numberp var
)
1877 (math-with-extra-prec 1
1878 (let* ((rp (reverse p
))
1880 (while (setq rp
(cdr rp
))
1881 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1883 (let* ((rp (reverse p
))
1884 (n (1- (length rp
)))
1885 (accum (math-mul (car rp
) (math-pow var n
)))
1887 (while (setq rp
(cdr rp
))
1889 (or (math-zerop (car rp
))
1890 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1892 (math-mul (if (math-looks-negp (car rp
))
1895 (math-pow var n
))))))
1900 (defun math-to-simple-fraction (f)
1901 (or (and (eq (car-safe f
) 'float
)
1902 (or (and (>= (nth 2 f
) 0)
1903 (math-scale-int (nth 1 f
) (nth 2 f
)))
1904 (and (integerp (nth 1 f
))
1907 (math-make-frac (nth 1 f
)
1908 (math-scale-int 1 (- (nth 2 f
)))))))
1913 ;;; calc-alg.el ends here
