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 (defun calc-input-angle-units (input)
359 (cond ((math-expr-contains input
'(var deg var-deg
)) 'deg
)
360 ((math-expr-contains input
'(var rad var-rad
)) 'rad
)
361 ((math-expr-contains input
'(var hms var-hms
)) 'hms
)
364 ;; math-normalize-error is declared in calc.el.
365 (defvar math-normalize-error
)
366 (defun math-simplify (top-expr)
367 (let ((math-simplifying t
)
368 (calc-angle-mode (if (calc-input-angle-units top-expr
)
371 (math-top-only (consp calc-simplify-mode
))
372 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
373 '((var AlgSimpRules var-AlgSimpRules
)))
374 (and math-living-dangerously
375 (calc-has-rules 'var-ExtSimpRules
)
376 '((var ExtSimpRules var-ExtSimpRules
)))
377 (and math-simplifying-units
378 (calc-has-rules 'var-UnitSimpRules
)
379 '((var UnitSimpRules var-UnitSimpRules
)))
380 (and math-integrating
381 (calc-has-rules 'var-IntegSimpRules
)
382 '((var IntegSimpRules var-IntegSimpRules
)))))
385 (let ((r simp-rules
))
386 (setq res
(math-simplify-step (math-normalize top-expr
))
387 calc-simplify-mode
'(nil)
388 top-expr
(math-normalize res
))
390 (setq top-expr
(math-rewrite top-expr
(car r
)
391 '(neg (var inf var-inf
)))
393 (calc-with-default-simplification
394 (while (let ((r simp-rules
))
395 (setq res
(math-normalize top-expr
))
396 (if (not math-normalize-error
)
399 (setq res
(math-rewrite res
(car r
))
401 (not (equal top-expr
(setq res
(math-simplify-step res
)))))))
402 (setq top-expr res
)))))
405 (defalias 'calcFunc-simplify
'math-simplify
)
407 ;;; The following has a "bug" in that if any recursive simplifications
408 ;;; occur only the first handler will be tried; this doesn't really
409 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
410 (defun math-simplify-step (a)
413 (let ((aa (if (or math-top-only
414 (memq (car a
) '(calcFunc-quote calcFunc-condition
417 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
418 (and (symbolp (car aa
))
419 (let ((handler (get (car aa
) 'math-simplify
)))
422 (equal (setq aa
(or (funcall (car handler
) aa
)
425 (setq handler
(cdr handler
))))))
429 (defmacro math-defsimplify
(funcs &rest code
)
431 (mapcar #'(lambda (func)
432 `(put ',func
'math-simplify
434 (get ',func
'math-simplify
)
436 #'(lambda (math-simplify-expr) ,@code
)))))
437 (if (symbolp funcs
) (list funcs
) funcs
))))
438 (put 'math-defsimplify
'lisp-indent-hook
1)
440 ;; The function created by math-defsimplify uses the variable
441 ;; math-simplify-expr, and so is used by functions in math-defsimplify
442 (defvar math-simplify-expr
)
444 (math-defsimplify (+ -
)
445 (math-simplify-plus))
447 (defun math-simplify-plus ()
448 (cond ((and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
449 (Math-numberp (nth 2 (nth 1 math-simplify-expr
)))
450 (not (Math-numberp (nth 2 math-simplify-expr
))))
451 (let ((x (nth 2 math-simplify-expr
))
452 (op (car math-simplify-expr
)))
453 (setcar (cdr (cdr math-simplify-expr
)) (nth 2 (nth 1 math-simplify-expr
)))
454 (setcar math-simplify-expr
(car (nth 1 math-simplify-expr
)))
455 (setcar (cdr (cdr (nth 1 math-simplify-expr
))) x
)
456 (setcar (nth 1 math-simplify-expr
) op
)))
457 ((and (eq (car math-simplify-expr
) '+)
458 (Math-numberp (nth 1 math-simplify-expr
))
459 (not (Math-numberp (nth 2 math-simplify-expr
))))
460 (let ((x (nth 2 math-simplify-expr
)))
461 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
462 (setcar (cdr math-simplify-expr
) x
))))
463 (let ((aa math-simplify-expr
)
465 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
466 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 math-simplify-expr
)
468 (eq (car math-simplify-expr
) '-
) t
))
470 (setcar (cdr (cdr math-simplify-expr
)) temp
)
471 (setcar math-simplify-expr
'+)
472 (setcar (cdr (cdr aaa
)) 0)))
473 (setq aa
(nth 1 aa
)))
474 (if (setq temp
(math-combine-sum aaa
(nth 2 math-simplify-expr
)
475 nil
(eq (car math-simplify-expr
) '-
) t
))
477 (setcar (cdr (cdr math-simplify-expr
)) temp
)
478 (setcar math-simplify-expr
'+)
479 (setcar (cdr aa
) 0)))
483 (math-simplify-times))
485 (defun math-simplify-times ()
486 (if (eq (car-safe (nth 2 math-simplify-expr
)) '*)
487 (and (math-beforep (nth 1 (nth 2 math-simplify-expr
)) (nth 1 math-simplify-expr
))
488 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
489 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr
)) t
))
490 (let ((x (nth 1 math-simplify-expr
)))
491 (setcar (cdr math-simplify-expr
) (nth 1 (nth 2 math-simplify-expr
)))
492 (setcar (cdr (nth 2 math-simplify-expr
)) x
)))
493 (and (math-beforep (nth 2 math-simplify-expr
) (nth 1 math-simplify-expr
))
494 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
495 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
496 (let ((x (nth 2 math-simplify-expr
)))
497 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
498 (setcar (cdr math-simplify-expr
) x
))))
499 (let ((aa math-simplify-expr
)
501 (safe t
) (scalar (math-known-scalarp (nth 1 math-simplify-expr
))))
502 (if (and (Math-ratp (nth 1 math-simplify-expr
))
503 (setq temp
(math-common-constant-factor (nth 2 math-simplify-expr
))))
505 (setcar (cdr (cdr math-simplify-expr
))
506 (math-cancel-common-factor (nth 2 math-simplify-expr
) temp
))
507 (setcar (cdr math-simplify-expr
) (math-mul (nth 1 math-simplify-expr
) temp
))))
508 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
510 (if (setq temp
(math-combine-prod (nth 1 math-simplify-expr
)
511 (nth 1 aaa
) nil nil t
))
513 (setcar (cdr math-simplify-expr
) temp
)
514 (setcar (cdr aaa
) 1)))
515 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
517 (if (and (setq temp
(math-combine-prod aaa
(nth 1 math-simplify-expr
) nil nil t
))
520 (setcar (cdr math-simplify-expr
) temp
)
521 (setcar (cdr (cdr aa
)) 1)))
522 (if (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
523 (memq (nth 1 (nth 1 math-simplify-expr
)) '(1 -
1)))
524 (math-div (math-mul (nth 2 math-simplify-expr
)
525 (nth 1 (nth 1 math-simplify-expr
)))
526 (nth 2 (nth 1 math-simplify-expr
)))
527 math-simplify-expr
)))
530 (math-simplify-divide))
532 (defun math-simplify-divide ()
533 (let ((np (cdr math-simplify-expr
))
535 (nn (and (or (eq (car math-simplify-expr
) '/)
536 (not (Math-realp (nth 2 math-simplify-expr
))))
537 (math-common-constant-factor (nth 2 math-simplify-expr
))))
541 (setq n
(and (or (eq (car math-simplify-expr
) '/)
542 (not (Math-realp (nth 1 math-simplify-expr
))))
543 (math-common-constant-factor (nth 1 math-simplify-expr
))))
544 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
545 (unless (and (eq (car-safe math-simplify-expr
) 'calcFunc-eq
)
546 (eq (car-safe (nth 1 math-simplify-expr
)) 'var
)
547 (not (math-expr-contains (nth 2 math-simplify-expr
)
548 (nth 1 math-simplify-expr
))))
549 (setcar (cdr math-simplify-expr
)
550 (math-mul (nth 2 nn
) (nth 1 math-simplify-expr
)))
551 (setcar (cdr (cdr math-simplify-expr
))
552 (math-cancel-common-factor (nth 2 math-simplify-expr
) nn
))
553 (if (and (math-negp nn
)
554 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
)))
555 (setcar math-simplify-expr
(nth 1 op
))))
556 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
558 (setcar (cdr math-simplify-expr
)
559 (math-cancel-common-factor (nth 1 math-simplify-expr
) n
))
560 (setcar (cdr (cdr math-simplify-expr
))
561 (math-cancel-common-factor (nth 2 math-simplify-expr
) n
))
562 (if (and (math-negp n
)
563 (setq op
(assq (car math-simplify-expr
)
564 calc-tweak-eqn-table
)))
565 (setcar math-simplify-expr
(nth 1 op
))))))))
566 (if (and (eq (car-safe (car np
)) '/)
567 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
569 (setq np
(cdr (nth 1 math-simplify-expr
)))
570 (while (eq (car-safe (setq n
(car np
))) '*)
571 (and (math-known-scalarp (nth 2 n
) t
)
572 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nil t
))
573 (setq np
(cdr (cdr n
))))
574 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nil t
)
576 np
(cdr (cdr (nth 1 math-simplify-expr
))))))
577 (while (eq (car-safe (setq n
(car np
))) '*)
578 (and (math-known-scalarp (nth 2 n
) t
)
579 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nover t
))
580 (setq np
(cdr (cdr n
))))
581 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nover t
)
584 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
585 ;; are local variables for math-simplify-divisor, but are used by
586 ;; math-simplify-one-divisor.
587 (defvar math-simplify-divisor-nover
)
588 (defvar math-simplify-divisor-dover
)
590 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
591 math-simplify-divisor-dover
)
592 (cond ((eq (car-safe (car dp
)) '/)
593 (math-simplify-divisor np
(cdr (car dp
))
594 math-simplify-divisor-nover
595 math-simplify-divisor-dover
)
596 (and (math-known-scalarp (nth 1 (car dp
)) t
)
597 (math-simplify-divisor np
(cdr (cdr (car dp
)))
598 math-simplify-divisor-nover
599 (not math-simplify-divisor-dover
))))
600 ((or (or (eq (car math-simplify-expr
) '/)
601 (let ((signs (math-possible-signs (car np
))))
602 (or (memq signs
'(1 4))
603 (and (memq (car math-simplify-expr
) '(calcFunc-eq calcFunc-neq
))
605 math-living-dangerously
)))
606 (math-numberp (car np
)))
609 (scalar (math-known-scalarp (car np
))))
610 (while (and (eq (car-safe (setq d
(car dp
))) '*)
612 (math-simplify-one-divisor np
(cdr d
))
613 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
616 (math-simplify-one-divisor np dp
))))))
618 (defun math-simplify-one-divisor (np dp
)
619 (let ((temp (math-combine-prod (car np
) (car dp
) math-simplify-divisor-nover
620 math-simplify-divisor-dover t
))
624 (and (not (memq (car math-simplify-expr
) '(/ calcFunc-eq calcFunc-neq
)))
625 (math-known-negp (car dp
))
626 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
))
627 (setcar math-simplify-expr
(nth 1 op
)))
628 (setcar np
(if math-simplify-divisor-nover
(math-div 1 temp
) temp
))
630 (and math-simplify-divisor-dover
(not math-simplify-divisor-nover
)
631 (eq (car math-simplify-expr
) '/)
632 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
633 (Math-integerp (nth 1 (car dp
)))
635 (setcar np
(math-mul (car np
)
636 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
637 (setcar dp
(nth 1 (car dp
))))))))
639 (defun math-common-constant-factor (expr)
640 (if (Math-realp expr
)
642 (and (not (memq expr
'(0 1 -
1)))
644 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
645 (math-common-constant-factor expr
)))
646 (if (memq (car expr
) '(+ - cplx sdev
))
647 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
648 (f2 (math-common-constant-factor (nth 2 expr
))))
650 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
652 (if (memq (car expr
) '(* polar
))
653 (math-common-constant-factor (nth 1 expr
))
654 (if (eq (car expr
) '/)
655 (or (math-common-constant-factor (nth 1 expr
))
656 (and (Math-integerp (nth 2 expr
))
657 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
659 (defun math-cancel-common-factor (expr val
)
660 (if (memq (car-safe expr
) '(+ - cplx sdev
))
662 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
663 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
665 (if (eq (car-safe expr
) '*)
666 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
667 (math-div expr val
))))
669 (defun math-frac-gcd (a b
)
674 (if (and (Math-integerp a
)
677 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
678 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
679 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
680 (math-gcd (nth 2 a
) (nth 2 b
)))))))
685 (defun math-simplify-mod ()
686 (and (Math-realp (nth 2 math-simplify-expr
))
687 (Math-posp (nth 2 math-simplify-expr
))
688 (let ((lin (math-is-linear (nth 1 math-simplify-expr
)))
691 (or (math-negp (car lin
))
692 (not (Math-lessp (car lin
) (nth 2 math-simplify-expr
))))
695 (math-mul (nth 1 lin
) (nth 2 lin
))
696 (math-mod (car lin
) (nth 2 math-simplify-expr
)))
697 (nth 2 math-simplify-expr
)))
699 (not (math-equal-int (nth 1 lin
) 1))
700 (math-num-integerp (nth 1 lin
))
701 (math-num-integerp (nth 2 math-simplify-expr
))
702 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 math-simplify-expr
)))
703 (not (math-equal-int t1
1))
708 (math-mul (math-div (nth 1 lin
) t1
)
710 (let ((calc-prefer-frac t
))
711 (math-div (car lin
) t1
)))
712 (math-div (nth 2 math-simplify-expr
) t1
))))
713 (and (math-equal-int (nth 2 math-simplify-expr
) 1)
714 (math-known-integerp (if lin
715 (math-mul (nth 1 lin
) (nth 2 lin
))
716 (nth 1 math-simplify-expr
)))
717 (if lin
(math-mod (car lin
) 1) 0))))))
719 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
720 calcFunc-gt calcFunc-leq calcFunc-geq
)
721 (if (= (length math-simplify-expr
) 3)
722 (math-simplify-ineq)))
724 (defun math-simplify-ineq ()
725 (let ((np (cdr math-simplify-expr
))
727 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
728 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr math-simplify-expr
))
731 (math-simplify-add-term np
(cdr (cdr math-simplify-expr
)) nil
732 (eq np
(cdr math-simplify-expr
)))
733 (math-simplify-divide)
734 (let ((signs (math-possible-signs (cons '-
(cdr math-simplify-expr
)))))
735 (or (cond ((eq (car math-simplify-expr
) 'calcFunc-eq
)
736 (or (and (eq signs
2) 1)
737 (and (memq signs
'(1 4 5)) 0)))
738 ((eq (car math-simplify-expr
) 'calcFunc-neq
)
739 (or (and (eq signs
2) 0)
740 (and (memq signs
'(1 4 5)) 1)))
741 ((eq (car math-simplify-expr
) 'calcFunc-lt
)
742 (or (and (eq signs
1) 1)
743 (and (memq signs
'(2 4 6)) 0)))
744 ((eq (car math-simplify-expr
) 'calcFunc-gt
)
745 (or (and (eq signs
4) 1)
746 (and (memq signs
'(1 2 3)) 0)))
747 ((eq (car math-simplify-expr
) 'calcFunc-leq
)
748 (or (and (eq signs
4) 0)
749 (and (memq signs
'(1 2 3)) 1)))
750 ((eq (car math-simplify-expr
) 'calcFunc-geq
)
751 (or (and (eq signs
1) 0)
752 (and (memq signs
'(2 4 6)) 1))))
753 math-simplify-expr
))))
755 (defun math-simplify-add-term (np dp minus lplain
)
756 (or (math-vectorp (car np
))
759 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
761 (if (setq temp
(math-combine-sum n
(nth 2 d
)
762 minus
(eq (car d
) '+) t
))
763 (if (or lplain
(eq (math-looks-negp temp
) minus
))
765 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
766 (setcar (cdr (cdr d
)) 0))
769 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
773 (if (setq temp
(math-combine-sum n d minus t t
))
776 (eq (math-looks-negp temp
) minus
)))
778 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
782 (setcar dp
(setq n
(math-neg temp
)))))))))
784 (math-defsimplify calcFunc-sin
785 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
786 (nth 1 (nth 1 math-simplify-expr
)))
787 (and (math-looks-negp (nth 1 math-simplify-expr
))
788 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 math-simplify-expr
)))))
789 (and (eq calc-angle-mode
'rad
)
790 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
792 (math-known-sin (car n
) (nth 1 n
) 120 0))))
793 (and (eq calc-angle-mode
'deg
)
794 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
796 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
797 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
798 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
799 (nth 1 (nth 1 math-simplify-expr
))))))
800 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
801 (math-div (nth 1 (nth 1 math-simplify-expr
))
803 (math-add 1 (math-sqr
804 (nth 1 (nth 1 math-simplify-expr
)))))))
805 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
806 (and m
(integerp (car m
))
807 (let ((n (car m
)) (a (nth 1 m
)))
809 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
810 (list 'calcFunc-cos a
))
811 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
812 (list 'calcFunc-sin a
))))))))
814 (math-defsimplify calcFunc-cos
815 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
816 (nth 1 (nth 1 math-simplify-expr
)))
817 (and (math-looks-negp (nth 1 math-simplify-expr
))
818 (list 'calcFunc-cos
(math-neg (nth 1 math-simplify-expr
))))
819 (and (eq calc-angle-mode
'rad
)
820 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
822 (math-known-sin (car n
) (nth 1 n
) 120 300))))
823 (and (eq calc-angle-mode
'deg
)
824 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
826 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
827 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
829 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))
830 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
834 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
835 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
836 (and m
(integerp (car m
))
837 (let ((n (car m
)) (a (nth 1 m
)))
839 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
840 (list 'calcFunc-cos a
))
841 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
842 (list 'calcFunc-sin a
))))))))
844 (math-defsimplify calcFunc-sec
845 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
846 (list 'calcFunc-sec
(math-neg (nth 1 math-simplify-expr
))))
847 (and (eq calc-angle-mode
'rad
)
848 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
850 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 300)))))
851 (and (eq calc-angle-mode
'deg
)
852 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
854 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300)))))
855 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
859 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
860 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
863 (nth 1 (nth 1 math-simplify-expr
))))
864 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
867 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
869 (math-defsimplify calcFunc-csc
870 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
871 (math-neg (list 'calcFunc-csc
(math-neg (nth 1 math-simplify-expr
)))))
872 (and (eq calc-angle-mode
'rad
)
873 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
875 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 0)))))
876 (and (eq calc-angle-mode
'deg
)
877 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
879 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0)))))
880 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
881 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
882 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
885 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
886 (nth 1 (nth 1 math-simplify-expr
)))))))
887 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
888 (math-div (list 'calcFunc-sqrt
889 (math-add 1 (math-sqr
890 (nth 1 (nth 1 math-simplify-expr
)))))
891 (nth 1 (nth 1 math-simplify-expr
))))))
893 (defun math-should-expand-trig (x &optional hyperbolic
)
894 (let ((m (math-is-multiple x
)))
895 (and math-living-dangerously
896 m
(or (and (integerp (car m
)) (> (car m
) 1))
897 (equal (car m
) '(frac 1 2)))
899 (memq (car-safe (nth 1 m
))
901 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
902 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
903 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
904 (eq hyperbolic
'exp
)))
907 (defun math-known-sin (plus n mul off
)
908 (setq n
(math-mul n mul
))
909 (and (math-num-integerp n
)
910 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
912 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
916 (if (math-zerop plus
)
917 (and (or calc-symbolic-mode
921 (10 .
(/ (calcFunc-sqrt
922 (- 2 (calcFunc-sqrt 3))) 2))
923 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
924 (15 .
(/ (calcFunc-sqrt
925 (- 2 (calcFunc-sqrt 2))) 2))
927 (24 .
(* (^
(/ 1 2) (/ 3 2))
929 (- 5 (calcFunc-sqrt 5)))))
930 (30 .
(/ (calcFunc-sqrt 2) 2))
931 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
932 (40 .
(/ (calcFunc-sqrt 3) 2))
933 (45 .
(/ (calcFunc-sqrt
934 (+ 2 (calcFunc-sqrt 2))) 2))
935 (48 .
(* (^
(/ 1 2) (/ 3 2))
937 (+ 5 (calcFunc-sqrt 5)))))
938 (50 .
(/ (calcFunc-sqrt
939 (+ 2 (calcFunc-sqrt 3))) 2))
941 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
942 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
945 (math-defsimplify calcFunc-tan
946 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
947 (nth 1 (nth 1 math-simplify-expr
)))
948 (and (math-looks-negp (nth 1 math-simplify-expr
))
949 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 math-simplify-expr
)))))
950 (and (eq calc-angle-mode
'rad
)
951 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
953 (math-known-tan (car n
) (nth 1 n
) 120))))
954 (and (eq calc-angle-mode
'deg
)
955 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
957 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
958 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
959 (math-div (nth 1 (nth 1 math-simplify-expr
))
961 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
962 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
963 (math-div (list 'calcFunc-sqrt
964 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
965 (nth 1 (nth 1 math-simplify-expr
))))
966 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
968 (if (equal (car m
) '(frac 1 2))
969 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
970 (list 'calcFunc-sin
(nth 1 m
)))
971 (math-div (list 'calcFunc-sin
(nth 1 math-simplify-expr
))
972 (list 'calcFunc-cos
(nth 1 math-simplify-expr
))))))))
974 (math-defsimplify calcFunc-cot
975 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
976 (math-neg (list 'calcFunc-cot
(math-neg (nth 1 math-simplify-expr
)))))
977 (and (eq calc-angle-mode
'rad
)
978 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
980 (math-div 1 (math-known-tan (car n
) (nth 1 n
) 120)))))
981 (and (eq calc-angle-mode
'deg
)
982 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
984 (math-div 1 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3))))))
985 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
986 (math-div (list 'calcFunc-sqrt
987 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
988 (nth 1 (nth 1 math-simplify-expr
))))
989 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
990 (math-div (nth 1 (nth 1 math-simplify-expr
))
992 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
993 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
994 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
996 (defun math-known-tan (plus n mul
)
997 (setq n
(math-mul n mul
))
998 (and (math-num-integerp n
)
999 (setq n
(math-mod (math-trunc n
) 120))
1001 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
1003 (if (math-zerop plus
)
1004 (and (or calc-symbolic-mode
1005 (memq n
'(0 30 60)))
1006 (cdr (assq n
'( (0 .
0)
1007 (10 .
(- 2 (calcFunc-sqrt 3)))
1008 (12 .
(calcFunc-sqrt
1009 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1010 (15 .
(- (calcFunc-sqrt 2) 1))
1011 (20 .
(/ (calcFunc-sqrt 3) 3))
1012 (24 .
(calcFunc-sqrt
1013 (- 5 (* 2 (calcFunc-sqrt 5)))))
1015 (36 .
(calcFunc-sqrt
1016 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
1017 (40 .
(calcFunc-sqrt 3))
1018 (45 .
(+ (calcFunc-sqrt 2) 1))
1019 (48 .
(calcFunc-sqrt
1020 (+ 5 (* 2 (calcFunc-sqrt 5)))))
1021 (50 .
(+ 2 (calcFunc-sqrt 3)))
1022 (60 .
(var uinf var-uinf
))))))
1023 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
1024 ((eq n
60) (math-normalize (list '/ -
1
1025 (list 'calcFunc-tan plus
))))
1028 (math-defsimplify calcFunc-sinh
1029 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1030 (nth 1 (nth 1 math-simplify-expr
)))
1031 (and (math-looks-negp (nth 1 math-simplify-expr
))
1032 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 math-simplify-expr
)))))
1033 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1034 math-living-dangerously
1035 (list 'calcFunc-sqrt
1036 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1037 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1038 math-living-dangerously
1039 (math-div (nth 1 (nth 1 math-simplify-expr
))
1040 (list 'calcFunc-sqrt
1041 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1042 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1043 (and m
(integerp (car m
))
1044 (let ((n (car m
)) (a (nth 1 m
)))
1047 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1048 (list 'calcFunc-cosh a
))
1049 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1050 (list 'calcFunc-sinh a
)))))))))
1052 (math-defsimplify calcFunc-cosh
1053 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1054 (nth 1 (nth 1 math-simplify-expr
)))
1055 (and (math-looks-negp (nth 1 math-simplify-expr
))
1056 (list 'calcFunc-cosh
(math-neg (nth 1 math-simplify-expr
))))
1057 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1058 math-living-dangerously
1059 (list 'calcFunc-sqrt
1060 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
1061 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1062 math-living-dangerously
1064 (list 'calcFunc-sqrt
1065 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
1066 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1067 (and m
(integerp (car m
))
1068 (let ((n (car m
)) (a (nth 1 m
)))
1071 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
1072 (list 'calcFunc-cosh a
))
1073 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
1074 (list 'calcFunc-sinh a
)))))))))
1076 (math-defsimplify calcFunc-tanh
1077 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1078 (nth 1 (nth 1 math-simplify-expr
)))
1079 (and (math-looks-negp (nth 1 math-simplify-expr
))
1080 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 math-simplify-expr
)))))
1081 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1082 math-living-dangerously
1083 (math-div (nth 1 (nth 1 math-simplify-expr
))
1084 (list 'calcFunc-sqrt
1085 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1086 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1087 math-living-dangerously
1088 (math-div (list 'calcFunc-sqrt
1089 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1090 (nth 1 (nth 1 math-simplify-expr
))))
1091 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
1093 (if (equal (car m
) '(frac 1 2))
1094 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
1095 (list 'calcFunc-sinh
(nth 1 m
)))
1096 (math-div (list 'calcFunc-sinh
(nth 1 math-simplify-expr
))
1097 (list 'calcFunc-cosh
(nth 1 math-simplify-expr
))))))))
1099 (math-defsimplify calcFunc-sech
1100 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1101 (list 'calcFunc-sech
(math-neg (nth 1 math-simplify-expr
))))
1102 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1103 math-living-dangerously
1106 (list 'calcFunc-sqrt
1107 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1108 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1109 math-living-dangerously
1110 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))) 1)
1111 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1112 math-living-dangerously
1113 (list 'calcFunc-sqrt
1114 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
1116 (math-defsimplify calcFunc-csch
1117 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1118 (math-neg (list 'calcFunc-csch
(math-neg (nth 1 math-simplify-expr
)))))
1119 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1120 math-living-dangerously
1121 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
1122 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1123 math-living-dangerously
1126 (list 'calcFunc-sqrt
1127 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1128 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1129 math-living-dangerously
1130 (math-div (list 'calcFunc-sqrt
1131 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
1132 (nth 1 (nth 1 math-simplify-expr
))))))
1134 (math-defsimplify calcFunc-coth
1135 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1136 (math-neg (list 'calcFunc-coth
(math-neg (nth 1 math-simplify-expr
)))))
1137 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1138 math-living-dangerously
1139 (math-div (list 'calcFunc-sqrt
1140 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1141 (nth 1 (nth 1 math-simplify-expr
))))
1142 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1143 math-living-dangerously
1144 (math-div (nth 1 (nth 1 math-simplify-expr
))
1145 (list 'calcFunc-sqrt
1146 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1147 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1148 math-living-dangerously
1149 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
1151 (math-defsimplify calcFunc-arcsin
1152 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1153 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 math-simplify-expr
)))))
1154 (and (eq (nth 1 math-simplify-expr
) 1)
1155 (math-quarter-circle t
))
1156 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1157 (math-div (math-half-circle t
) 6))
1158 (and math-living-dangerously
1159 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1160 (nth 1 (nth 1 math-simplify-expr
)))
1161 (and math-living-dangerously
1162 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1163 (math-sub (math-quarter-circle t
)
1164 (nth 1 (nth 1 math-simplify-expr
))))))
1166 (math-defsimplify calcFunc-arccos
1167 (or (and (eq (nth 1 math-simplify-expr
) 0)
1168 (math-quarter-circle t
))
1169 (and (eq (nth 1 math-simplify-expr
) -
1)
1170 (math-half-circle t
))
1171 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1172 (math-div (math-half-circle t
) 3))
1173 (and (equal (nth 1 math-simplify-expr
) '(frac -
1 2))
1174 (math-div (math-mul (math-half-circle t
) 2) 3))
1175 (and math-living-dangerously
1176 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1177 (nth 1 (nth 1 math-simplify-expr
)))
1178 (and math-living-dangerously
1179 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1180 (math-sub (math-quarter-circle t
)
1181 (nth 1 (nth 1 math-simplify-expr
))))))
1183 (math-defsimplify calcFunc-arctan
1184 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1185 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 math-simplify-expr
)))))
1186 (and (eq (nth 1 math-simplify-expr
) 1)
1187 (math-div (math-half-circle t
) 4))
1188 (and math-living-dangerously
1189 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tan
)
1190 (nth 1 (nth 1 math-simplify-expr
)))))
1192 (math-defsimplify calcFunc-arcsinh
1193 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1194 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 math-simplify-expr
)))))
1195 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sinh
)
1196 (or math-living-dangerously
1197 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1198 (nth 1 (nth 1 math-simplify-expr
)))))
1200 (math-defsimplify calcFunc-arccosh
1201 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1202 (or math-living-dangerously
1203 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1204 (nth 1 (nth 1 math-simplify-expr
))))
1206 (math-defsimplify calcFunc-arctanh
1207 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1208 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 math-simplify-expr
)))))
1209 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tanh
)
1210 (or math-living-dangerously
1211 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1212 (nth 1 (nth 1 math-simplify-expr
)))))
1214 (math-defsimplify calcFunc-sqrt
1215 (math-simplify-sqrt))
1217 (defun math-simplify-sqrt ()
1218 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
1219 (math-div (list 'calcFunc-sqrt
1220 (math-mul (nth 1 (nth 1 math-simplify-expr
))
1221 (nth 2 (nth 1 math-simplify-expr
))))
1222 (nth 2 (nth 1 math-simplify-expr
))))
1223 (let ((fac (if (math-objectp (nth 1 math-simplify-expr
))
1224 (math-squared-factor (nth 1 math-simplify-expr
))
1225 (math-common-constant-factor (nth 1 math-simplify-expr
)))))
1226 (and fac
(not (eq fac
1))
1227 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
1229 (list 'calcFunc-sqrt
1230 (math-cancel-common-factor
1231 (nth 1 math-simplify-expr
) fac
))))))
1232 (and math-living-dangerously
1233 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1234 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 1)
1235 (eq (car-safe (nth 2 (nth 1 math-simplify-expr
))) '^
)
1236 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr
))) 2)
1237 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1240 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr
))))))
1241 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1244 (nth 1 (nth 1 (nth 2
1245 (nth 1 math-simplify-expr
))))))))
1246 (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1247 (math-equal-int (nth 2 (nth 1 math-simplify-expr
)) 1)
1248 (eq (car-safe (nth 1 (nth 1 math-simplify-expr
))) '^
)
1249 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr
))) 2)
1250 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr
))))
1252 (list 'calcFunc-sinh
1253 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr
)))))))
1254 (and (eq (car-safe (nth 1 math-simplify-expr
)) '+)
1255 (let ((a (nth 1 (nth 1 math-simplify-expr
)))
1256 (b (nth 2 (nth 1 math-simplify-expr
))))
1257 (and (or (and (math-equal-int a
1)
1258 (setq a b b
(nth 1 (nth 1 math-simplify-expr
))))
1259 (math-equal-int b
1))
1260 (eq (car-safe a
) '^
)
1261 (math-equal-int (nth 2 a
) 2)
1262 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
1263 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
1264 (and (eq (car-safe (nth 1 a
)) 'calcFunc-csch
)
1265 (list 'calcFunc-coth
(nth 1 (nth 1 a
))))
1266 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
1267 (list '/ 1 (list 'calcFunc-cos
1268 (nth 1 (nth 1 a
)))))
1269 (and (eq (car-safe (nth 1 a
)) 'calcFunc-cot
)
1270 (list '/ 1 (list 'calcFunc-sin
1271 (nth 1 (nth 1 a
)))))))))
1272 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1274 (nth 1 (nth 1 math-simplify-expr
))
1275 (math-div (nth 2 (nth 1 math-simplify-expr
)) 2)))
1276 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1277 (list '^
(nth 1 (nth 1 math-simplify-expr
)) (math-div 1 4)))
1278 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1279 (list (car (nth 1 math-simplify-expr
))
1280 (list 'calcFunc-sqrt
(nth 1 (nth 1 math-simplify-expr
)))
1281 (list 'calcFunc-sqrt
(nth 2 (nth 1 math-simplify-expr
)))))
1282 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
1283 (not (math-any-floats (nth 1 math-simplify-expr
)))
1284 (let ((f (calcFunc-factors (calcFunc-expand
1285 (nth 1 math-simplify-expr
)))))
1286 (and (math-vectorp f
)
1287 (or (> (length f
) 2)
1288 (> (nth 2 (nth 1 f
)) 1))
1289 (let ((out 1) (rest 1) (sums 1) fac pow
)
1290 (while (setq f
(cdr f
))
1291 (setq fac
(nth 1 (car f
))
1292 pow
(nth 2 (car f
)))
1294 (setq out
(math-mul out
(math-pow
1298 (if (memq (car-safe fac
) '(+ -
))
1299 (setq sums
(math-mul-thru sums fac
))
1300 (setq rest
(math-mul rest fac
)))))
1301 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1304 (list 'calcFunc-sqrt
1305 (math-mul sums rest
))))))))))))
1307 ;;; Rather than factoring x into primes, just check for the first ten primes.
1308 (defun math-squared-factor (x)
1309 (if (Math-integerp x
)
1310 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1314 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1316 fac
(math-mul fac
(car prsqr
)))
1317 (setq prsqr
(cdr prsqr
))))
1320 (math-defsimplify calcFunc-exp
1321 (math-simplify-exp (nth 1 math-simplify-expr
)))
1323 (defun math-simplify-exp (x)
1324 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1326 (and math-living-dangerously
1327 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1329 (list 'calcFunc-sqrt
1330 (math-add (math-sqr (nth 1 x
)) 1))))
1331 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1333 (list 'calcFunc-sqrt
1334 (math-sub (math-sqr (nth 1 x
)) 1))))
1335 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1336 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1337 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1338 (let ((m (math-should-expand-trig x
'exp
)))
1339 (and m
(integerp (car m
))
1340 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1341 (and calc-symbolic-mode
1342 (math-known-imagp x
)
1343 (let* ((ip (calcFunc-im x
))
1344 (n (math-linear-in ip
'(var pi var-pi
)))
1347 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1348 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1349 (list '+ c
(list '* s
'(var i var-i
))))))))
1351 (math-defsimplify calcFunc-ln
1352 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1353 (or math-living-dangerously
1354 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1355 (nth 1 (nth 1 math-simplify-expr
)))
1356 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1357 (equal (nth 1 (nth 1 math-simplify-expr
)) '(var e var-e
))
1358 (or math-living-dangerously
1359 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1360 (nth 2 (nth 1 math-simplify-expr
)))
1361 (and calc-symbolic-mode
1362 (math-known-negp (nth 1 math-simplify-expr
))
1363 (math-add (list 'calcFunc-ln
(math-neg (nth 1 math-simplify-expr
)))
1364 '(* (var pi var-pi
) (var i var-i
))))
1365 (and calc-symbolic-mode
1366 (math-known-imagp (nth 1 math-simplify-expr
))
1367 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr
)))
1368 (ips (math-possible-signs ip
)))
1369 (or (and (memq ips
'(4 6))
1370 (math-add (list 'calcFunc-ln ip
)
1371 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1372 (and (memq ips
'(1 3))
1373 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1374 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1377 (math-simplify-pow))
1379 (defun math-simplify-pow ()
1380 (or (and math-living-dangerously
1381 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1383 (nth 1 (nth 1 math-simplify-expr
))
1384 (math-mul (nth 2 math-simplify-expr
)
1385 (nth 2 (nth 1 math-simplify-expr
)))))
1386 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1388 (nth 1 (nth 1 math-simplify-expr
))
1389 (math-div (nth 2 math-simplify-expr
) 2)))
1390 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1391 (list (car (nth 1 math-simplify-expr
))
1392 (list '^
(nth 1 (nth 1 math-simplify-expr
))
1393 (nth 2 math-simplify-expr
))
1394 (list '^
(nth 2 (nth 1 math-simplify-expr
))
1395 (nth 2 math-simplify-expr
))))))
1396 (and (math-equal-int (nth 1 math-simplify-expr
) 10)
1397 (eq (car-safe (nth 2 math-simplify-expr
)) 'calcFunc-log10
)
1398 (nth 1 (nth 2 math-simplify-expr
)))
1399 (and (equal (nth 1 math-simplify-expr
) '(var e var-e
))
1400 (math-simplify-exp (nth 2 math-simplify-expr
)))
1401 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1402 (not math-integrating
)
1403 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 math-simplify-expr
))
1404 (nth 2 math-simplify-expr
))))
1405 (and (equal (nth 1 math-simplify-expr
) '(var i var-i
))
1407 (math-num-integerp (nth 2 math-simplify-expr
))
1408 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr
)) 4)))
1410 ((eq x
1) (nth 1 math-simplify-expr
))
1412 ((eq x
3) (math-neg (nth 1 math-simplify-expr
))))))
1413 (and math-integrating
1414 (integerp (nth 2 math-simplify-expr
))
1415 (>= (nth 2 math-simplify-expr
) 2)
1416 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1417 (math-mul (math-pow (nth 1 math-simplify-expr
)
1418 (- (nth 2 math-simplify-expr
) 2))
1422 (nth 1 (nth 1 math-simplify-expr
)))))))
1423 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1424 (math-mul (math-pow (nth 1 math-simplify-expr
)
1425 (- (nth 2 math-simplify-expr
) 2))
1428 (list 'calcFunc-sinh
1429 (nth 1 (nth 1 math-simplify-expr
)))))))))
1430 (and (eq (car-safe (nth 2 math-simplify-expr
)) 'frac
)
1431 (Math-ratp (nth 1 math-simplify-expr
))
1432 (Math-posp (nth 1 math-simplify-expr
))
1433 (if (equal (nth 2 math-simplify-expr
) '(frac 1 2))
1434 (list 'calcFunc-sqrt
(nth 1 math-simplify-expr
))
1435 (let ((flr (math-floor (nth 2 math-simplify-expr
))))
1436 (and (not (Math-zerop flr
))
1437 (list '* (list '^
(nth 1 math-simplify-expr
) flr
)
1438 (list '^
(nth 1 math-simplify-expr
)
1439 (math-sub (nth 2 math-simplify-expr
) flr
)))))))
1440 (and (eq (math-quarter-integer (nth 2 math-simplify-expr
)) 2)
1441 (let ((temp (math-simplify-sqrt)))
1443 (list '^ temp
(math-mul (nth 2 math-simplify-expr
) 2)))))))
1445 (math-defsimplify calcFunc-log10
1446 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1447 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 10)
1448 (or math-living-dangerously
1449 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1450 (nth 2 (nth 1 math-simplify-expr
))))
1453 (math-defsimplify calcFunc-erf
1454 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1455 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 math-simplify-expr
)))))
1456 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1457 (list 'calcFunc-conj
1458 (list 'calcFunc-erf
(nth 1 (nth 1 math-simplify-expr
)))))))
1460 (math-defsimplify calcFunc-erfc
1461 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1462 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 math-simplify-expr
)))))
1463 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1464 (list 'calcFunc-conj
1465 (list 'calcFunc-erfc
(nth 1 (nth 1 math-simplify-expr
)))))))
1468 (defun math-linear-in (expr term
&optional always
)
1469 (if (math-expr-contains expr term
)
1470 (let* ((calc-prefer-frac t
)
1471 (p (math-is-polynomial expr term
1)))
1474 (and always
(list expr
0))))
1476 (defun math-multiple-of (expr term
)
1477 (let ((p (math-linear-in expr term
)))
1479 (math-zerop (car p
))
1482 ; not perfect, but it'll do
1483 (defun math-integer-plus (expr)
1484 (cond ((Math-integerp expr
)
1486 ((and (memq (car expr
) '(+ -
))
1487 (Math-integerp (nth 1 expr
)))
1488 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1490 ((and (memq (car expr
) '(+ -
))
1491 (Math-integerp (nth 2 expr
)))
1493 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1496 (defun math-is-linear (expr &optional always
)
1499 (if (eq (car-safe expr
) '+)
1500 (if (Math-objectp (nth 1 expr
))
1501 (setq offset
(nth 1 expr
)
1503 (if (Math-objectp (nth 2 expr
))
1504 (setq offset
(nth 2 expr
)
1505 expr
(nth 1 expr
))))
1506 (if (eq (car-safe expr
) '-
)
1507 (if (Math-objectp (nth 1 expr
))
1508 (setq offset
(nth 1 expr
)
1509 expr
(math-neg (nth 2 expr
)))
1510 (if (Math-objectp (nth 2 expr
))
1511 (setq offset
(math-neg (nth 2 expr
))
1512 expr
(nth 1 expr
))))))
1513 (setq coef
(math-is-multiple expr always
))
1515 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1519 (defun math-is-multiple (expr &optional always
)
1520 (or (if (eq (car-safe expr
) '*)
1521 (if (Math-objectp (nth 1 expr
))
1522 (list (nth 1 expr
) (nth 2 expr
)))
1523 (if (eq (car-safe expr
) '/)
1524 (if (and (Math-objectp (nth 1 expr
))
1525 (not (math-equal-int (nth 1 expr
) 1)))
1526 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1527 (if (Math-objectp (nth 2 expr
))
1528 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1529 (let ((res (math-is-multiple (nth 1 expr
))))
1532 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1533 (setq res
(math-is-multiple (nth 2 expr
)))
1535 (list (math-div 1 (car res
))
1536 (math-div (nth 1 expr
)
1537 (nth 2 (nth 2 expr
)))))))))
1538 (if (eq (car-safe expr
) 'neg
)
1539 (list -
1 (nth 1 expr
)))))
1540 (if (Math-objvecp expr
)
1546 (defun calcFunc-lin (expr &optional var
)
1548 (let ((res (math-linear-in expr var t
)))
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 t
)))
1552 (or res
(math-reject-arg expr
"Linear term expected"))
1555 (defun calcFunc-linnt (expr &optional var
)
1557 (let ((res (math-linear-in expr var
)))
1558 (or res
(math-reject-arg expr
"Linear term expected"))
1559 (list 'vec
(car res
) (nth 1 res
) var
))
1560 (let ((res (math-is-linear expr
)))
1561 (or res
(math-reject-arg expr
"Linear term expected"))
1564 (defun calcFunc-islin (expr &optional var
)
1565 (if (and (Math-objvecp expr
) (not var
))
1567 (calcFunc-lin expr var
)
1570 (defun calcFunc-islinnt (expr &optional var
)
1571 (if (Math-objvecp expr
)
1573 (calcFunc-linnt expr var
)
1579 ;;; Simple operations on expressions.
1581 ;;; Return number of occurrences of thing in expr, or nil if none.
1582 (defun math-expr-contains-count (expr thing
)
1583 (cond ((equal expr thing
) 1)
1584 ((Math-primp expr
) nil
)
1587 (while (setq expr
(cdr expr
))
1588 (setq num
(+ num
(or (math-expr-contains-count
1589 (car expr
) thing
) 0))))
1593 (defun math-expr-contains (expr thing
)
1594 (cond ((equal expr thing
) 1)
1595 ((Math-primp expr
) nil
)
1597 (while (and (setq expr
(cdr expr
))
1598 (not (math-expr-contains (car expr
) thing
))))
1601 ;;; Return non-nil if any variable of thing occurs in expr.
1602 (defun math-expr-depends (expr thing
)
1603 (if (Math-primp thing
)
1604 (and (eq (car-safe thing
) 'var
)
1605 (math-expr-contains expr thing
))
1606 (while (and (setq thing
(cdr thing
))
1607 (not (math-expr-depends expr
(car thing
)))))
1610 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1612 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1613 ;; for math-expr-subst, but used by math-expr-subst-rec.
1614 (defvar math-expr-subst-old
)
1615 (defvar math-expr-subst-new
)
1617 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new
)
1618 (math-expr-subst-rec expr
))
1620 (defalias 'calcFunc-subst
'math-expr-subst
)
1622 (defun math-expr-subst-rec (expr)
1623 (cond ((equal expr math-expr-subst-old
) math-expr-subst-new
)
1624 ((Math-primp expr
) expr
)
1625 ((memq (car expr
) '(calcFunc-deriv
1627 (if (= (length expr
) 2)
1628 (if (equal (nth 1 expr
) math-expr-subst-old
)
1629 (append expr
(list math-expr-subst-new
))
1631 (list (car expr
) (nth 1 expr
)
1632 (math-expr-subst-rec (nth 2 expr
)))))
1635 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1637 ;;; Various measures of the size of an expression.
1638 (defun math-expr-weight (expr)
1639 (if (Math-primp expr
)
1642 (while (setq expr
(cdr expr
))
1643 (setq w
(+ w
(math-expr-weight (car expr
)))))
1646 (defun math-expr-height (expr)
1647 (if (Math-primp expr
)
1650 (while (setq expr
(cdr expr
))
1651 (setq h
(max h
(math-expr-height (car expr
)))))
1657 ;;; Polynomial operations (to support the integrator and solve-for).
1659 (defun calcFunc-collect (expr base
)
1660 (let ((p (math-is-polynomial expr base
50 t
)))
1662 (math-build-polynomial-expr (mapcar 'math-normalize p
) base
)
1665 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1666 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1667 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1669 ;; These variables are local to math-is-polynomial, but are used by
1670 ;; math-is-poly-rec.
1671 (defvar math-is-poly-degree
)
1672 (defvar math-is-poly-loose
)
1675 (defun math-is-polynomial (expr math-var
&optional math-is-poly-degree math-is-poly-loose
)
1676 (let* ((math-poly-base-variable (if math-is-poly-loose
1677 (if (eq math-is-poly-loose
'gen
) math-var
'(var XXX XXX
))
1678 math-poly-base-variable
))
1679 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1680 (and (or (null math-is-poly-degree
)
1681 (<= (length poly
) (1+ math-is-poly-degree
)))
1684 (defun math-is-poly-rec (expr negpow
)
1686 (or (cond ((or (equal expr math-var
)
1687 (eq (car-safe expr
) '^
))
1690 (or (equal expr math-var
)
1691 (setq pow
(nth 2 expr
)
1693 (or (eq math-poly-mult-powers
1)
1694 (setq pow
(let ((m (math-is-multiple pow
1)))
1695 (and (eq (car-safe (car m
)) 'cplx
)
1696 (Math-zerop (nth 1 (car m
)))
1697 (setq m
(list (nth 2 (car m
))
1700 (and (if math-poly-mult-powers
1701 (equal math-poly-mult-powers
1703 (setq math-poly-mult-powers
(nth 1 m
)))
1704 (or (equal expr math-var
)
1705 (eq math-poly-mult-powers
1))
1709 (setq pow
(math-to-simple-fraction pow
))
1710 (and (eq (car-safe pow
) 'frac
)
1711 math-poly-frac-powers
1712 (equal expr math-var
)
1713 (setq math-poly-frac-powers
1714 (calcFunc-lcm math-poly-frac-powers
1716 (or (memq math-poly-frac-powers
'(1 nil
))
1717 (setq pow
(math-mul pow math-poly-frac-powers
)))
1720 (equal expr math-var
))
1723 (let ((p1 (if (equal expr math-var
)
1725 (math-is-poly-rec expr nil
)))
1729 (or (null math-is-poly-degree
)
1730 (<= (* (1- (length p1
)) n
) math-is-poly-degree
))
1733 (setq accum
(math-poly-mul accum p1
)
1737 (math-is-poly-rec expr nil
)
1738 (setq math-poly-neg-powers
1739 (cons (math-pow expr
(- pow
))
1740 math-poly-neg-powers
))
1741 (list (list '^ expr pow
))))))))
1742 ((Math-objectp expr
)
1744 ((memq (car expr
) '(+ -
))
1745 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1747 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1749 (math-poly-mix p1
1 p2
1750 (if (eq (car expr
) '+) 1 -
1)))))))
1751 ((eq (car expr
) 'neg
)
1752 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1754 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1756 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1758 (or (null math-is-poly-degree
)
1759 (<= (- (+ (length p1
) (length p2
)) 2)
1760 math-is-poly-degree
))
1761 (math-poly-mul p1 p2
))))))
1763 (and (or (not (math-poly-depends (nth 2 expr
) math-var
))
1765 (math-is-poly-rec (nth 2 expr
) nil
)
1766 (setq math-poly-neg-powers
1767 (cons (nth 2 expr
) math-poly-neg-powers
))))
1768 (not (Math-zerop (nth 2 expr
)))
1769 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1770 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1772 ((and (eq (car expr
) 'calcFunc-exp
)
1773 (equal math-var
'(var e var-e
)))
1774 (math-is-poly-rec (list '^ math-var
(nth 1 expr
)) negpow
))
1775 ((and (eq (car expr
) 'calcFunc-sqrt
)
1776 math-poly-frac-powers
)
1777 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1779 (and (or (not (math-poly-depends expr math-var
))
1781 (not (eq (car expr
) 'vec
))
1784 ;;; Check if expr is a polynomial in var; if so, return its degree.
1785 (defun math-polynomial-p (expr var
)
1786 (cond ((equal expr var
) 1)
1787 ((Math-primp expr
) 0)
1788 ((memq (car expr
) '(+ -
))
1789 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1791 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1794 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1796 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1798 ((eq (car expr
) 'neg
)
1799 (math-polynomial-p (nth 1 expr
) var
))
1800 ((and (eq (car expr
) '/)
1801 (not (math-poly-depends (nth 2 expr
) var
)))
1802 (math-polynomial-p (nth 1 expr
) var
))
1803 ((and (eq (car expr
) '^
)
1804 (natnump (nth 2 expr
)))
1805 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1806 (and p1
(* p1
(nth 2 expr
)))))
1807 ((math-poly-depends expr var
) nil
)
1810 (defun math-poly-depends (expr var
)
1811 (if math-poly-base-variable
1812 (math-expr-contains expr math-poly-base-variable
)
1813 (math-expr-depends expr var
)))
1815 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1816 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1817 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1818 (defvar math-poly-base-const-ok
)
1819 (defvar math-poly-base-pred
)
1821 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1822 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1823 ;; by math-polynomial-base.
1825 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred
)
1826 (or math-poly-base-pred
1827 (setq math-poly-base-pred
(function (lambda (base) (math-polynomial-p
1828 math-poly-base-top-expr base
)))))
1829 (or (let ((math-poly-base-const-ok nil
))
1830 (math-polynomial-base-rec math-poly-base-top-expr
))
1831 (let ((math-poly-base-const-ok t
))
1832 (math-polynomial-base-rec math-poly-base-top-expr
))))
1834 (defun math-polynomial-base-rec (mpb-expr)
1835 (and (not (Math-objvecp mpb-expr
))
1836 (or (and (memq (car mpb-expr
) '(+ -
*))
1837 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1838 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1839 (and (memq (car mpb-expr
) '(/ neg
))
1840 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1841 (and (eq (car mpb-expr
) '^
)
1842 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1843 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1844 (math-polynomial-base-rec '(var e var-e
)))
1845 (and (or math-poly-base-const-ok
(math-expr-contains-vars mpb-expr
))
1846 (funcall math-poly-base-pred mpb-expr
)
1849 ;;; Return non-nil if expr refers to any variables.
1850 (defun math-expr-contains-vars (expr)
1851 (or (eq (car-safe expr
) 'var
)
1852 (and (not (Math-primp expr
))
1854 (while (and (setq expr
(cdr expr
))
1855 (not (math-expr-contains-vars (car expr
)))))
1858 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1859 ;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil.
1860 (defun math-poly-simplify (p)
1862 (if (Math-zerop (nth (1- (length p
)) p
))
1863 (let ((pp (copy-sequence p
)))
1864 (while (and (cdr pp
)
1865 (Math-zerop (nth (1- (length pp
)) pp
)))
1866 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1870 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1871 ;;; coefficients ac, bc. Result may be unsimplified.
1872 (defun math-poly-mix (a ac b bc
)
1874 (cons (math-add (math-mul (or (car a
) 0) ac
)
1875 (math-mul (or (car b
) 0) bc
))
1876 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1878 (defun math-poly-zerop (a)
1880 (and (null (cdr a
)) (Math-zerop (car a
)))))
1882 ;;; Multiply two polynomials in list form.
1883 (defun math-poly-mul (a b
)
1885 (math-poly-mix b
(car a
)
1886 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1888 ;;; Build an expression from a polynomial list.
1889 (defun math-build-polynomial-expr (p var
)
1891 (if (Math-numberp var
)
1892 (math-with-extra-prec 1
1893 (let* ((rp (reverse p
))
1895 (while (setq rp
(cdr rp
))
1896 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1898 (let* ((rp (reverse p
))
1899 (n (1- (length rp
)))
1900 (accum (math-mul (car rp
) (math-pow var n
)))
1902 (while (setq rp
(cdr rp
))
1904 (or (math-zerop (car rp
))
1905 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1907 (math-mul (if (math-looks-negp (car rp
))
1910 (math-pow var n
))))))
1915 (defun math-to-simple-fraction (f)
1916 (or (and (eq (car-safe f
) 'float
)
1917 (or (and (>= (nth 2 f
) 0)
1918 (math-scale-int (nth 1 f
) (nth 2 f
)))
1919 (and (integerp (nth 1 f
))
1922 (math-make-frac (nth 1 f
)
1923 (math-scale-int 1 (- (nth 2 f
)))))))
1928 ;;; calc-alg.el ends here
