1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2017 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This file is autoloaded from calc-ext.el.
33 (defun calc-alg-evaluate (arg)
36 (calc-with-default-simplification
37 (let ((math-simplify-only nil
))
38 (calc-modify-simplify-mode arg
)
39 (calc-enter-result 1 "dsmp" (calc-top 1))))))
41 (defun calc-modify-simplify-mode (arg)
42 (if (= (math-abs arg
) 2)
43 (setq calc-simplify-mode
'alg
)
44 (if (>= (math-abs arg
) 3)
45 (setq calc-simplify-mode
'ext
)))
47 (setq calc-simplify-mode
(list calc-simplify-mode
))))
49 (defun calc-simplify ()
52 (let ((top (calc-top-n 1)))
55 (let ((calc-simplify-mode nil
))
56 (math-normalize (math-trig-rewrite top
)))))
57 (if (calc-is-hyperbolic)
59 (let ((calc-simplify-mode nil
))
60 (math-normalize (math-hyperbolic-trig-rewrite top
)))))
61 (calc-with-default-simplification
62 (calc-enter-result 1 "simp" (math-simplify top
))))))
64 (defun calc-simplify-extended ()
67 (calc-with-default-simplification
68 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
70 (defun calc-expand-formula (arg)
73 (calc-with-default-simplification
74 (let ((math-simplify-only nil
))
75 (calc-modify-simplify-mode arg
)
76 (calc-enter-result 1 "expf"
78 (let ((math-expand-formulas t
))
80 (let ((top (calc-top-n 1)))
81 (or (math-expand-formula top
)
84 (defun calc-factor (arg)
87 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
88 'calcFunc-factors
'calcFunc-factor
)
91 (defun calc-expand (n)
94 (calc-enter-result 1 "expa"
95 (append (list 'calcFunc-expand
97 (and n
(list (prefix-numeric-value n
)))))))
99 ;;; Write out powers (a*b*...)^n as a*b*...*a*b*...
100 (defun calcFunc-powerexpand (expr)
101 (math-normalize (math-map-tree 'math-powerexpand expr
)))
103 (defun math-powerexpand (expr)
104 (if (eq (car-safe expr
) '^
)
105 (let ((n (nth 2 expr
)))
106 (cond ((and (integerp n
)
112 (setq prod
(math-mul prod a
))
118 (a (math-pow (nth 1 expr
) -
1))
119 (prod (math-pow (nth 1 expr
) -
1)))
121 (setq prod
(math-mul a prod
))
128 (defun calc-powerexpand ()
131 (calc-enter-result 1 "pexp"
132 (calcFunc-powerexpand (calc-top-n 1)))))
134 (defun calc-collect (&optional var
)
135 (interactive "sCollect terms involving: ")
137 (if (or (equal var
"") (equal var
"$") (null var
))
138 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
139 (calc-top-list-n 2)))
140 (let ((var (math-read-expr var
)))
141 (if (eq (car-safe var
) 'error
)
142 (error "Bad format in expression: %s" (nth 1 var
)))
143 (calc-enter-result 1 "clct" (list 'calcFunc-collect
147 (defun calc-apart (arg)
150 (calc-unary-op "aprt" 'calcFunc-apart arg
)))
152 (defun calc-normalize-rat (arg)
155 (calc-unary-op "nrat" 'calcFunc-nrat arg
)))
157 (defun calc-poly-gcd (arg)
160 (calc-binary-op "pgcd" 'calcFunc-pgcd arg
)))
163 (defun calc-poly-div (arg)
166 (let ((calc-poly-div-remainder nil
))
167 (calc-binary-op "pdiv" 'calcFunc-pdiv arg
)
168 (if (and calc-poly-div-remainder
(null arg
))
170 (calc-clear-command-flag 'clear-message
)
171 (calc-record calc-poly-div-remainder
"prem")
172 (if (not (Math-zerop calc-poly-div-remainder
))
173 (message "(Remainder was %s)"
174 (math-format-flat-expr calc-poly-div-remainder
0))
175 (message "(No remainder)")))))))
177 (defun calc-poly-rem (arg)
180 (calc-binary-op "prem" 'calcFunc-prem arg
)))
182 (defun calc-poly-div-rem (arg)
185 (if (calc-is-hyperbolic)
186 (calc-binary-op "pdvr" 'calcFunc-pdivide arg
)
187 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg
))))
189 (defun calc-substitute (&optional oldname newname
)
190 (interactive "sSubstitute old: ")
192 (let (old new
(num 1) expr
)
193 (if (or (equal oldname
"") (equal oldname
"$") (null oldname
))
194 (setq new
(calc-top-n 1)
199 (progn (calc-unread-command ?\C-a
)
200 (setq newname
(read-string (concat "Substitute old: "
204 (if (or (equal newname
"") (equal newname
"$") (null newname
))
205 (setq new
(calc-top-n 1)
208 (setq new
(if (stringp newname
) (math-read-expr newname
) newname
))
209 (if (eq (car-safe new
) 'error
)
210 (error "Bad format in expression: %s" (nth 1 new
)))
211 (setq expr
(calc-top-n 1)))
212 (setq old
(if (stringp oldname
) (math-read-expr oldname
) oldname
))
213 (if (eq (car-safe old
) 'error
)
214 (error "Bad format in expression: %s" (nth 1 old
)))
215 (or (math-expr-contains expr old
)
216 (error "No occurrences found")))
217 (calc-enter-result num
"sbst" (math-expr-subst expr old new
)))))
220 (defun calc-has-rules (name)
221 (setq name
(calc-var-value name
))
223 (memq (car name
) '(vec calcFunc-assign calcFunc-condition
))
226 ;; math-eval-rules-cache and math-eval-rules-cache-other are
227 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
228 (defvar math-eval-rules-cache
)
229 (defvar math-eval-rules-cache-other
)
231 (defun math-recompile-eval-rules ()
232 (setq math-eval-rules-cache
(and (calc-has-rules 'var-EvalRules
)
233 (math-compile-rewrites
234 '(var EvalRules var-EvalRules
)))
235 math-eval-rules-cache-other
(assq nil math-eval-rules-cache
)
236 math-eval-rules-cache-tag
(calc-var-value 'var-EvalRules
)))
239 ;;; Try to expand a formula according to its definition.
240 (defun math-expand-formula (expr)
243 (or (get (car expr
) 'calc-user-defn
)
244 (get (car expr
) 'math-expandable
))
245 (let ((res (let ((math-expand-formulas t
))
246 (apply (car expr
) (cdr expr
)))))
247 (and (not (eq (car-safe res
) (car expr
)))
253 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
254 (defun math-beforep (a b
) ; [Public]
255 (cond ((and (Math-realp a
) (Math-realp b
))
256 (let ((comp (math-compare a b
)))
260 (> (length (memq (car-safe a
)
261 '(bigneg nil bigpos frac float
)))
262 (length (memq (car-safe b
)
263 '(bigneg nil bigpos frac float
))))))))
264 ((equal b
'(neg (var inf var-inf
))) nil
)
265 ((equal a
'(neg (var inf var-inf
))) t
)
266 ((equal a
'(var inf var-inf
)) nil
)
267 ((equal b
'(var inf var-inf
)) t
)
269 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
))
270 (if (or (math-beforep a
(nth 2 b
)) (Math-equal a
(nth 2 b
)))
275 (if (and (eq (car-safe a
) 'intv
) (math-intv-constp a
))
276 (if (math-beforep (nth 2 a
) b
)
280 ((and (eq (car a
) 'intv
) (eq (car b
) 'intv
)
281 (math-intv-constp a
) (math-intv-constp b
))
282 (let ((comp (math-compare (nth 2 a
) (nth 2 b
))))
283 (cond ((eq comp -
1) t
)
285 ((and (memq (nth 1 a
) '(2 3)) (memq (nth 1 b
) '(0 1))) t
)
286 ((and (memq (nth 1 a
) '(0 1)) (memq (nth 1 b
) '(2 3))) nil
)
287 ((eq (setq comp
(math-compare (nth 3 a
) (nth 3 b
))) -
1) t
)
289 ((and (memq (nth 1 a
) '(0 2)) (memq (nth 1 b
) '(1 3))) t
)
291 ((not (eq (not (Math-objectp a
)) (not (Math-objectp b
))))
294 (if (eq (car b
) 'var
)
295 (string-lessp (nth 1 a
) (nth 1 b
))
296 (not (Math-numberp b
))))
297 ((eq (car b
) 'var
) (Math-numberp a
))
298 ((eq (car a
) (car b
))
299 (while (and (setq a
(cdr a
) b
(cdr b
)) a
300 (equal (car a
) (car b
))))
303 (math-beforep (car a
) (car b
)))))
304 (t (string-lessp (car a
) (car b
)))))
307 (defsubst math-simplify-extended
(a)
308 (let ((math-living-dangerously t
))
311 (defalias 'calcFunc-esimplify
'math-simplify-extended
)
313 ;;; Rewrite the trig functions in a form easier to simplify.
314 (defun math-trig-rewrite (fn)
315 "Rewrite trigonometric functions in terms of sines and cosines."
319 ((eq (car-safe fn
) 'calcFunc-sec
)
320 (list '/ 1 (cons 'calcFunc-cos
(math-trig-rewrite (cdr fn
)))))
321 ((eq (car-safe fn
) 'calcFunc-csc
)
322 (list '/ 1 (cons 'calcFunc-sin
(math-trig-rewrite (cdr fn
)))))
323 ((eq (car-safe fn
) 'calcFunc-tan
)
324 (let ((newfn (math-trig-rewrite (cdr fn
))))
325 (list '/ (cons 'calcFunc-sin newfn
)
326 (cons 'calcFunc-cos newfn
))))
327 ((eq (car-safe fn
) 'calcFunc-cot
)
328 (let ((newfn (math-trig-rewrite (cdr fn
))))
329 (list '/ (cons 'calcFunc-cos newfn
)
330 (cons 'calcFunc-sin newfn
))))
332 (mapcar 'math-trig-rewrite fn
))))
334 (defun math-hyperbolic-trig-rewrite (fn)
335 "Rewrite hyperbolic functions in terms of sinhs and coshs."
339 ((eq (car-safe fn
) 'calcFunc-sech
)
340 (list '/ 1 (cons 'calcFunc-cosh
(math-hyperbolic-trig-rewrite (cdr fn
)))))
341 ((eq (car-safe fn
) 'calcFunc-csch
)
342 (list '/ 1 (cons 'calcFunc-sinh
(math-hyperbolic-trig-rewrite (cdr fn
)))))
343 ((eq (car-safe fn
) 'calcFunc-tanh
)
344 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn
))))
345 (list '/ (cons 'calcFunc-sinh newfn
)
346 (cons 'calcFunc-cosh newfn
))))
347 ((eq (car-safe fn
) 'calcFunc-coth
)
348 (let ((newfn (math-hyperbolic-trig-rewrite (cdr fn
))))
349 (list '/ (cons 'calcFunc-cosh newfn
)
350 (cons 'calcFunc-sinh newfn
))))
352 (mapcar 'math-hyperbolic-trig-rewrite fn
))))
354 ;; math-top-only is local to math-simplify, but is used by
355 ;; math-simplify-step, which is called by math-simplify.
356 (defvar math-top-only
)
358 ;; math-normalize-error is declared in calc.el.
359 (defvar math-normalize-error
)
360 (defun math-simplify (top-expr)
361 (let ((math-simplifying t
)
362 (math-top-only (consp calc-simplify-mode
))
363 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
364 '((var AlgSimpRules var-AlgSimpRules
)))
365 (and math-living-dangerously
366 (calc-has-rules 'var-ExtSimpRules
)
367 '((var ExtSimpRules var-ExtSimpRules
)))
368 (and math-simplifying-units
369 (calc-has-rules 'var-UnitSimpRules
)
370 '((var UnitSimpRules var-UnitSimpRules
)))
371 (and math-integrating
372 (calc-has-rules 'var-IntegSimpRules
)
373 '((var IntegSimpRules var-IntegSimpRules
)))))
376 (let ((r simp-rules
))
377 (setq res
(math-simplify-step (math-normalize top-expr
))
378 calc-simplify-mode
'(nil)
379 top-expr
(math-normalize res
))
381 (setq top-expr
(math-rewrite top-expr
(car r
)
382 '(neg (var inf var-inf
)))
384 (calc-with-default-simplification
385 (while (let ((r simp-rules
))
386 (setq res
(math-normalize top-expr
))
387 (if (not math-normalize-error
)
390 (setq res
(math-rewrite res
(car r
))
392 (not (equal top-expr
(setq res
(math-simplify-step res
)))))))
393 (setq top-expr res
)))))
396 (defalias 'calcFunc-simplify
'math-simplify
)
398 ;;; The following has a "bug" in that if any recursive simplifications
399 ;;; occur only the first handler will be tried; this doesn't really
400 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
401 (defun math-simplify-step (a)
404 (let ((aa (if (or math-top-only
405 (memq (car a
) '(calcFunc-quote calcFunc-condition
408 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
409 (and (symbolp (car aa
))
410 (let ((handler (get (car aa
) 'math-simplify
)))
413 (equal (setq aa
(or (funcall (car handler
) aa
)
416 (setq handler
(cdr handler
))))))
420 (defmacro math-defsimplify
(funcs &rest code
)
422 (mapcar #'(lambda (func)
423 `(put ',func
'math-simplify
425 (get ',func
'math-simplify
)
427 #'(lambda (math-simplify-expr) ,@code
)))))
428 (if (symbolp funcs
) (list funcs
) funcs
))))
429 (put 'math-defsimplify
'lisp-indent-hook
1)
431 ;; The function created by math-defsimplify uses the variable
432 ;; math-simplify-expr, and so is used by functions in math-defsimplify
433 (defvar math-simplify-expr
)
435 (math-defsimplify (+ -
)
436 (math-simplify-plus))
438 (defun math-simplify-plus ()
439 (cond ((and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
440 (Math-numberp (nth 2 (nth 1 math-simplify-expr
)))
441 (not (Math-numberp (nth 2 math-simplify-expr
))))
442 (let ((x (nth 2 math-simplify-expr
))
443 (op (car math-simplify-expr
)))
444 (setcar (cdr (cdr math-simplify-expr
)) (nth 2 (nth 1 math-simplify-expr
)))
445 (setcar math-simplify-expr
(car (nth 1 math-simplify-expr
)))
446 (setcar (cdr (cdr (nth 1 math-simplify-expr
))) x
)
447 (setcar (nth 1 math-simplify-expr
) op
)))
448 ((and (eq (car math-simplify-expr
) '+)
449 (Math-numberp (nth 1 math-simplify-expr
))
450 (not (Math-numberp (nth 2 math-simplify-expr
))))
451 (let ((x (nth 2 math-simplify-expr
)))
452 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
453 (setcar (cdr math-simplify-expr
) x
))))
454 (let ((aa math-simplify-expr
)
456 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
457 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 math-simplify-expr
)
459 (eq (car math-simplify-expr
) '-
) t
))
461 (setcar (cdr (cdr math-simplify-expr
)) temp
)
462 (setcar math-simplify-expr
'+)
463 (setcar (cdr (cdr aaa
)) 0)))
464 (setq aa
(nth 1 aa
)))
465 (if (setq temp
(math-combine-sum aaa
(nth 2 math-simplify-expr
)
466 nil
(eq (car math-simplify-expr
) '-
) t
))
468 (setcar (cdr (cdr math-simplify-expr
)) temp
)
469 (setcar math-simplify-expr
'+)
470 (setcar (cdr aa
) 0)))
474 (math-simplify-times))
476 (defun math-simplify-times ()
477 (if (eq (car-safe (nth 2 math-simplify-expr
)) '*)
478 (and (math-beforep (nth 1 (nth 2 math-simplify-expr
)) (nth 1 math-simplify-expr
))
479 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
480 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr
)) t
))
481 (let ((x (nth 1 math-simplify-expr
)))
482 (setcar (cdr math-simplify-expr
) (nth 1 (nth 2 math-simplify-expr
)))
483 (setcar (cdr (nth 2 math-simplify-expr
)) x
)))
484 (and (math-beforep (nth 2 math-simplify-expr
) (nth 1 math-simplify-expr
))
485 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
486 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
487 (let ((x (nth 2 math-simplify-expr
)))
488 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
489 (setcar (cdr math-simplify-expr
) x
))))
490 (let ((aa math-simplify-expr
)
492 (safe t
) (scalar (math-known-scalarp (nth 1 math-simplify-expr
))))
493 (if (and (Math-ratp (nth 1 math-simplify-expr
))
494 (setq temp
(math-common-constant-factor (nth 2 math-simplify-expr
))))
496 (setcar (cdr (cdr math-simplify-expr
))
497 (math-cancel-common-factor (nth 2 math-simplify-expr
) temp
))
498 (setcar (cdr math-simplify-expr
) (math-mul (nth 1 math-simplify-expr
) temp
))))
499 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
501 (if (setq temp
(math-combine-prod (nth 1 math-simplify-expr
)
502 (nth 1 aaa
) nil nil t
))
504 (setcar (cdr math-simplify-expr
) temp
)
505 (setcar (cdr aaa
) 1)))
506 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
508 (if (and (setq temp
(math-combine-prod aaa
(nth 1 math-simplify-expr
) nil nil t
))
511 (setcar (cdr math-simplify-expr
) temp
)
512 (setcar (cdr (cdr aa
)) 1)))
513 (if (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
514 (memq (nth 1 (nth 1 math-simplify-expr
)) '(1 -
1)))
515 (math-div (math-mul (nth 2 math-simplify-expr
)
516 (nth 1 (nth 1 math-simplify-expr
)))
517 (nth 2 (nth 1 math-simplify-expr
)))
518 math-simplify-expr
)))
521 (math-simplify-divide))
523 (defun math-simplify-divide ()
524 (let ((np (cdr math-simplify-expr
))
526 (nn (and (or (eq (car math-simplify-expr
) '/)
527 (not (Math-realp (nth 2 math-simplify-expr
))))
528 (math-common-constant-factor (nth 2 math-simplify-expr
))))
532 (setq n
(and (or (eq (car math-simplify-expr
) '/)
533 (not (Math-realp (nth 1 math-simplify-expr
))))
534 (math-common-constant-factor (nth 1 math-simplify-expr
))))
535 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
536 (unless (and (eq (car-safe math-simplify-expr
) 'calcFunc-eq
)
537 (eq (car-safe (nth 1 math-simplify-expr
)) 'var
)
538 (not (math-expr-contains (nth 2 math-simplify-expr
)
539 (nth 1 math-simplify-expr
))))
540 (setcar (cdr math-simplify-expr
)
541 (math-mul (nth 2 nn
) (nth 1 math-simplify-expr
)))
542 (setcar (cdr (cdr math-simplify-expr
))
543 (math-cancel-common-factor (nth 2 math-simplify-expr
) nn
))
544 (if (and (math-negp nn
)
545 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
)))
546 (setcar math-simplify-expr
(nth 1 op
))))
547 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
549 (setcar (cdr math-simplify-expr
)
550 (math-cancel-common-factor (nth 1 math-simplify-expr
) n
))
551 (setcar (cdr (cdr math-simplify-expr
))
552 (math-cancel-common-factor (nth 2 math-simplify-expr
) n
))
553 (if (and (math-negp n
)
554 (setq op
(assq (car math-simplify-expr
)
555 calc-tweak-eqn-table
)))
556 (setcar math-simplify-expr
(nth 1 op
))))))))
557 (if (and (eq (car-safe (car np
)) '/)
558 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
560 (setq np
(cdr (nth 1 math-simplify-expr
)))
561 (while (eq (car-safe (setq n
(car np
))) '*)
562 (and (math-known-scalarp (nth 2 n
) t
)
563 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nil t
))
564 (setq np
(cdr (cdr n
))))
565 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nil t
)
567 np
(cdr (cdr (nth 1 math-simplify-expr
))))))
568 (while (eq (car-safe (setq n
(car np
))) '*)
569 (and (math-known-scalarp (nth 2 n
) t
)
570 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nover t
))
571 (setq np
(cdr (cdr n
))))
572 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nover t
)
575 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
576 ;; are local variables for math-simplify-divisor, but are used by
577 ;; math-simplify-one-divisor.
578 (defvar math-simplify-divisor-nover
)
579 (defvar math-simplify-divisor-dover
)
581 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
582 math-simplify-divisor-dover
)
583 (cond ((eq (car-safe (car dp
)) '/)
584 (math-simplify-divisor np
(cdr (car dp
))
585 math-simplify-divisor-nover
586 math-simplify-divisor-dover
)
587 (and (math-known-scalarp (nth 1 (car dp
)) t
)
588 (math-simplify-divisor np
(cdr (cdr (car dp
)))
589 math-simplify-divisor-nover
590 (not math-simplify-divisor-dover
))))
591 ((or (or (eq (car math-simplify-expr
) '/)
592 (let ((signs (math-possible-signs (car np
))))
593 (or (memq signs
'(1 4))
594 (and (memq (car math-simplify-expr
) '(calcFunc-eq calcFunc-neq
))
596 math-living-dangerously
)))
597 (math-numberp (car np
)))
600 (scalar (math-known-scalarp (car np
))))
601 (while (and (eq (car-safe (setq d
(car dp
))) '*)
603 (math-simplify-one-divisor np
(cdr d
))
604 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
607 (math-simplify-one-divisor np dp
))))))
609 (defun math-simplify-one-divisor (np dp
)
610 (let ((temp (math-combine-prod (car np
) (car dp
) math-simplify-divisor-nover
611 math-simplify-divisor-dover t
))
615 (and (not (memq (car math-simplify-expr
) '(/ calcFunc-eq calcFunc-neq
)))
616 (math-known-negp (car dp
))
617 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
))
618 (setcar math-simplify-expr
(nth 1 op
)))
619 (setcar np
(if math-simplify-divisor-nover
(math-div 1 temp
) temp
))
621 (and math-simplify-divisor-dover
(not math-simplify-divisor-nover
)
622 (eq (car math-simplify-expr
) '/)
623 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
624 (Math-integerp (nth 1 (car dp
)))
626 (setcar np
(math-mul (car np
)
627 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
628 (setcar dp
(nth 1 (car dp
))))))))
630 (defun math-common-constant-factor (expr)
631 (if (Math-realp expr
)
633 (and (not (memq expr
'(0 1 -
1)))
635 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
636 (math-common-constant-factor expr
)))
637 (if (memq (car expr
) '(+ - cplx sdev
))
638 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
639 (f2 (math-common-constant-factor (nth 2 expr
))))
641 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
643 (if (memq (car expr
) '(* polar
))
644 (math-common-constant-factor (nth 1 expr
))
645 (if (eq (car expr
) '/)
646 (or (math-common-constant-factor (nth 1 expr
))
647 (and (Math-integerp (nth 2 expr
))
648 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
650 (defun math-cancel-common-factor (expr val
)
651 (if (memq (car-safe expr
) '(+ - cplx sdev
))
653 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
654 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
656 (if (eq (car-safe expr
) '*)
657 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
658 (math-div expr val
))))
660 (defun math-frac-gcd (a b
)
665 (if (and (Math-integerp a
)
668 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
669 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
670 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
671 (math-gcd (nth 2 a
) (nth 2 b
)))))))
676 (defun math-simplify-mod ()
677 (and (Math-realp (nth 2 math-simplify-expr
))
678 (Math-posp (nth 2 math-simplify-expr
))
679 (let ((lin (math-is-linear (nth 1 math-simplify-expr
)))
682 (or (math-negp (car lin
))
683 (not (Math-lessp (car lin
) (nth 2 math-simplify-expr
))))
686 (math-mul (nth 1 lin
) (nth 2 lin
))
687 (math-mod (car lin
) (nth 2 math-simplify-expr
)))
688 (nth 2 math-simplify-expr
)))
690 (not (math-equal-int (nth 1 lin
) 1))
691 (math-num-integerp (nth 1 lin
))
692 (math-num-integerp (nth 2 math-simplify-expr
))
693 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 math-simplify-expr
)))
694 (not (math-equal-int t1
1))
699 (math-mul (math-div (nth 1 lin
) t1
)
701 (let ((calc-prefer-frac t
))
702 (math-div (car lin
) t1
)))
703 (math-div (nth 2 math-simplify-expr
) t1
))))
704 (and (math-equal-int (nth 2 math-simplify-expr
) 1)
705 (math-known-integerp (if lin
706 (math-mul (nth 1 lin
) (nth 2 lin
))
707 (nth 1 math-simplify-expr
)))
708 (if lin
(math-mod (car lin
) 1) 0))))))
710 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
711 calcFunc-gt calcFunc-leq calcFunc-geq
)
712 (if (= (length math-simplify-expr
) 3)
713 (math-simplify-ineq)))
715 (defun math-simplify-ineq ()
716 (let ((np (cdr math-simplify-expr
))
718 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
719 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr math-simplify-expr
))
722 (math-simplify-add-term np
(cdr (cdr math-simplify-expr
)) nil
723 (eq np
(cdr math-simplify-expr
)))
724 (math-simplify-divide)
725 (let ((signs (math-possible-signs (cons '-
(cdr math-simplify-expr
)))))
726 (or (cond ((eq (car math-simplify-expr
) 'calcFunc-eq
)
727 (or (and (eq signs
2) 1)
728 (and (memq signs
'(1 4 5)) 0)))
729 ((eq (car math-simplify-expr
) 'calcFunc-neq
)
730 (or (and (eq signs
2) 0)
731 (and (memq signs
'(1 4 5)) 1)))
732 ((eq (car math-simplify-expr
) 'calcFunc-lt
)
733 (or (and (eq signs
1) 1)
734 (and (memq signs
'(2 4 6)) 0)))
735 ((eq (car math-simplify-expr
) 'calcFunc-gt
)
736 (or (and (eq signs
4) 1)
737 (and (memq signs
'(1 2 3)) 0)))
738 ((eq (car math-simplify-expr
) 'calcFunc-leq
)
739 (or (and (eq signs
4) 0)
740 (and (memq signs
'(1 2 3)) 1)))
741 ((eq (car math-simplify-expr
) 'calcFunc-geq
)
742 (or (and (eq signs
1) 0)
743 (and (memq signs
'(2 4 6)) 1))))
744 math-simplify-expr
))))
746 (defun math-simplify-add-term (np dp minus lplain
)
747 (or (math-vectorp (car np
))
750 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
752 (if (setq temp
(math-combine-sum n
(nth 2 d
)
753 minus
(eq (car d
) '+) t
))
754 (if (or lplain
(eq (math-looks-negp temp
) minus
))
756 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
757 (setcar (cdr (cdr d
)) 0))
760 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
764 (if (setq temp
(math-combine-sum n d minus t t
))
767 (eq (math-looks-negp temp
) minus
)))
769 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
773 (setcar dp
(setq n
(math-neg temp
)))))))))
775 (math-defsimplify calcFunc-sin
776 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
777 (nth 1 (nth 1 math-simplify-expr
)))
778 (and (math-looks-negp (nth 1 math-simplify-expr
))
779 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 math-simplify-expr
)))))
780 (and (eq calc-angle-mode
'rad
)
781 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
783 (math-known-sin (car n
) (nth 1 n
) 120 0))))
784 (and (eq calc-angle-mode
'deg
)
785 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
787 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
788 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
789 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
790 (nth 1 (nth 1 math-simplify-expr
))))))
791 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
792 (math-div (nth 1 (nth 1 math-simplify-expr
))
794 (math-add 1 (math-sqr
795 (nth 1 (nth 1 math-simplify-expr
)))))))
796 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
797 (and m
(integerp (car m
))
798 (let ((n (car m
)) (a (nth 1 m
)))
800 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
801 (list 'calcFunc-cos a
))
802 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
803 (list 'calcFunc-sin a
))))))))
805 (math-defsimplify calcFunc-cos
806 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
807 (nth 1 (nth 1 math-simplify-expr
)))
808 (and (math-looks-negp (nth 1 math-simplify-expr
))
809 (list 'calcFunc-cos
(math-neg (nth 1 math-simplify-expr
))))
810 (and (eq calc-angle-mode
'rad
)
811 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
813 (math-known-sin (car n
) (nth 1 n
) 120 300))))
814 (and (eq calc-angle-mode
'deg
)
815 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
817 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
818 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
820 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))
821 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
825 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
826 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
827 (and m
(integerp (car m
))
828 (let ((n (car m
)) (a (nth 1 m
)))
830 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
831 (list 'calcFunc-cos a
))
832 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
833 (list 'calcFunc-sin a
))))))))
835 (math-defsimplify calcFunc-sec
836 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
837 (list 'calcFunc-sec
(math-neg (nth 1 math-simplify-expr
))))
838 (and (eq calc-angle-mode
'rad
)
839 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
841 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 300)))))
842 (and (eq calc-angle-mode
'deg
)
843 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
845 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300)))))
846 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
850 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
851 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
854 (nth 1 (nth 1 math-simplify-expr
))))
855 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
858 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
860 (math-defsimplify calcFunc-csc
861 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
862 (math-neg (list 'calcFunc-csc
(math-neg (nth 1 math-simplify-expr
)))))
863 (and (eq calc-angle-mode
'rad
)
864 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
866 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 0)))))
867 (and (eq calc-angle-mode
'deg
)
868 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
870 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0)))))
871 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
872 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
873 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
876 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
877 (nth 1 (nth 1 math-simplify-expr
)))))))
878 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
879 (math-div (list 'calcFunc-sqrt
880 (math-add 1 (math-sqr
881 (nth 1 (nth 1 math-simplify-expr
)))))
882 (nth 1 (nth 1 math-simplify-expr
))))))
884 (defun math-should-expand-trig (x &optional hyperbolic
)
885 (let ((m (math-is-multiple x
)))
886 (and math-living-dangerously
887 m
(or (and (integerp (car m
)) (> (car m
) 1))
888 (equal (car m
) '(frac 1 2)))
890 (memq (car-safe (nth 1 m
))
892 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
893 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
894 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
895 (eq hyperbolic
'exp
)))
898 (defun math-known-sin (plus n mul off
)
899 (setq n
(math-mul n mul
))
900 (and (math-num-integerp n
)
901 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
903 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
907 (if (math-zerop plus
)
908 (and (or calc-symbolic-mode
912 (10 .
(/ (calcFunc-sqrt
913 (- 2 (calcFunc-sqrt 3))) 2))
914 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
915 (15 .
(/ (calcFunc-sqrt
916 (- 2 (calcFunc-sqrt 2))) 2))
918 (24 .
(* (^
(/ 1 2) (/ 3 2))
920 (- 5 (calcFunc-sqrt 5)))))
921 (30 .
(/ (calcFunc-sqrt 2) 2))
922 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
923 (40 .
(/ (calcFunc-sqrt 3) 2))
924 (45 .
(/ (calcFunc-sqrt
925 (+ 2 (calcFunc-sqrt 2))) 2))
926 (48 .
(* (^
(/ 1 2) (/ 3 2))
928 (+ 5 (calcFunc-sqrt 5)))))
929 (50 .
(/ (calcFunc-sqrt
930 (+ 2 (calcFunc-sqrt 3))) 2))
932 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
933 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
936 (math-defsimplify calcFunc-tan
937 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
938 (nth 1 (nth 1 math-simplify-expr
)))
939 (and (math-looks-negp (nth 1 math-simplify-expr
))
940 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 math-simplify-expr
)))))
941 (and (eq calc-angle-mode
'rad
)
942 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
944 (math-known-tan (car n
) (nth 1 n
) 120))))
945 (and (eq calc-angle-mode
'deg
)
946 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
948 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
949 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
950 (math-div (nth 1 (nth 1 math-simplify-expr
))
952 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
953 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
954 (math-div (list 'calcFunc-sqrt
955 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
956 (nth 1 (nth 1 math-simplify-expr
))))
957 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
959 (if (equal (car m
) '(frac 1 2))
960 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
961 (list 'calcFunc-sin
(nth 1 m
)))
962 (math-div (list 'calcFunc-sin
(nth 1 math-simplify-expr
))
963 (list 'calcFunc-cos
(nth 1 math-simplify-expr
))))))))
965 (math-defsimplify calcFunc-cot
966 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
967 (math-neg (list 'calcFunc-cot
(math-neg (nth 1 math-simplify-expr
)))))
968 (and (eq calc-angle-mode
'rad
)
969 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
971 (math-div 1 (math-known-tan (car n
) (nth 1 n
) 120)))))
972 (and (eq calc-angle-mode
'deg
)
973 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
975 (math-div 1 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3))))))
976 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
977 (math-div (list 'calcFunc-sqrt
978 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
979 (nth 1 (nth 1 math-simplify-expr
))))
980 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
981 (math-div (nth 1 (nth 1 math-simplify-expr
))
983 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
984 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
985 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
987 (defun math-known-tan (plus n mul
)
988 (setq n
(math-mul n mul
))
989 (and (math-num-integerp n
)
990 (setq n
(math-mod (math-trunc n
) 120))
992 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
994 (if (math-zerop plus
)
995 (and (or calc-symbolic-mode
997 (cdr (assq n
'( (0 .
0)
998 (10 .
(- 2 (calcFunc-sqrt 3)))
1000 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1001 (15 .
(- (calcFunc-sqrt 2) 1))
1002 (20 .
(/ (calcFunc-sqrt 3) 3))
1003 (24 .
(calcFunc-sqrt
1004 (- 5 (* 2 (calcFunc-sqrt 5)))))
1006 (36 .
(calcFunc-sqrt
1007 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1008 (40 .
(calcFunc-sqrt 3))
1009 (45 .
(+ (calcFunc-sqrt 2) 1))
1010 (48 .
(calcFunc-sqrt
1011 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1012 (50 .
(+ 2 (calcFunc-sqrt 3)))
1013 (60 .
(var uinf var-uinf
))))))
1014 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
1015 ((eq n
60) (math-normalize (list '/ -
1
1016 (list 'calcFunc-tan plus
))))
1019 (math-defsimplify calcFunc-sinh
1020 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1021 (nth 1 (nth 1 math-simplify-expr
)))
1022 (and (math-looks-negp (nth 1 math-simplify-expr
))
1023 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 math-simplify-expr
)))))
1024 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1025 math-living-dangerously
1026 (list 'calcFunc-sqrt
1027 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1028 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1029 math-living-dangerously
1030 (math-div (nth 1 (nth 1 math-simplify-expr
))
1031 (list 'calcFunc-sqrt
1032 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1033 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1034 (and m
(integerp (car m
))
1035 (let ((n (car m
)) (a (nth 1 m
)))
1038 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1039 (list 'calcFunc-cosh a
))
1040 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1041 (list 'calcFunc-sinh a
)))))))))
1043 (math-defsimplify calcFunc-cosh
1044 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1045 (nth 1 (nth 1 math-simplify-expr
)))
1046 (and (math-looks-negp (nth 1 math-simplify-expr
))
1047 (list 'calcFunc-cosh
(math-neg (nth 1 math-simplify-expr
))))
1048 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1049 math-living-dangerously
1050 (list 'calcFunc-sqrt
1051 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1052 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1053 math-living-dangerously
1055 (list 'calcFunc-sqrt
1056 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1057 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1058 (and m
(integerp (car m
))
1059 (let ((n (car m
)) (a (nth 1 m
)))
1062 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1063 (list 'calcFunc-cosh a
))
1064 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1065 (list 'calcFunc-sinh a
)))))))))
1067 (math-defsimplify calcFunc-tanh
1068 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1069 (nth 1 (nth 1 math-simplify-expr
)))
1070 (and (math-looks-negp (nth 1 math-simplify-expr
))
1071 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 math-simplify-expr
)))))
1072 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1073 math-living-dangerously
1074 (math-div (nth 1 (nth 1 math-simplify-expr
))
1075 (list 'calcFunc-sqrt
1076 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1077 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1078 math-living-dangerously
1079 (math-div (list 'calcFunc-sqrt
1080 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1081 (nth 1 (nth 1 math-simplify-expr
))))
1082 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1084 (if (equal (car m
) '(frac 1 2))
1085 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
1086 (list 'calcFunc-sinh
(nth 1 m
)))
1087 (math-div (list 'calcFunc-sinh
(nth 1 math-simplify-expr
))
1088 (list 'calcFunc-cosh
(nth 1 math-simplify-expr
))))))))
1090 (math-defsimplify calcFunc-sech
1091 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1092 (list 'calcFunc-sech
(math-neg (nth 1 math-simplify-expr
))))
1093 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1094 math-living-dangerously
1097 (list 'calcFunc-sqrt
1098 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1099 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1100 math-living-dangerously
1101 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))) 1)
1102 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1103 math-living-dangerously
1104 (list 'calcFunc-sqrt
1105 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
1107 (math-defsimplify calcFunc-csch
1108 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1109 (math-neg (list 'calcFunc-csch
(math-neg (nth 1 math-simplify-expr
)))))
1110 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1111 math-living-dangerously
1112 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
1113 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1114 math-living-dangerously
1117 (list 'calcFunc-sqrt
1118 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1119 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1120 math-living-dangerously
1121 (math-div (list 'calcFunc-sqrt
1122 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
1123 (nth 1 (nth 1 math-simplify-expr
))))))
1125 (math-defsimplify calcFunc-coth
1126 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1127 (math-neg (list 'calcFunc-coth
(math-neg (nth 1 math-simplify-expr
)))))
1128 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1129 math-living-dangerously
1130 (math-div (list 'calcFunc-sqrt
1131 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1132 (nth 1 (nth 1 math-simplify-expr
))))
1133 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1134 math-living-dangerously
1135 (math-div (nth 1 (nth 1 math-simplify-expr
))
1136 (list 'calcFunc-sqrt
1137 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1138 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1139 math-living-dangerously
1140 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
1142 (math-defsimplify calcFunc-arcsin
1143 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1144 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 math-simplify-expr
)))))
1145 (and (eq (nth 1 math-simplify-expr
) 1)
1146 (math-quarter-circle t
))
1147 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1148 (math-div (math-half-circle t
) 6))
1149 (and math-living-dangerously
1150 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1151 (nth 1 (nth 1 math-simplify-expr
)))
1152 (and math-living-dangerously
1153 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1154 (math-sub (math-quarter-circle t
)
1155 (nth 1 (nth 1 math-simplify-expr
))))))
1157 (math-defsimplify calcFunc-arccos
1158 (or (and (eq (nth 1 math-simplify-expr
) 0)
1159 (math-quarter-circle t
))
1160 (and (eq (nth 1 math-simplify-expr
) -
1)
1161 (math-half-circle t
))
1162 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1163 (math-div (math-half-circle t
) 3))
1164 (and (equal (nth 1 math-simplify-expr
) '(frac -
1 2))
1165 (math-div (math-mul (math-half-circle t
) 2) 3))
1166 (and math-living-dangerously
1167 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1168 (nth 1 (nth 1 math-simplify-expr
)))
1169 (and math-living-dangerously
1170 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1171 (math-sub (math-quarter-circle t
)
1172 (nth 1 (nth 1 math-simplify-expr
))))))
1174 (math-defsimplify calcFunc-arctan
1175 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1176 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 math-simplify-expr
)))))
1177 (and (eq (nth 1 math-simplify-expr
) 1)
1178 (math-div (math-half-circle t
) 4))
1179 (and math-living-dangerously
1180 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tan
)
1181 (nth 1 (nth 1 math-simplify-expr
)))))
1183 (math-defsimplify calcFunc-arcsinh
1184 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1185 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 math-simplify-expr
)))))
1186 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sinh
)
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-arccosh
1192 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1193 (or math-living-dangerously
1194 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1195 (nth 1 (nth 1 math-simplify-expr
))))
1197 (math-defsimplify calcFunc-arctanh
1198 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1199 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 math-simplify-expr
)))))
1200 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tanh
)
1201 (or math-living-dangerously
1202 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1203 (nth 1 (nth 1 math-simplify-expr
)))))
1205 (math-defsimplify calcFunc-sqrt
1206 (math-simplify-sqrt))
1208 (defun math-simplify-sqrt ()
1209 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
1210 (math-div (list 'calcFunc-sqrt
1211 (math-mul (nth 1 (nth 1 math-simplify-expr
))
1212 (nth 2 (nth 1 math-simplify-expr
))))
1213 (nth 2 (nth 1 math-simplify-expr
))))
1214 (let ((fac (if (math-objectp (nth 1 math-simplify-expr
))
1215 (math-squared-factor (nth 1 math-simplify-expr
))
1216 (math-common-constant-factor (nth 1 math-simplify-expr
)))))
1217 (and fac
(not (eq fac
1))
1218 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
1220 (list 'calcFunc-sqrt
1221 (math-cancel-common-factor
1222 (nth 1 math-simplify-expr
) fac
))))))
1223 (and math-living-dangerously
1224 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1225 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 1)
1226 (eq (car-safe (nth 2 (nth 1 math-simplify-expr
))) '^
)
1227 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr
))) 2)
1228 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1231 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr
))))))
1232 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1235 (nth 1 (nth 1 (nth 2
1236 (nth 1 math-simplify-expr
))))))))
1237 (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1238 (math-equal-int (nth 2 (nth 1 math-simplify-expr
)) 1)
1239 (eq (car-safe (nth 1 (nth 1 math-simplify-expr
))) '^
)
1240 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr
))) 2)
1241 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr
))))
1243 (list 'calcFunc-sinh
1244 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr
)))))))
1245 (and (eq (car-safe (nth 1 math-simplify-expr
)) '+)
1246 (let ((a (nth 1 (nth 1 math-simplify-expr
)))
1247 (b (nth 2 (nth 1 math-simplify-expr
))))
1248 (and (or (and (math-equal-int a
1)
1249 (setq a b b
(nth 1 (nth 1 math-simplify-expr
))))
1250 (math-equal-int b
1))
1251 (eq (car-safe a
) '^
)
1252 (math-equal-int (nth 2 a
) 2)
1253 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
1254 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
1255 (and (eq (car-safe (nth 1 a
)) 'calcFunc-csch
)
1256 (list 'calcFunc-coth
(nth 1 (nth 1 a
))))
1257 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
1258 (list '/ 1 (list 'calcFunc-cos
1259 (nth 1 (nth 1 a
)))))
1260 (and (eq (car-safe (nth 1 a
)) 'calcFunc-cot
)
1261 (list '/ 1 (list 'calcFunc-sin
1262 (nth 1 (nth 1 a
)))))))))
1263 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1265 (nth 1 (nth 1 math-simplify-expr
))
1266 (math-div (nth 2 (nth 1 math-simplify-expr
)) 2)))
1267 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1268 (list '^
(nth 1 (nth 1 math-simplify-expr
)) (math-div 1 4)))
1269 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1270 (list (car (nth 1 math-simplify-expr
))
1271 (list 'calcFunc-sqrt
(nth 1 (nth 1 math-simplify-expr
)))
1272 (list 'calcFunc-sqrt
(nth 2 (nth 1 math-simplify-expr
)))))
1273 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
1274 (not (math-any-floats (nth 1 math-simplify-expr
)))
1275 (let ((f (calcFunc-factors (calcFunc-expand
1276 (nth 1 math-simplify-expr
)))))
1277 (and (math-vectorp f
)
1278 (or (> (length f
) 2)
1279 (> (nth 2 (nth 1 f
)) 1))
1280 (let ((out 1) (rest 1) (sums 1) fac pow
)
1281 (while (setq f
(cdr f
))
1282 (setq fac
(nth 1 (car f
))
1283 pow
(nth 2 (car f
)))
1285 (setq out
(math-mul out
(math-pow
1289 (if (memq (car-safe fac
) '(+ -
))
1290 (setq sums
(math-mul-thru sums fac
))
1291 (setq rest
(math-mul rest fac
)))))
1292 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1295 (list 'calcFunc-sqrt
1296 (math-mul sums rest
))))))))))))
1298 ;;; Rather than factoring x into primes, just check for the first ten primes.
1299 (defun math-squared-factor (x)
1300 (if (Math-integerp x
)
1301 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1305 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1307 fac
(math-mul fac
(car prsqr
)))
1308 (setq prsqr
(cdr prsqr
))))
1311 (math-defsimplify calcFunc-exp
1312 (math-simplify-exp (nth 1 math-simplify-expr
)))
1314 (defun math-simplify-exp (x)
1315 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1317 (and math-living-dangerously
1318 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1320 (list 'calcFunc-sqrt
1321 (math-add (math-sqr (nth 1 x
)) 1))))
1322 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1324 (list 'calcFunc-sqrt
1325 (math-sub (math-sqr (nth 1 x
)) 1))))
1326 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1327 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1328 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1329 (let ((m (math-should-expand-trig x
'exp
)))
1330 (and m
(integerp (car m
))
1331 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1332 (and calc-symbolic-mode
1333 (math-known-imagp x
)
1334 (let* ((ip (calcFunc-im x
))
1335 (n (math-linear-in ip
'(var pi var-pi
)))
1338 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1339 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1340 (list '+ c
(list '* s
'(var i var-i
))))))))
1342 (math-defsimplify calcFunc-ln
1343 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1344 (or math-living-dangerously
1345 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1346 (nth 1 (nth 1 math-simplify-expr
)))
1347 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1348 (equal (nth 1 (nth 1 math-simplify-expr
)) '(var e var-e
))
1349 (or math-living-dangerously
1350 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1351 (nth 2 (nth 1 math-simplify-expr
)))
1352 (and calc-symbolic-mode
1353 (math-known-negp (nth 1 math-simplify-expr
))
1354 (math-add (list 'calcFunc-ln
(math-neg (nth 1 math-simplify-expr
)))
1355 '(* (var pi var-pi
) (var i var-i
))))
1356 (and calc-symbolic-mode
1357 (math-known-imagp (nth 1 math-simplify-expr
))
1358 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr
)))
1359 (ips (math-possible-signs ip
)))
1360 (or (and (memq ips
'(4 6))
1361 (math-add (list 'calcFunc-ln ip
)
1362 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1363 (and (memq ips
'(1 3))
1364 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1365 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1368 (math-simplify-pow))
1370 (defun math-simplify-pow ()
1371 (or (and math-living-dangerously
1372 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1374 (nth 1 (nth 1 math-simplify-expr
))
1375 (math-mul (nth 2 math-simplify-expr
)
1376 (nth 2 (nth 1 math-simplify-expr
)))))
1377 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1379 (nth 1 (nth 1 math-simplify-expr
))
1380 (math-div (nth 2 math-simplify-expr
) 2)))
1381 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1382 (list (car (nth 1 math-simplify-expr
))
1383 (list '^
(nth 1 (nth 1 math-simplify-expr
))
1384 (nth 2 math-simplify-expr
))
1385 (list '^
(nth 2 (nth 1 math-simplify-expr
))
1386 (nth 2 math-simplify-expr
))))))
1387 (and (math-equal-int (nth 1 math-simplify-expr
) 10)
1388 (eq (car-safe (nth 2 math-simplify-expr
)) 'calcFunc-log10
)
1389 (nth 1 (nth 2 math-simplify-expr
)))
1390 (and (equal (nth 1 math-simplify-expr
) '(var e var-e
))
1391 (math-simplify-exp (nth 2 math-simplify-expr
)))
1392 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1393 (not math-integrating
)
1394 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 math-simplify-expr
))
1395 (nth 2 math-simplify-expr
))))
1396 (and (equal (nth 1 math-simplify-expr
) '(var i var-i
))
1398 (math-num-integerp (nth 2 math-simplify-expr
))
1399 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr
)) 4)))
1401 ((eq x
1) (nth 1 math-simplify-expr
))
1403 ((eq x
3) (math-neg (nth 1 math-simplify-expr
))))))
1404 (and math-integrating
1405 (integerp (nth 2 math-simplify-expr
))
1406 (>= (nth 2 math-simplify-expr
) 2)
1407 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1408 (math-mul (math-pow (nth 1 math-simplify-expr
)
1409 (- (nth 2 math-simplify-expr
) 2))
1413 (nth 1 (nth 1 math-simplify-expr
)))))))
1414 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1415 (math-mul (math-pow (nth 1 math-simplify-expr
)
1416 (- (nth 2 math-simplify-expr
) 2))
1419 (list 'calcFunc-sinh
1420 (nth 1 (nth 1 math-simplify-expr
)))))))))
1421 (and (eq (car-safe (nth 2 math-simplify-expr
)) 'frac
)
1422 (Math-ratp (nth 1 math-simplify-expr
))
1423 (Math-posp (nth 1 math-simplify-expr
))
1424 (if (equal (nth 2 math-simplify-expr
) '(frac 1 2))
1425 (list 'calcFunc-sqrt
(nth 1 math-simplify-expr
))
1426 (let ((flr (math-floor (nth 2 math-simplify-expr
))))
1427 (and (not (Math-zerop flr
))
1428 (list '* (list '^
(nth 1 math-simplify-expr
) flr
)
1429 (list '^
(nth 1 math-simplify-expr
)
1430 (math-sub (nth 2 math-simplify-expr
) flr
)))))))
1431 (and (eq (math-quarter-integer (nth 2 math-simplify-expr
)) 2)
1432 (let ((temp (math-simplify-sqrt)))
1434 (list '^ temp
(math-mul (nth 2 math-simplify-expr
) 2)))))))
1436 (math-defsimplify calcFunc-log10
1437 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1438 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 10)
1439 (or math-living-dangerously
1440 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1441 (nth 2 (nth 1 math-simplify-expr
))))
1444 (math-defsimplify calcFunc-erf
1445 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1446 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 math-simplify-expr
)))))
1447 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1448 (list 'calcFunc-conj
1449 (list 'calcFunc-erf
(nth 1 (nth 1 math-simplify-expr
)))))))
1451 (math-defsimplify calcFunc-erfc
1452 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1453 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 math-simplify-expr
)))))
1454 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1455 (list 'calcFunc-conj
1456 (list 'calcFunc-erfc
(nth 1 (nth 1 math-simplify-expr
)))))))
1459 (defun math-linear-in (expr term
&optional always
)
1460 (if (math-expr-contains expr term
)
1461 (let* ((calc-prefer-frac t
)
1462 (p (math-is-polynomial expr term
1)))
1465 (and always
(list expr
0))))
1467 (defun math-multiple-of (expr term
)
1468 (let ((p (math-linear-in expr term
)))
1470 (math-zerop (car p
))
1473 ; not perfect, but it'll do
1474 (defun math-integer-plus (expr)
1475 (cond ((Math-integerp expr
)
1477 ((and (memq (car expr
) '(+ -
))
1478 (Math-integerp (nth 1 expr
)))
1479 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1481 ((and (memq (car expr
) '(+ -
))
1482 (Math-integerp (nth 2 expr
)))
1484 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1487 (defun math-is-linear (expr &optional always
)
1490 (if (eq (car-safe expr
) '+)
1491 (if (Math-objectp (nth 1 expr
))
1492 (setq offset
(nth 1 expr
)
1494 (if (Math-objectp (nth 2 expr
))
1495 (setq offset
(nth 2 expr
)
1496 expr
(nth 1 expr
))))
1497 (if (eq (car-safe expr
) '-
)
1498 (if (Math-objectp (nth 1 expr
))
1499 (setq offset
(nth 1 expr
)
1500 expr
(math-neg (nth 2 expr
)))
1501 (if (Math-objectp (nth 2 expr
))
1502 (setq offset
(math-neg (nth 2 expr
))
1503 expr
(nth 1 expr
))))))
1504 (setq coef
(math-is-multiple expr always
))
1506 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1510 (defun math-is-multiple (expr &optional always
)
1511 (or (if (eq (car-safe expr
) '*)
1512 (if (Math-objectp (nth 1 expr
))
1513 (list (nth 1 expr
) (nth 2 expr
)))
1514 (if (eq (car-safe expr
) '/)
1515 (if (and (Math-objectp (nth 1 expr
))
1516 (not (math-equal-int (nth 1 expr
) 1)))
1517 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1518 (if (Math-objectp (nth 2 expr
))
1519 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1520 (let ((res (math-is-multiple (nth 1 expr
))))
1523 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1524 (setq res
(math-is-multiple (nth 2 expr
)))
1526 (list (math-div 1 (car res
))
1527 (math-div (nth 1 expr
)
1528 (nth 2 (nth 2 expr
)))))))))
1529 (if (eq (car-safe expr
) 'neg
)
1530 (list -
1 (nth 1 expr
)))))
1531 (if (Math-objvecp expr
)
1537 (defun calcFunc-lin (expr &optional var
)
1539 (let ((res (math-linear-in expr var t
)))
1540 (or res
(math-reject-arg expr
"Linear term expected"))
1541 (list 'vec
(car res
) (nth 1 res
) var
))
1542 (let ((res (math-is-linear expr t
)))
1543 (or res
(math-reject-arg expr
"Linear term expected"))
1546 (defun calcFunc-linnt (expr &optional var
)
1548 (let ((res (math-linear-in expr var
)))
1549 (or res
(math-reject-arg expr
"Linear term expected"))
1550 (list 'vec
(car res
) (nth 1 res
) var
))
1551 (let ((res (math-is-linear expr
)))
1552 (or res
(math-reject-arg expr
"Linear term expected"))
1555 (defun calcFunc-islin (expr &optional var
)
1556 (if (and (Math-objvecp expr
) (not var
))
1558 (calcFunc-lin expr var
)
1561 (defun calcFunc-islinnt (expr &optional var
)
1562 (if (Math-objvecp expr
)
1564 (calcFunc-linnt expr var
)
1570 ;;; Simple operations on expressions.
1572 ;;; Return number of occurrences of thing in expr, or nil if none.
1573 (defun math-expr-contains-count (expr thing
)
1574 (cond ((equal expr thing
) 1)
1575 ((Math-primp expr
) nil
)
1578 (while (setq expr
(cdr expr
))
1579 (setq num
(+ num
(or (math-expr-contains-count
1580 (car expr
) thing
) 0))))
1584 (defun math-expr-contains (expr thing
)
1585 (cond ((equal expr thing
) 1)
1586 ((Math-primp expr
) nil
)
1588 (while (and (setq expr
(cdr expr
))
1589 (not (math-expr-contains (car expr
) thing
))))
1592 ;;; Return non-nil if any variable of thing occurs in expr.
1593 (defun math-expr-depends (expr thing
)
1594 (if (Math-primp thing
)
1595 (and (eq (car-safe thing
) 'var
)
1596 (math-expr-contains expr thing
))
1597 (while (and (setq thing
(cdr thing
))
1598 (not (math-expr-depends expr
(car thing
)))))
1601 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1603 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1604 ;; for math-expr-subst, but used by math-expr-subst-rec.
1605 (defvar math-expr-subst-old
)
1606 (defvar math-expr-subst-new
)
1608 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new
)
1609 (math-expr-subst-rec expr
))
1611 (defalias 'calcFunc-subst
'math-expr-subst
)
1613 (defun math-expr-subst-rec (expr)
1614 (cond ((equal expr math-expr-subst-old
) math-expr-subst-new
)
1615 ((Math-primp expr
) expr
)
1616 ((memq (car expr
) '(calcFunc-deriv
1618 (if (= (length expr
) 2)
1619 (if (equal (nth 1 expr
) math-expr-subst-old
)
1620 (append expr
(list math-expr-subst-new
))
1622 (list (car expr
) (nth 1 expr
)
1623 (math-expr-subst-rec (nth 2 expr
)))))
1626 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1628 ;;; Various measures of the size of an expression.
1629 (defun math-expr-weight (expr)
1630 (if (Math-primp expr
)
1633 (while (setq expr
(cdr expr
))
1634 (setq w
(+ w
(math-expr-weight (car expr
)))))
1637 (defun math-expr-height (expr)
1638 (if (Math-primp expr
)
1641 (while (setq expr
(cdr expr
))
1642 (setq h
(max h
(math-expr-height (car expr
)))))
1648 ;;; Polynomial operations (to support the integrator and solve-for).
1650 (defun calcFunc-collect (expr base
)
1651 (let ((p (math-is-polynomial expr base
50 t
)))
1653 (math-build-polynomial-expr (mapcar 'math-normalize p
) base
)
1656 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1657 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1658 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1660 ;; These variables are local to math-is-polynomial, but are used by
1661 ;; math-is-poly-rec.
1662 (defvar math-is-poly-degree
)
1663 (defvar math-is-poly-loose
)
1666 (defun math-is-polynomial (expr math-var
&optional math-is-poly-degree math-is-poly-loose
)
1667 (let* ((math-poly-base-variable (if math-is-poly-loose
1668 (if (eq math-is-poly-loose
'gen
) math-var
'(var XXX XXX
))
1669 math-poly-base-variable
))
1670 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1671 (and (or (null math-is-poly-degree
)
1672 (<= (length poly
) (1+ math-is-poly-degree
)))
1675 (defun math-is-poly-rec (expr negpow
)
1677 (or (cond ((or (equal expr math-var
)
1678 (eq (car-safe expr
) '^
))
1681 (or (equal expr math-var
)
1682 (setq pow
(nth 2 expr
)
1684 (or (eq math-poly-mult-powers
1)
1685 (setq pow
(let ((m (math-is-multiple pow
1)))
1686 (and (eq (car-safe (car m
)) 'cplx
)
1687 (Math-zerop (nth 1 (car m
)))
1688 (setq m
(list (nth 2 (car m
))
1691 (and (if math-poly-mult-powers
1692 (equal math-poly-mult-powers
1694 (setq math-poly-mult-powers
(nth 1 m
)))
1695 (or (equal expr math-var
)
1696 (eq math-poly-mult-powers
1))
1700 (setq pow
(math-to-simple-fraction pow
))
1701 (and (eq (car-safe pow
) 'frac
)
1702 math-poly-frac-powers
1703 (equal expr math-var
)
1704 (setq math-poly-frac-powers
1705 (calcFunc-lcm math-poly-frac-powers
1707 (or (memq math-poly-frac-powers
'(1 nil
))
1708 (setq pow
(math-mul pow math-poly-frac-powers
)))
1711 (equal expr math-var
))
1714 (let ((p1 (if (equal expr math-var
)
1716 (math-is-poly-rec expr nil
)))
1720 (or (null math-is-poly-degree
)
1721 (<= (* (1- (length p1
)) n
) math-is-poly-degree
))
1724 (setq accum
(math-poly-mul accum p1
)
1728 (math-is-poly-rec expr nil
)
1729 (setq math-poly-neg-powers
1730 (cons (math-pow expr
(- pow
))
1731 math-poly-neg-powers
))
1732 (list (list '^ expr pow
))))))))
1733 ((Math-objectp expr
)
1735 ((memq (car expr
) '(+ -
))
1736 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1738 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1740 (math-poly-mix p1
1 p2
1741 (if (eq (car expr
) '+) 1 -
1)))))))
1742 ((eq (car expr
) 'neg
)
1743 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1745 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1747 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1749 (or (null math-is-poly-degree
)
1750 (<= (- (+ (length p1
) (length p2
)) 2)
1751 math-is-poly-degree
))
1752 (math-poly-mul p1 p2
))))))
1754 (and (or (not (math-poly-depends (nth 2 expr
) math-var
))
1756 (math-is-poly-rec (nth 2 expr
) nil
)
1757 (setq math-poly-neg-powers
1758 (cons (nth 2 expr
) math-poly-neg-powers
))))
1759 (not (Math-zerop (nth 2 expr
)))
1760 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1761 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1763 ((and (eq (car expr
) 'calcFunc-exp
)
1764 (equal math-var
'(var e var-e
)))
1765 (math-is-poly-rec (list '^ math-var
(nth 1 expr
)) negpow
))
1766 ((and (eq (car expr
) 'calcFunc-sqrt
)
1767 math-poly-frac-powers
)
1768 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1770 (and (or (not (math-poly-depends expr math-var
))
1772 (not (eq (car expr
) 'vec
))
1775 ;;; Check if expr is a polynomial in var; if so, return its degree.
1776 (defun math-polynomial-p (expr var
)
1777 (cond ((equal expr var
) 1)
1778 ((Math-primp expr
) 0)
1779 ((memq (car expr
) '(+ -
))
1780 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1782 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1785 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1787 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1789 ((eq (car expr
) 'neg
)
1790 (math-polynomial-p (nth 1 expr
) var
))
1791 ((and (eq (car expr
) '/)
1792 (not (math-poly-depends (nth 2 expr
) var
)))
1793 (math-polynomial-p (nth 1 expr
) var
))
1794 ((and (eq (car expr
) '^
)
1795 (natnump (nth 2 expr
)))
1796 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1797 (and p1
(* p1
(nth 2 expr
)))))
1798 ((math-poly-depends expr var
) nil
)
1801 (defun math-poly-depends (expr var
)
1802 (if math-poly-base-variable
1803 (math-expr-contains expr math-poly-base-variable
)
1804 (math-expr-depends expr var
)))
1806 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1807 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1808 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1809 (defvar math-poly-base-const-ok
)
1810 (defvar math-poly-base-pred
)
1812 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1813 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1814 ;; by math-polynomial-base.
1816 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred
)
1817 (or math-poly-base-pred
1818 (setq math-poly-base-pred
(function (lambda (base) (math-polynomial-p
1819 math-poly-base-top-expr base
)))))
1820 (or (let ((math-poly-base-const-ok nil
))
1821 (math-polynomial-base-rec math-poly-base-top-expr
))
1822 (let ((math-poly-base-const-ok t
))
1823 (math-polynomial-base-rec math-poly-base-top-expr
))))
1825 (defun math-polynomial-base-rec (mpb-expr)
1826 (and (not (Math-objvecp mpb-expr
))
1827 (or (and (memq (car mpb-expr
) '(+ -
*))
1828 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1829 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1830 (and (memq (car mpb-expr
) '(/ neg
))
1831 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1832 (and (eq (car mpb-expr
) '^
)
1833 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1834 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1835 (math-polynomial-base-rec '(var e var-e
)))
1836 (and (or math-poly-base-const-ok
(math-expr-contains-vars mpb-expr
))
1837 (funcall math-poly-base-pred mpb-expr
)
1840 ;;; Return non-nil if expr refers to any variables.
1841 (defun math-expr-contains-vars (expr)
1842 (or (eq (car-safe expr
) 'var
)
1843 (and (not (Math-primp expr
))
1845 (while (and (setq expr
(cdr expr
))
1846 (not (math-expr-contains-vars (car expr
)))))
1849 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1850 ;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
1851 (defun math-poly-simplify (p)
1853 (if (Math-zerop (nth (1- (length p
)) p
))
1854 (let ((pp (copy-sequence p
)))
1855 (while (and (cdr pp
)
1856 (Math-zerop (nth (1- (length pp
)) pp
)))
1857 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1861 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1862 ;;; coefficients ac, bc. Result may be unsimplified.
1863 (defun math-poly-mix (a ac b bc
)
1865 (cons (math-add (math-mul (or (car a
) 0) ac
)
1866 (math-mul (or (car b
) 0) bc
))
1867 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1869 (defun math-poly-zerop (a)
1871 (and (null (cdr a
)) (Math-zerop (car a
)))))
1873 ;;; Multiply two polynomials in list form.
1874 (defun math-poly-mul (a b
)
1876 (math-poly-mix b
(car a
)
1877 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1879 ;;; Build an expression from a polynomial list.
1880 (defun math-build-polynomial-expr (p var
)
1882 (if (Math-numberp var
)
1883 (math-with-extra-prec 1
1884 (let* ((rp (reverse p
))
1886 (while (setq rp
(cdr rp
))
1887 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1889 (let* ((rp (reverse p
))
1890 (n (1- (length rp
)))
1891 (accum (math-mul (car rp
) (math-pow var n
)))
1893 (while (setq rp
(cdr rp
))
1895 (or (math-zerop (car rp
))
1896 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1898 (math-mul (if (math-looks-negp (car rp
))
1901 (math-pow var n
))))))
1906 (defun math-to-simple-fraction (f)
1907 (or (and (eq (car-safe f
) 'float
)
1908 (or (and (>= (nth 2 f
) 0)
1909 (math-scale-int (nth 1 f
) (nth 2 f
)))
1910 (and (integerp (nth 1 f
))
1913 (math-make-frac (nth 1 f
)
1914 (math-scale-int 1 (- (nth 2 f
)))))))
1919 ;;; calc-alg.el ends here
