1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2005 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
36 (defun calc-alg-evaluate (arg)
39 (calc-with-default-simplification
40 (let ((math-simplify-only nil
))
41 (calc-modify-simplify-mode arg
)
42 (calc-enter-result 1 "dsmp" (calc-top 1))))))
44 (defun calc-modify-simplify-mode (arg)
45 (if (= (math-abs arg
) 2)
46 (setq calc-simplify-mode
'alg
)
47 (if (>= (math-abs arg
) 3)
48 (setq calc-simplify-mode
'ext
)))
50 (setq calc-simplify-mode
(list calc-simplify-mode
))))
52 (defun calc-simplify ()
55 (calc-with-default-simplification
56 (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
58 (defun calc-simplify-extended ()
61 (calc-with-default-simplification
62 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
64 (defun calc-expand-formula (arg)
67 (calc-with-default-simplification
68 (let ((math-simplify-only nil
))
69 (calc-modify-simplify-mode arg
)
70 (calc-enter-result 1 "expf"
72 (let ((math-expand-formulas t
))
74 (let ((top (calc-top-n 1)))
75 (or (math-expand-formula top
)
78 (defun calc-factor (arg)
81 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
82 'calcFunc-factors
'calcFunc-factor
)
85 (defun calc-expand (n)
88 (calc-enter-result 1 "expa"
89 (append (list 'calcFunc-expand
91 (and n
(list (prefix-numeric-value n
)))))))
93 (defun calc-collect (&optional var
)
94 (interactive "sCollect terms involving: ")
96 (if (or (equal var
"") (equal var
"$") (null var
))
97 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
99 (let ((var (math-read-expr var
)))
100 (if (eq (car-safe var
) 'error
)
101 (error "Bad format in expression: %s" (nth 1 var
)))
102 (calc-enter-result 1 "clct" (list 'calcFunc-collect
106 (defun calc-apart (arg)
109 (calc-unary-op "aprt" 'calcFunc-apart arg
)))
111 (defun calc-normalize-rat (arg)
114 (calc-unary-op "nrat" 'calcFunc-nrat arg
)))
116 (defun calc-poly-gcd (arg)
119 (calc-binary-op "pgcd" 'calcFunc-pgcd arg
)))
122 (defun calc-poly-div (arg)
125 (let ((calc-poly-div-remainder nil
))
126 (calc-binary-op "pdiv" 'calcFunc-pdiv arg
)
127 (if (and calc-poly-div-remainder
(null arg
))
129 (calc-clear-command-flag 'clear-message
)
130 (calc-record calc-poly-div-remainder
"prem")
131 (if (not (Math-zerop calc-poly-div-remainder
))
132 (message "(Remainder was %s)"
133 (math-format-flat-expr calc-poly-div-remainder
0))
134 (message "(No remainder)")))))))
136 (defun calc-poly-rem (arg)
139 (calc-binary-op "prem" 'calcFunc-prem arg
)))
141 (defun calc-poly-div-rem (arg)
144 (if (calc-is-hyperbolic)
145 (calc-binary-op "pdvr" 'calcFunc-pdivide arg
)
146 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg
))))
148 (defun calc-substitute (&optional oldname newname
)
149 (interactive "sSubstitute old: ")
151 (let (old new
(num 1) expr
)
152 (if (or (equal oldname
"") (equal oldname
"$") (null oldname
))
153 (setq new
(calc-top-n 1)
158 (progn (calc-unread-command ?\C-a
)
159 (setq newname
(read-string (concat "Substitute old: "
163 (if (or (equal newname
"") (equal newname
"$") (null newname
))
164 (setq new
(calc-top-n 1)
167 (setq new
(if (stringp newname
) (math-read-expr newname
) newname
))
168 (if (eq (car-safe new
) 'error
)
169 (error "Bad format in expression: %s" (nth 1 new
)))
170 (setq expr
(calc-top-n 1)))
171 (setq old
(if (stringp oldname
) (math-read-expr oldname
) oldname
))
172 (if (eq (car-safe old
) 'error
)
173 (error "Bad format in expression: %s" (nth 1 old
)))
174 (or (math-expr-contains expr old
)
175 (error "No occurrences found")))
176 (calc-enter-result num
"sbst" (math-expr-subst expr old new
)))))
179 (defun calc-has-rules (name)
180 (setq name
(calc-var-value name
))
182 (memq (car name
) '(vec calcFunc-assign calcFunc-condition
))
185 ;; math-eval-rules-cache and math-eval-rules-cache-other are
186 ;; declared in calc.el, but are used here by math-recompile-eval-rules.
187 (defvar math-eval-rules-cache
)
188 (defvar math-eval-rules-cache-other
)
190 (defun math-recompile-eval-rules ()
191 (setq math-eval-rules-cache
(and (calc-has-rules 'var-EvalRules
)
192 (math-compile-rewrites
193 '(var EvalRules var-EvalRules
)))
194 math-eval-rules-cache-other
(assq nil math-eval-rules-cache
)
195 math-eval-rules-cache-tag
(calc-var-value 'var-EvalRules
)))
198 ;;; Try to expand a formula according to its definition.
199 (defun math-expand-formula (expr)
202 (or (get (car expr
) 'calc-user-defn
)
203 (get (car expr
) 'math-expandable
))
204 (let ((res (let ((math-expand-formulas t
))
205 (apply (car expr
) (cdr expr
)))))
206 (and (not (eq (car-safe res
) (car expr
)))
212 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
213 (defun math-beforep (a b
) ; [Public]
214 (cond ((and (Math-realp a
) (Math-realp b
))
215 (let ((comp (math-compare a b
)))
219 (> (length (memq (car-safe a
)
220 '(bigneg nil bigpos frac float
)))
221 (length (memq (car-safe b
)
222 '(bigneg nil bigpos frac float
))))))))
223 ((equal b
'(neg (var inf var-inf
))) nil
)
224 ((equal a
'(neg (var inf var-inf
))) t
)
225 ((equal a
'(var inf var-inf
)) nil
)
226 ((equal b
'(var inf var-inf
)) t
)
228 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
))
229 (if (or (math-beforep a
(nth 2 b
)) (Math-equal a
(nth 2 b
)))
234 (if (and (eq (car-safe a
) 'intv
) (math-intv-constp a
))
235 (if (math-beforep (nth 2 a
) b
)
239 ((and (eq (car a
) 'intv
) (eq (car b
) 'intv
)
240 (math-intv-constp a
) (math-intv-constp b
))
241 (let ((comp (math-compare (nth 2 a
) (nth 2 b
))))
242 (cond ((eq comp -
1) t
)
244 ((and (memq (nth 1 a
) '(2 3)) (memq (nth 1 b
) '(0 1))) t
)
245 ((and (memq (nth 1 a
) '(0 1)) (memq (nth 1 b
) '(2 3))) nil
)
246 ((eq (setq comp
(math-compare (nth 3 a
) (nth 3 b
))) -
1) t
)
248 ((and (memq (nth 1 a
) '(0 2)) (memq (nth 1 b
) '(1 3))) t
)
250 ((not (eq (not (Math-objectp a
)) (not (Math-objectp b
))))
253 (if (eq (car b
) 'var
)
254 (string-lessp (symbol-name (nth 1 a
)) (symbol-name (nth 1 b
)))
255 (not (Math-numberp b
))))
256 ((eq (car b
) 'var
) (Math-numberp a
))
257 ((eq (car a
) (car b
))
258 (while (and (setq a
(cdr a
) b
(cdr b
)) a
259 (equal (car a
) (car b
))))
262 (math-beforep (car a
) (car b
)))))
263 (t (string-lessp (symbol-name (car a
)) (symbol-name (car b
))))))
266 (defsubst math-simplify-extended
(a)
267 (let ((math-living-dangerously t
))
270 (defalias 'calcFunc-esimplify
'math-simplify-extended
)
272 ;; math-top-only is local to math-simplify, but is used by
273 ;; math-simplify-step, which is called by math-simplify.
274 (defvar math-top-only
)
276 (defun math-simplify (top-expr)
277 (let ((math-simplifying t
)
278 (math-top-only (consp calc-simplify-mode
))
279 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
280 '((var AlgSimpRules var-AlgSimpRules
)))
281 (and math-living-dangerously
282 (calc-has-rules 'var-ExtSimpRules
)
283 '((var ExtSimpRules var-ExtSimpRules
)))
284 (and math-simplifying-units
285 (calc-has-rules 'var-UnitSimpRules
)
286 '((var UnitSimpRules var-UnitSimpRules
)))
287 (and math-integrating
288 (calc-has-rules 'var-IntegSimpRules
)
289 '((var IntegSimpRules var-IntegSimpRules
)))))
292 (let ((r simp-rules
))
293 (setq res
(math-simplify-step (math-normalize top-expr
))
294 calc-simplify-mode
'(nil)
295 top-expr
(math-normalize res
))
297 (setq top-expr
(math-rewrite top-expr
(car r
)
298 '(neg (var inf var-inf
)))
300 (calc-with-default-simplification
301 (while (let ((r simp-rules
))
302 (setq res
(math-normalize top-expr
))
304 (setq res
(math-rewrite res
(car r
))
306 (not (equal top-expr
(setq res
(math-simplify-step res
)))))
307 (setq top-expr res
)))))
310 (defalias 'calcFunc-simplify
'math-simplify
)
312 ;;; The following has a "bug" in that if any recursive simplifications
313 ;;; occur only the first handler will be tried; this doesn't really
314 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
315 (defun math-simplify-step (a)
318 (let ((aa (if (or math-top-only
319 (memq (car a
) '(calcFunc-quote calcFunc-condition
322 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
323 (and (symbolp (car aa
))
324 (let ((handler (get (car aa
) 'math-simplify
)))
327 (equal (setq aa
(or (funcall (car handler
) aa
)
330 (setq handler
(cdr handler
))))))
334 (defmacro math-defsimplify
(funcs &rest code
)
338 (list 'put
(list 'quote func
) ''math-simplify
340 (list 'get
(list 'quote func
) ''math-simplify
)
343 (append '(lambda (math-simplify-expr))
345 (if (symbolp funcs
) (list funcs
) funcs
))))
346 (put 'math-defsimplify
'lisp-indent-hook
1)
348 ;; The function created by math-defsimplify uses the variable
349 ;; math-simplify-expr, and so is used by functions in math-defsimplify
350 (defvar math-simplify-expr
)
352 (math-defsimplify (+ -
)
353 (math-simplify-plus))
355 (defun math-simplify-plus ()
356 (cond ((and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
357 (Math-numberp (nth 2 (nth 1 math-simplify-expr
)))
358 (not (Math-numberp (nth 2 math-simplify-expr
))))
359 (let ((x (nth 2 math-simplify-expr
))
360 (op (car math-simplify-expr
)))
361 (setcar (cdr (cdr math-simplify-expr
)) (nth 2 (nth 1 math-simplify-expr
)))
362 (setcar math-simplify-expr
(car (nth 1 math-simplify-expr
)))
363 (setcar (cdr (cdr (nth 1 math-simplify-expr
))) x
)
364 (setcar (nth 1 math-simplify-expr
) op
)))
365 ((and (eq (car math-simplify-expr
) '+)
366 (Math-numberp (nth 1 math-simplify-expr
))
367 (not (Math-numberp (nth 2 math-simplify-expr
))))
368 (let ((x (nth 2 math-simplify-expr
)))
369 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
370 (setcar (cdr math-simplify-expr
) x
))))
371 (let ((aa math-simplify-expr
)
373 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
374 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 math-simplify-expr
)
376 (eq (car math-simplify-expr
) '-
) t
))
378 (setcar (cdr (cdr math-simplify-expr
)) temp
)
379 (setcar math-simplify-expr
'+)
380 (setcar (cdr (cdr aaa
)) 0)))
381 (setq aa
(nth 1 aa
)))
382 (if (setq temp
(math-combine-sum aaa
(nth 2 math-simplify-expr
)
383 nil
(eq (car math-simplify-expr
) '-
) t
))
385 (setcar (cdr (cdr math-simplify-expr
)) temp
)
386 (setcar math-simplify-expr
'+)
387 (setcar (cdr aa
) 0)))
391 (math-simplify-times))
393 (defun math-simplify-times ()
394 (if (eq (car-safe (nth 2 math-simplify-expr
)) '*)
395 (and (math-beforep (nth 1 (nth 2 math-simplify-expr
)) (nth 1 math-simplify-expr
))
396 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
397 (math-known-scalarp (nth 1 (nth 2 math-simplify-expr
)) t
))
398 (let ((x (nth 1 math-simplify-expr
)))
399 (setcar (cdr math-simplify-expr
) (nth 1 (nth 2 math-simplify-expr
)))
400 (setcar (cdr (nth 2 math-simplify-expr
)) x
)))
401 (and (math-beforep (nth 2 math-simplify-expr
) (nth 1 math-simplify-expr
))
402 (or (math-known-scalarp (nth 1 math-simplify-expr
) t
)
403 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
404 (let ((x (nth 2 math-simplify-expr
)))
405 (setcar (cdr (cdr math-simplify-expr
)) (nth 1 math-simplify-expr
))
406 (setcar (cdr math-simplify-expr
) x
))))
407 (let ((aa math-simplify-expr
)
409 (safe t
) (scalar (math-known-scalarp (nth 1 math-simplify-expr
))))
410 (if (and (Math-ratp (nth 1 math-simplify-expr
))
411 (setq temp
(math-common-constant-factor (nth 2 math-simplify-expr
))))
413 (setcar (cdr (cdr math-simplify-expr
))
414 (math-cancel-common-factor (nth 2 math-simplify-expr
) temp
))
415 (setcar (cdr math-simplify-expr
) (math-mul (nth 1 math-simplify-expr
) temp
))))
416 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
418 (if (setq temp
(math-combine-prod (nth 1 math-simplify-expr
)
419 (nth 1 aaa
) nil nil t
))
421 (setcar (cdr math-simplify-expr
) temp
)
422 (setcar (cdr aaa
) 1)))
423 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
425 (if (and (setq temp
(math-combine-prod aaa
(nth 1 math-simplify-expr
) nil nil t
))
428 (setcar (cdr math-simplify-expr
) temp
)
429 (setcar (cdr (cdr aa
)) 1)))
430 (if (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
431 (memq (nth 1 (nth 1 math-simplify-expr
)) '(1 -
1)))
432 (math-div (math-mul (nth 2 math-simplify-expr
)
433 (nth 1 (nth 1 math-simplify-expr
)))
434 (nth 2 (nth 1 math-simplify-expr
)))
435 math-simplify-expr
)))
438 (math-simplify-divide))
440 (defun math-simplify-divide ()
441 (let ((np (cdr math-simplify-expr
))
443 (nn (and (or (eq (car math-simplify-expr
) '/)
444 (not (Math-realp (nth 2 math-simplify-expr
))))
445 (math-common-constant-factor (nth 2 math-simplify-expr
))))
449 (setq n
(and (or (eq (car math-simplify-expr
) '/)
450 (not (Math-realp (nth 1 math-simplify-expr
))))
451 (math-common-constant-factor (nth 1 math-simplify-expr
))))
452 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
454 (setcar (cdr math-simplify-expr
)
455 (math-mul (nth 2 nn
) (nth 1 math-simplify-expr
)))
456 (setcar (cdr (cdr math-simplify-expr
))
457 (math-cancel-common-factor (nth 2 math-simplify-expr
) nn
))
458 (if (and (math-negp nn
)
459 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
)))
460 (setcar math-simplify-expr
(nth 1 op
))))
461 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
463 (setcar (cdr math-simplify-expr
)
464 (math-cancel-common-factor (nth 1 math-simplify-expr
) n
))
465 (setcar (cdr (cdr math-simplify-expr
))
466 (math-cancel-common-factor (nth 2 math-simplify-expr
) n
))
467 (if (and (math-negp n
)
468 (setq op
(assq (car math-simplify-expr
)
469 calc-tweak-eqn-table
)))
470 (setcar math-simplify-expr
(nth 1 op
))))))))
471 (if (and (eq (car-safe (car np
)) '/)
472 (math-known-scalarp (nth 2 math-simplify-expr
) t
))
474 (setq np
(cdr (nth 1 math-simplify-expr
)))
475 (while (eq (car-safe (setq n
(car np
))) '*)
476 (and (math-known-scalarp (nth 2 n
) t
)
477 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nil t
))
478 (setq np
(cdr (cdr n
))))
479 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nil t
)
481 np
(cdr (cdr (nth 1 math-simplify-expr
))))))
482 (while (eq (car-safe (setq n
(car np
))) '*)
483 (and (math-known-scalarp (nth 2 n
) t
)
484 (math-simplify-divisor (cdr n
) (cdr (cdr math-simplify-expr
)) nover t
))
485 (setq np
(cdr (cdr n
))))
486 (math-simplify-divisor np
(cdr (cdr math-simplify-expr
)) nover t
)
489 ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover
490 ;; are local variables for math-simplify-divisor, but are used by
491 ;; math-simplify-one-divisor.
492 (defvar math-simplify-divisor-nover
)
493 (defvar math-simplify-divisor-dover
)
495 (defun math-simplify-divisor (np dp math-simplify-divisor-nover
496 math-simplify-divisor-dover
)
497 (cond ((eq (car-safe (car dp
)) '/)
498 (math-simplify-divisor np
(cdr (car dp
))
499 math-simplify-divisor-nover
500 math-simplify-divisor-dover
)
501 (and (math-known-scalarp (nth 1 (car dp
)) t
)
502 (math-simplify-divisor np
(cdr (cdr (car dp
)))
503 math-simplify-divisor-nover
504 (not math-simplify-divisor-dover
))))
505 ((or (or (eq (car math-simplify-expr
) '/)
506 (let ((signs (math-possible-signs (car np
))))
507 (or (memq signs
'(1 4))
508 (and (memq (car math-simplify-expr
) '(calcFunc-eq calcFunc-neq
))
510 math-living-dangerously
)))
511 (math-numberp (car np
)))
514 (scalar (math-known-scalarp (car np
))))
515 (while (and (eq (car-safe (setq d
(car dp
))) '*)
517 (math-simplify-one-divisor np
(cdr d
))
518 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
521 (math-simplify-one-divisor np dp
))))))
523 (defun math-simplify-one-divisor (np dp
)
524 (let ((temp (math-combine-prod (car np
) (car dp
) math-simplify-divisor-nover
525 math-simplify-divisor-dover t
))
529 (and (not (memq (car math-simplify-expr
) '(/ calcFunc-eq calcFunc-neq
)))
530 (math-known-negp (car dp
))
531 (setq op
(assq (car math-simplify-expr
) calc-tweak-eqn-table
))
532 (setcar math-simplify-expr
(nth 1 op
)))
533 (setcar np
(if math-simplify-divisor-nover
(math-div 1 temp
) temp
))
535 (and math-simplify-divisor-dover
(not math-simplify-divisor-nover
)
536 (eq (car math-simplify-expr
) '/)
537 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
538 (Math-integerp (nth 1 (car dp
)))
540 (setcar np
(math-mul (car np
)
541 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
542 (setcar dp
(nth 1 (car dp
))))))))
544 (defun math-common-constant-factor (expr)
545 (if (Math-realp expr
)
547 (and (not (memq expr
'(0 1 -
1)))
549 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
550 (math-common-constant-factor expr
)))
551 (if (memq (car expr
) '(+ - cplx sdev
))
552 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
553 (f2 (math-common-constant-factor (nth 2 expr
))))
555 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
557 (if (memq (car expr
) '(* polar
))
558 (math-common-constant-factor (nth 1 expr
))
559 (if (eq (car expr
) '/)
560 (or (math-common-constant-factor (nth 1 expr
))
561 (and (Math-integerp (nth 2 expr
))
562 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
564 (defun math-cancel-common-factor (expr val
)
565 (if (memq (car-safe expr
) '(+ - cplx sdev
))
567 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
568 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
570 (if (eq (car-safe expr
) '*)
571 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
572 (math-div expr val
))))
574 (defun math-frac-gcd (a b
)
579 (if (and (Math-integerp a
)
582 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
583 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
584 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
585 (math-gcd (nth 2 a
) (nth 2 b
)))))))
590 (defun math-simplify-mod ()
591 (and (Math-realp (nth 2 math-simplify-expr
))
592 (Math-posp (nth 2 math-simplify-expr
))
593 (let ((lin (math-is-linear (nth 1 math-simplify-expr
)))
596 (or (math-negp (car lin
))
597 (not (Math-lessp (car lin
) (nth 2 math-simplify-expr
))))
600 (math-mul (nth 1 lin
) (nth 2 lin
))
601 (math-mod (car lin
) (nth 2 math-simplify-expr
)))
602 (nth 2 math-simplify-expr
)))
604 (not (math-equal-int (nth 1 lin
) 1))
605 (math-num-integerp (nth 1 lin
))
606 (math-num-integerp (nth 2 math-simplify-expr
))
607 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 math-simplify-expr
)))
608 (not (math-equal-int t1
1))
613 (math-mul (math-div (nth 1 lin
) t1
)
615 (let ((calc-prefer-frac t
))
616 (math-div (car lin
) t1
)))
617 (math-div (nth 2 math-simplify-expr
) t1
))))
618 (and (math-equal-int (nth 2 math-simplify-expr
) 1)
619 (math-known-integerp (if lin
620 (math-mul (nth 1 lin
) (nth 2 lin
))
621 (nth 1 math-simplify-expr
)))
622 (if lin
(math-mod (car lin
) 1) 0))))))
624 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
625 calcFunc-gt calcFunc-leq calcFunc-geq
)
626 (if (= (length math-simplify-expr
) 3)
627 (math-simplify-ineq)))
629 (defun math-simplify-ineq ()
630 (let ((np (cdr math-simplify-expr
))
632 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
633 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr math-simplify-expr
))
636 (math-simplify-add-term np
(cdr (cdr math-simplify-expr
)) nil
637 (eq np
(cdr math-simplify-expr
)))
638 (math-simplify-divide)
639 (let ((signs (math-possible-signs (cons '-
(cdr math-simplify-expr
)))))
640 (or (cond ((eq (car math-simplify-expr
) 'calcFunc-eq
)
641 (or (and (eq signs
2) 1)
642 (and (memq signs
'(1 4 5)) 0)))
643 ((eq (car math-simplify-expr
) 'calcFunc-neq
)
644 (or (and (eq signs
2) 0)
645 (and (memq signs
'(1 4 5)) 1)))
646 ((eq (car math-simplify-expr
) 'calcFunc-lt
)
647 (or (and (eq signs
1) 1)
648 (and (memq signs
'(2 4 6)) 0)))
649 ((eq (car math-simplify-expr
) 'calcFunc-gt
)
650 (or (and (eq signs
4) 1)
651 (and (memq signs
'(1 2 3)) 0)))
652 ((eq (car math-simplify-expr
) 'calcFunc-leq
)
653 (or (and (eq signs
4) 0)
654 (and (memq signs
'(1 2 3)) 1)))
655 ((eq (car math-simplify-expr
) 'calcFunc-geq
)
656 (or (and (eq signs
1) 0)
657 (and (memq signs
'(2 4 6)) 1))))
658 math-simplify-expr
))))
660 (defun math-simplify-add-term (np dp minus lplain
)
661 (or (math-vectorp (car np
))
664 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
666 (if (setq temp
(math-combine-sum n
(nth 2 d
)
667 minus
(eq (car d
) '+) t
))
668 (if (or lplain
(eq (math-looks-negp temp
) minus
))
670 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
671 (setcar (cdr (cdr d
)) 0))
674 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
678 (if (setq temp
(math-combine-sum n d minus t t
))
681 (eq (math-looks-negp temp
) minus
)))
683 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
687 (setcar dp
(setq n
(math-neg temp
)))))))))
689 (math-defsimplify calcFunc-sin
690 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
691 (nth 1 (nth 1 math-simplify-expr
)))
692 (and (math-looks-negp (nth 1 math-simplify-expr
))
693 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 math-simplify-expr
)))))
694 (and (eq calc-angle-mode
'rad
)
695 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
697 (math-known-sin (car n
) (nth 1 n
) 120 0))))
698 (and (eq calc-angle-mode
'deg
)
699 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
701 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
702 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
703 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
704 (nth 1 (nth 1 math-simplify-expr
))))))
705 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
706 (math-div (nth 1 (nth 1 math-simplify-expr
))
708 (math-add 1 (math-sqr
709 (nth 1 (nth 1 math-simplify-expr
)))))))
710 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
711 (and m
(integerp (car m
))
712 (let ((n (car m
)) (a (nth 1 m
)))
714 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
715 (list 'calcFunc-cos a
))
716 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
717 (list 'calcFunc-sin a
))))))))
719 (math-defsimplify calcFunc-cos
720 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
721 (nth 1 (nth 1 math-simplify-expr
)))
722 (and (math-looks-negp (nth 1 math-simplify-expr
))
723 (list 'calcFunc-cos
(math-neg (nth 1 math-simplify-expr
))))
724 (and (eq calc-angle-mode
'rad
)
725 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
727 (math-known-sin (car n
) (nth 1 n
) 120 300))))
728 (and (eq calc-angle-mode
'deg
)
729 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
731 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
732 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
734 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))
735 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
739 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
740 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
741 (and m
(integerp (car m
))
742 (let ((n (car m
)) (a (nth 1 m
)))
744 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
745 (list 'calcFunc-cos a
))
746 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
747 (list 'calcFunc-sin a
))))))))
749 (math-defsimplify calcFunc-sec
750 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
751 (list 'calcFunc-sec
(math-neg (nth 1 math-simplify-expr
))))
752 (and (eq calc-angle-mode
'rad
)
753 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
755 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 300)))))
756 (and (eq calc-angle-mode
'deg
)
757 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
759 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300)))))
760 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
764 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
765 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
768 (nth 1 (nth 1 math-simplify-expr
))))
769 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
772 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
774 (math-defsimplify calcFunc-csc
775 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
776 (math-neg (list 'calcFunc-csc
(math-neg (nth 1 math-simplify-expr
)))))
777 (and (eq calc-angle-mode
'rad
)
778 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
780 (math-div 1 (math-known-sin (car n
) (nth 1 n
) 120 0)))))
781 (and (eq calc-angle-mode
'deg
)
782 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
784 (math-div 1 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0)))))
785 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
786 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
787 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
790 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr
791 (nth 1 (nth 1 math-simplify-expr
)))))))
792 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
793 (math-div (list 'calcFunc-sqrt
794 (math-add 1 (math-sqr
795 (nth 1 (nth 1 math-simplify-expr
)))))
796 (nth 1 (nth 1 math-simplify-expr
))))))
798 (defun math-should-expand-trig (x &optional hyperbolic
)
799 (let ((m (math-is-multiple x
)))
800 (and math-living-dangerously
801 m
(or (and (integerp (car m
)) (> (car m
) 1))
802 (equal (car m
) '(frac 1 2)))
804 (memq (car-safe (nth 1 m
))
806 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
807 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
808 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
809 (eq hyperbolic
'exp
)))
812 (defun math-known-sin (plus n mul off
)
813 (setq n
(math-mul n mul
))
814 (and (math-num-integerp n
)
815 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
817 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
821 (if (math-zerop plus
)
822 (and (or calc-symbolic-mode
826 (10 .
(/ (calcFunc-sqrt
827 (- 2 (calcFunc-sqrt 3))) 2))
828 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
829 (15 .
(/ (calcFunc-sqrt
830 (- 2 (calcFunc-sqrt 2))) 2))
832 (24 .
(* (^
(/ 1 2) (/ 3 2))
834 (- 5 (calcFunc-sqrt 5)))))
835 (30 .
(/ (calcFunc-sqrt 2) 2))
836 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
837 (40 .
(/ (calcFunc-sqrt 3) 2))
838 (45 .
(/ (calcFunc-sqrt
839 (+ 2 (calcFunc-sqrt 2))) 2))
840 (48 .
(* (^
(/ 1 2) (/ 3 2))
842 (+ 5 (calcFunc-sqrt 5)))))
843 (50 .
(/ (calcFunc-sqrt
844 (+ 2 (calcFunc-sqrt 3))) 2))
846 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
847 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
850 (math-defsimplify calcFunc-tan
851 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
852 (nth 1 (nth 1 math-simplify-expr
)))
853 (and (math-looks-negp (nth 1 math-simplify-expr
))
854 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 math-simplify-expr
)))))
855 (and (eq calc-angle-mode
'rad
)
856 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
858 (math-known-tan (car n
) (nth 1 n
) 120))))
859 (and (eq calc-angle-mode
'deg
)
860 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
862 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
863 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
864 (math-div (nth 1 (nth 1 math-simplify-expr
))
866 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
867 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
868 (math-div (list 'calcFunc-sqrt
869 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
870 (nth 1 (nth 1 math-simplify-expr
))))
871 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
))))
873 (if (equal (car m
) '(frac 1 2))
874 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
875 (list 'calcFunc-sin
(nth 1 m
)))
876 (math-div (list 'calcFunc-sin
(nth 1 math-simplify-expr
))
877 (list 'calcFunc-cos
(nth 1 math-simplify-expr
))))))))
879 (math-defsimplify calcFunc-cot
880 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
881 (math-neg (list 'calcFunc-cot
(math-neg (nth 1 math-simplify-expr
)))))
882 (and (eq calc-angle-mode
'rad
)
883 (let ((n (math-linear-in (nth 1 math-simplify-expr
) '(var pi var-pi
))))
885 (math-div 1 (math-known-tan (car n
) (nth 1 n
) 120)))))
886 (and (eq calc-angle-mode
'deg
)
887 (let ((n (math-integer-plus (nth 1 math-simplify-expr
))))
889 (math-div 1 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3))))))
890 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsin
)
891 (math-div (list 'calcFunc-sqrt
892 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
893 (nth 1 (nth 1 math-simplify-expr
))))
894 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccos
)
895 (math-div (nth 1 (nth 1 math-simplify-expr
))
897 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
898 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctan
)
899 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
901 (defun math-known-tan (plus n mul
)
902 (setq n
(math-mul n mul
))
903 (and (math-num-integerp n
)
904 (setq n
(math-mod (math-trunc n
) 120))
906 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
908 (if (math-zerop plus
)
909 (and (or calc-symbolic-mode
911 (cdr (assq n
'( (0 .
0)
912 (10 .
(- 2 (calcFunc-sqrt 3)))
914 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
915 (15 .
(- (calcFunc-sqrt 2) 1))
916 (20 .
(/ (calcFunc-sqrt 3) 3))
918 (- 5 (* 2 (calcFunc-sqrt 5)))))
921 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
922 (40 .
(calcFunc-sqrt 3))
923 (45 .
(+ (calcFunc-sqrt 2) 1))
925 (+ 5 (* 2 (calcFunc-sqrt 5)))))
926 (50 .
(+ 2 (calcFunc-sqrt 3)))
927 (60 .
(var uinf var-uinf
))))))
928 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
929 ((eq n
60) (math-normalize (list '/ -
1
930 (list 'calcFunc-tan plus
))))
933 (math-defsimplify calcFunc-sinh
934 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
935 (nth 1 (nth 1 math-simplify-expr
)))
936 (and (math-looks-negp (nth 1 math-simplify-expr
))
937 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 math-simplify-expr
)))))
938 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
939 math-living-dangerously
941 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
942 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
943 math-living-dangerously
944 (math-div (nth 1 (nth 1 math-simplify-expr
))
946 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
947 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
948 (and m
(integerp (car m
))
949 (let ((n (car m
)) (a (nth 1 m
)))
952 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
953 (list 'calcFunc-cosh a
))
954 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
955 (list 'calcFunc-sinh a
)))))))))
957 (math-defsimplify calcFunc-cosh
958 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
959 (nth 1 (nth 1 math-simplify-expr
)))
960 (and (math-looks-negp (nth 1 math-simplify-expr
))
961 (list 'calcFunc-cosh
(math-neg (nth 1 math-simplify-expr
))))
962 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
963 math-living-dangerously
965 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1)))
966 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
967 math-living-dangerously
970 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))))
971 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
972 (and m
(integerp (car m
))
973 (let ((n (car m
)) (a (nth 1 m
)))
976 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
977 (list 'calcFunc-cosh a
))
978 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
979 (list 'calcFunc-sinh a
)))))))))
981 (math-defsimplify calcFunc-tanh
982 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
983 (nth 1 (nth 1 math-simplify-expr
)))
984 (and (math-looks-negp (nth 1 math-simplify-expr
))
985 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 math-simplify-expr
)))))
986 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
987 math-living-dangerously
988 (math-div (nth 1 (nth 1 math-simplify-expr
))
990 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
991 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
992 math-living-dangerously
993 (math-div (list 'calcFunc-sqrt
994 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
995 (nth 1 (nth 1 math-simplify-expr
))))
996 (let ((m (math-should-expand-trig (nth 1 math-simplify-expr
) t
)))
998 (if (equal (car m
) '(frac 1 2))
999 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
1000 (list 'calcFunc-sinh
(nth 1 m
)))
1001 (math-div (list 'calcFunc-sinh
(nth 1 math-simplify-expr
))
1002 (list 'calcFunc-cosh
(nth 1 math-simplify-expr
))))))))
1004 (math-defsimplify calcFunc-sech
1005 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1006 (list 'calcFunc-sech
(math-neg (nth 1 math-simplify-expr
))))
1007 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1008 math-living-dangerously
1011 (list 'calcFunc-sqrt
1012 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1013 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1014 math-living-dangerously
1015 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))) 1)
1016 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1017 math-living-dangerously
1018 (list 'calcFunc-sqrt
1019 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
))))))))
1021 (math-defsimplify calcFunc-csch
1022 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1023 (math-neg (list 'calcFunc-csch
(math-neg (nth 1 math-simplify-expr
)))))
1024 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1025 math-living-dangerously
1026 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))
1027 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1028 math-living-dangerously
1031 (list 'calcFunc-sqrt
1032 (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))))
1033 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arctanh
)
1034 math-living-dangerously
1035 (math-div (list 'calcFunc-sqrt
1036 (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr
)))))
1037 (nth 1 (nth 1 math-simplify-expr
))))))
1039 (math-defsimplify calcFunc-coth
1040 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1041 (math-neg (list 'calcFunc-coth
(math-neg (nth 1 math-simplify-expr
)))))
1042 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arcsinh
)
1043 math-living-dangerously
1044 (math-div (list 'calcFunc-sqrt
1045 (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr
))) 1))
1046 (nth 1 (nth 1 math-simplify-expr
))))
1047 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-arccosh
)
1048 math-living-dangerously
1049 (math-div (nth 1 (nth 1 math-simplify-expr
))
1050 (list 'calcFunc-sqrt
1051 (math-sub (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
1054 (math-div 1 (nth 1 (nth 1 math-simplify-expr
))))))
1056 (math-defsimplify calcFunc-arcsin
1057 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1058 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 math-simplify-expr
)))))
1059 (and (eq (nth 1 math-simplify-expr
) 1)
1060 (math-quarter-circle t
))
1061 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1062 (math-div (math-half-circle t
) 6))
1063 (and math-living-dangerously
1064 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1065 (nth 1 (nth 1 math-simplify-expr
)))
1066 (and math-living-dangerously
1067 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1068 (math-sub (math-quarter-circle t
)
1069 (nth 1 (nth 1 math-simplify-expr
))))))
1071 (math-defsimplify calcFunc-arccos
1072 (or (and (eq (nth 1 math-simplify-expr
) 0)
1073 (math-quarter-circle t
))
1074 (and (eq (nth 1 math-simplify-expr
) -
1)
1075 (math-half-circle t
))
1076 (and (equal (nth 1 math-simplify-expr
) '(frac 1 2))
1077 (math-div (math-half-circle t
) 3))
1078 (and (equal (nth 1 math-simplify-expr
) '(frac -
1 2))
1079 (math-div (math-mul (math-half-circle t
) 2) 3))
1080 (and math-living-dangerously
1081 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1082 (nth 1 (nth 1 math-simplify-expr
)))
1083 (and math-living-dangerously
1084 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sin
)
1085 (math-sub (math-quarter-circle t
)
1086 (nth 1 (nth 1 math-simplify-expr
))))))
1088 (math-defsimplify calcFunc-arctan
1089 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1090 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 math-simplify-expr
)))))
1091 (and (eq (nth 1 math-simplify-expr
) 1)
1092 (math-div (math-half-circle t
) 4))
1093 (and math-living-dangerously
1094 (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tan
)
1095 (nth 1 (nth 1 math-simplify-expr
)))))
1097 (math-defsimplify calcFunc-arcsinh
1098 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1099 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 math-simplify-expr
)))))
1100 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sinh
)
1101 (or math-living-dangerously
1102 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1103 (nth 1 (nth 1 math-simplify-expr
)))))
1105 (math-defsimplify calcFunc-arccosh
1106 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1107 (or math-living-dangerously
1108 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1109 (nth 1 (nth 1 math-simplify-expr
))))
1111 (math-defsimplify calcFunc-arctanh
1112 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1113 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 math-simplify-expr
)))))
1114 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-tanh
)
1115 (or math-living-dangerously
1116 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1117 (nth 1 (nth 1 math-simplify-expr
)))))
1119 (math-defsimplify calcFunc-sqrt
1120 (math-simplify-sqrt))
1122 (defun math-simplify-sqrt ()
1123 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'frac
)
1124 (math-div (list 'calcFunc-sqrt
1125 (math-mul (nth 1 (nth 1 math-simplify-expr
))
1126 (nth 2 (nth 1 math-simplify-expr
))))
1127 (nth 2 (nth 1 math-simplify-expr
))))
1128 (let ((fac (if (math-objectp (nth 1 math-simplify-expr
))
1129 (math-squared-factor (nth 1 math-simplify-expr
))
1130 (math-common-constant-factor (nth 1 math-simplify-expr
)))))
1131 (and fac
(not (eq fac
1))
1132 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
1134 (list 'calcFunc-sqrt
1135 (math-cancel-common-factor
1136 (nth 1 math-simplify-expr
) fac
))))))
1137 (and math-living-dangerously
1138 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1139 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 1)
1140 (eq (car-safe (nth 2 (nth 1 math-simplify-expr
))) '^
)
1141 (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr
))) 2)
1142 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1145 (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr
))))))
1146 (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr
))))
1149 (nth 1 (nth 1 (nth 2
1150 (nth 1 math-simplify-expr
))))))))
1151 (and (eq (car-safe (nth 1 math-simplify-expr
)) '-
)
1152 (math-equal-int (nth 2 (nth 1 math-simplify-expr
)) 1)
1153 (eq (car-safe (nth 1 (nth 1 math-simplify-expr
))) '^
)
1154 (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr
))) 2)
1155 (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr
))))
1157 (list 'calcFunc-sinh
1158 (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr
)))))))
1159 (and (eq (car-safe (nth 1 math-simplify-expr
)) '+)
1160 (let ((a (nth 1 (nth 1 math-simplify-expr
)))
1161 (b (nth 2 (nth 1 math-simplify-expr
))))
1162 (and (or (and (math-equal-int a
1)
1163 (setq a b b
(nth 1 (nth 1 math-simplify-expr
))))
1164 (math-equal-int b
1))
1165 (eq (car-safe a
) '^
)
1166 (math-equal-int (nth 2 a
) 2)
1167 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
1168 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
1169 (and (eq (car-safe (nth 1 a
)) 'calcFunc-csch
)
1170 (list 'calcFunc-coth
(nth 1 (nth 1 a
))))
1171 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
1172 (list '/ 1 (list 'calcFunc-cos
1173 (nth 1 (nth 1 a
)))))
1174 (and (eq (car-safe (nth 1 a
)) 'calcFunc-cot
)
1175 (list '/ 1 (list 'calcFunc-sin
1176 (nth 1 (nth 1 a
)))))))))
1177 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1179 (nth 1 (nth 1 math-simplify-expr
))
1180 (math-div (nth 2 (nth 1 math-simplify-expr
)) 2)))
1181 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1182 (list '^
(nth 1 (nth 1 math-simplify-expr
)) (math-div 1 4)))
1183 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1184 (list (car (nth 1 math-simplify-expr
))
1185 (list 'calcFunc-sqrt
(nth 1 (nth 1 math-simplify-expr
)))
1186 (list 'calcFunc-sqrt
(nth 2 (nth 1 math-simplify-expr
)))))
1187 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(+ -
))
1188 (not (math-any-floats (nth 1 math-simplify-expr
)))
1189 (let ((f (calcFunc-factors (calcFunc-expand
1190 (nth 1 math-simplify-expr
)))))
1191 (and (math-vectorp f
)
1192 (or (> (length f
) 2)
1193 (> (nth 2 (nth 1 f
)) 1))
1194 (let ((out 1) (rest 1) (sums 1) fac pow
)
1195 (while (setq f
(cdr f
))
1196 (setq fac
(nth 1 (car f
))
1197 pow
(nth 2 (car f
)))
1199 (setq out
(math-mul out
(math-pow
1203 (if (memq (car-safe fac
) '(+ -
))
1204 (setq sums
(math-mul-thru sums fac
))
1205 (setq rest
(math-mul rest fac
)))))
1206 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1209 (list 'calcFunc-sqrt
1210 (math-mul sums rest
))))))))))))
1212 ;;; Rather than factoring x into primes, just check for the first ten primes.
1213 (defun math-squared-factor (x)
1214 (if (Math-integerp x
)
1215 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1219 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1221 fac
(math-mul fac
(car prsqr
)))
1222 (setq prsqr
(cdr prsqr
))))
1225 (math-defsimplify calcFunc-exp
1226 (math-simplify-exp (nth 1 math-simplify-expr
)))
1228 (defun math-simplify-exp (x)
1229 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1231 (and math-living-dangerously
1232 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1234 (list 'calcFunc-sqrt
1235 (math-add (math-sqr (nth 1 x
)) 1))))
1236 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1238 (list 'calcFunc-sqrt
1239 (math-sub (math-sqr (nth 1 x
)) 1))))
1240 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1241 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1242 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1243 (let ((m (math-should-expand-trig x
'exp
)))
1244 (and m
(integerp (car m
))
1245 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1246 (and calc-symbolic-mode
1247 (math-known-imagp x
)
1248 (let* ((ip (calcFunc-im x
))
1249 (n (math-linear-in ip
'(var pi var-pi
)))
1252 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1253 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1254 (list '+ c
(list '* s
'(var i var-i
))))))))
1256 (math-defsimplify calcFunc-ln
1257 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1258 (or math-living-dangerously
1259 (math-known-realp (nth 1 (nth 1 math-simplify-expr
))))
1260 (nth 1 (nth 1 math-simplify-expr
)))
1261 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1262 (equal (nth 1 (nth 1 math-simplify-expr
)) '(var e var-e
))
1263 (or math-living-dangerously
1264 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1265 (nth 2 (nth 1 math-simplify-expr
)))
1266 (and calc-symbolic-mode
1267 (math-known-negp (nth 1 math-simplify-expr
))
1268 (math-add (list 'calcFunc-ln
(math-neg (nth 1 math-simplify-expr
)))
1269 '(* (var pi var-pi
) (var i var-i
))))
1270 (and calc-symbolic-mode
1271 (math-known-imagp (nth 1 math-simplify-expr
))
1272 (let* ((ip (calcFunc-im (nth 1 math-simplify-expr
)))
1273 (ips (math-possible-signs ip
)))
1274 (or (and (memq ips
'(4 6))
1275 (math-add (list 'calcFunc-ln ip
)
1276 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1277 (and (memq ips
'(1 3))
1278 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1279 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1282 (math-simplify-pow))
1284 (defun math-simplify-pow ()
1285 (or (and math-living-dangerously
1286 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1288 (nth 1 (nth 1 math-simplify-expr
))
1289 (math-mul (nth 2 math-simplify-expr
)
1290 (nth 2 (nth 1 math-simplify-expr
)))))
1291 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-sqrt
)
1293 (nth 1 (nth 1 math-simplify-expr
))
1294 (math-div (nth 2 math-simplify-expr
) 2)))
1295 (and (memq (car-safe (nth 1 math-simplify-expr
)) '(* /))
1296 (list (car (nth 1 math-simplify-expr
))
1297 (list '^
(nth 1 (nth 1 math-simplify-expr
))
1298 (nth 2 math-simplify-expr
))
1299 (list '^
(nth 2 (nth 1 math-simplify-expr
))
1300 (nth 2 math-simplify-expr
))))))
1301 (and (math-equal-int (nth 1 math-simplify-expr
) 10)
1302 (eq (car-safe (nth 2 math-simplify-expr
)) 'calcFunc-log10
)
1303 (nth 1 (nth 2 math-simplify-expr
)))
1304 (and (equal (nth 1 math-simplify-expr
) '(var e var-e
))
1305 (math-simplify-exp (nth 2 math-simplify-expr
)))
1306 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-exp
)
1307 (not math-integrating
)
1308 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 math-simplify-expr
))
1309 (nth 2 math-simplify-expr
))))
1310 (and (equal (nth 1 math-simplify-expr
) '(var i var-i
))
1312 (math-num-integerp (nth 2 math-simplify-expr
))
1313 (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr
)) 4)))
1315 ((eq x
1) (nth 1 math-simplify-expr
))
1317 ((eq x
3) (math-neg (nth 1 math-simplify-expr
))))))
1318 (and math-integrating
1319 (integerp (nth 2 math-simplify-expr
))
1320 (>= (nth 2 math-simplify-expr
) 2)
1321 (or (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cos
)
1322 (math-mul (math-pow (nth 1 math-simplify-expr
)
1323 (- (nth 2 math-simplify-expr
) 2))
1327 (nth 1 (nth 1 math-simplify-expr
)))))))
1328 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-cosh
)
1329 (math-mul (math-pow (nth 1 math-simplify-expr
)
1330 (- (nth 2 math-simplify-expr
) 2))
1333 (list 'calcFunc-sinh
1334 (nth 1 (nth 1 math-simplify-expr
)))))))))
1335 (and (eq (car-safe (nth 2 math-simplify-expr
)) 'frac
)
1336 (Math-ratp (nth 1 math-simplify-expr
))
1337 (Math-posp (nth 1 math-simplify-expr
))
1338 (if (equal (nth 2 math-simplify-expr
) '(frac 1 2))
1339 (list 'calcFunc-sqrt
(nth 1 math-simplify-expr
))
1340 (let ((flr (math-floor (nth 2 math-simplify-expr
))))
1341 (and (not (Math-zerop flr
))
1342 (list '* (list '^
(nth 1 math-simplify-expr
) flr
)
1343 (list '^
(nth 1 math-simplify-expr
)
1344 (math-sub (nth 2 math-simplify-expr
) flr
)))))))
1345 (and (eq (math-quarter-integer (nth 2 math-simplify-expr
)) 2)
1346 (let ((temp (math-simplify-sqrt)))
1348 (list '^ temp
(math-mul (nth 2 math-simplify-expr
) 2)))))))
1350 (math-defsimplify calcFunc-log10
1351 (and (eq (car-safe (nth 1 math-simplify-expr
)) '^
)
1352 (math-equal-int (nth 1 (nth 1 math-simplify-expr
)) 10)
1353 (or math-living-dangerously
1354 (math-known-realp (nth 2 (nth 1 math-simplify-expr
))))
1355 (nth 2 (nth 1 math-simplify-expr
))))
1358 (math-defsimplify calcFunc-erf
1359 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1360 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 math-simplify-expr
)))))
1361 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1362 (list 'calcFunc-conj
1363 (list 'calcFunc-erf
(nth 1 (nth 1 math-simplify-expr
)))))))
1365 (math-defsimplify calcFunc-erfc
1366 (or (and (math-looks-negp (nth 1 math-simplify-expr
))
1367 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 math-simplify-expr
)))))
1368 (and (eq (car-safe (nth 1 math-simplify-expr
)) 'calcFunc-conj
)
1369 (list 'calcFunc-conj
1370 (list 'calcFunc-erfc
(nth 1 (nth 1 math-simplify-expr
)))))))
1373 (defun math-linear-in (expr term
&optional always
)
1374 (if (math-expr-contains expr term
)
1375 (let* ((calc-prefer-frac t
)
1376 (p (math-is-polynomial expr term
1)))
1379 (and always
(list expr
0))))
1381 (defun math-multiple-of (expr term
)
1382 (let ((p (math-linear-in expr term
)))
1384 (math-zerop (car p
))
1387 ; not perfect, but it'll do
1388 (defun math-integer-plus (expr)
1389 (cond ((Math-integerp expr
)
1391 ((and (memq (car expr
) '(+ -
))
1392 (Math-integerp (nth 1 expr
)))
1393 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1395 ((and (memq (car expr
) '(+ -
))
1396 (Math-integerp (nth 2 expr
)))
1398 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1401 (defun math-is-linear (expr &optional always
)
1404 (if (eq (car-safe expr
) '+)
1405 (if (Math-objectp (nth 1 expr
))
1406 (setq offset
(nth 1 expr
)
1408 (if (Math-objectp (nth 2 expr
))
1409 (setq offset
(nth 2 expr
)
1410 expr
(nth 1 expr
))))
1411 (if (eq (car-safe expr
) '-
)
1412 (if (Math-objectp (nth 1 expr
))
1413 (setq offset
(nth 1 expr
)
1414 expr
(math-neg (nth 2 expr
)))
1415 (if (Math-objectp (nth 2 expr
))
1416 (setq offset
(math-neg (nth 2 expr
))
1417 expr
(nth 1 expr
))))))
1418 (setq coef
(math-is-multiple expr always
))
1420 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1424 (defun math-is-multiple (expr &optional always
)
1425 (or (if (eq (car-safe expr
) '*)
1426 (if (Math-objectp (nth 1 expr
))
1427 (list (nth 1 expr
) (nth 2 expr
)))
1428 (if (eq (car-safe expr
) '/)
1429 (if (and (Math-objectp (nth 1 expr
))
1430 (not (math-equal-int (nth 1 expr
) 1)))
1431 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1432 (if (Math-objectp (nth 2 expr
))
1433 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1434 (let ((res (math-is-multiple (nth 1 expr
))))
1437 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1438 (setq res
(math-is-multiple (nth 2 expr
)))
1440 (list (math-div 1 (car res
))
1441 (math-div (nth 1 expr
)
1442 (nth 2 (nth 2 expr
)))))))))
1443 (if (eq (car-safe expr
) 'neg
)
1444 (list -
1 (nth 1 expr
)))))
1445 (if (Math-objvecp expr
)
1451 (defun calcFunc-lin (expr &optional var
)
1453 (let ((res (math-linear-in expr var t
)))
1454 (or res
(math-reject-arg expr
"Linear term expected"))
1455 (list 'vec
(car res
) (nth 1 res
) var
))
1456 (let ((res (math-is-linear expr t
)))
1457 (or res
(math-reject-arg expr
"Linear term expected"))
1460 (defun calcFunc-linnt (expr &optional var
)
1462 (let ((res (math-linear-in expr var
)))
1463 (or res
(math-reject-arg expr
"Linear term expected"))
1464 (list 'vec
(car res
) (nth 1 res
) var
))
1465 (let ((res (math-is-linear expr
)))
1466 (or res
(math-reject-arg expr
"Linear term expected"))
1469 (defun calcFunc-islin (expr &optional var
)
1470 (if (and (Math-objvecp expr
) (not var
))
1472 (calcFunc-lin expr var
)
1475 (defun calcFunc-islinnt (expr &optional var
)
1476 (if (Math-objvecp expr
)
1478 (calcFunc-linnt expr var
)
1484 ;;; Simple operations on expressions.
1486 ;;; Return number of occurrences of thing in expr, or nil if none.
1487 (defun math-expr-contains-count (expr thing
)
1488 (cond ((equal expr thing
) 1)
1489 ((Math-primp expr
) nil
)
1492 (while (setq expr
(cdr expr
))
1493 (setq num
(+ num
(or (math-expr-contains-count
1494 (car expr
) thing
) 0))))
1498 (defun math-expr-contains (expr thing
)
1499 (cond ((equal expr thing
) 1)
1500 ((Math-primp expr
) nil
)
1502 (while (and (setq expr
(cdr expr
))
1503 (not (math-expr-contains (car expr
) thing
))))
1506 ;;; Return non-nil if any variable of thing occurs in expr.
1507 (defun math-expr-depends (expr thing
)
1508 (if (Math-primp thing
)
1509 (and (eq (car-safe thing
) 'var
)
1510 (math-expr-contains expr thing
))
1511 (while (and (setq thing
(cdr thing
))
1512 (not (math-expr-depends expr
(car thing
)))))
1515 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1517 ;; The variables math-expr-subst-old and math-expr-subst-new are local
1518 ;; for math-expr-subst, but used by math-expr-subst-rec.
1519 (defvar math-expr-subst-old
)
1520 (defvar math-expr-subst-new
)
1522 (defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new
)
1523 (math-expr-subst-rec expr
))
1525 (defalias 'calcFunc-subst
'math-expr-subst
)
1527 (defun math-expr-subst-rec (expr)
1528 (cond ((equal expr math-expr-subst-old
) math-expr-subst-new
)
1529 ((Math-primp expr
) expr
)
1530 ((memq (car expr
) '(calcFunc-deriv
1532 (if (= (length expr
) 2)
1533 (if (equal (nth 1 expr
) math-expr-subst-old
)
1534 (append expr
(list math-expr-subst-new
))
1536 (list (car expr
) (nth 1 expr
)
1537 (math-expr-subst-rec (nth 2 expr
)))))
1540 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1542 ;;; Various measures of the size of an expression.
1543 (defun math-expr-weight (expr)
1544 (if (Math-primp expr
)
1547 (while (setq expr
(cdr expr
))
1548 (setq w
(+ w
(math-expr-weight (car expr
)))))
1551 (defun math-expr-height (expr)
1552 (if (Math-primp expr
)
1555 (while (setq expr
(cdr expr
))
1556 (setq h
(max h
(math-expr-height (car expr
)))))
1562 ;;; Polynomial operations (to support the integrator and solve-for).
1564 (defun calcFunc-collect (expr base
)
1565 (let ((p (math-is-polynomial expr base
50 t
)))
1567 (math-normalize ; fix selection bug
1568 (math-build-polynomial-expr p base
))
1571 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1572 ;;; else return nil if not in polynomial form. If "loose" (math-is-poly-loose),
1573 ;;; coefficients may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1575 ;; The variables math-is-poly-degree and math-is-poly-loose are local to
1576 ;; math-is-polynomial, but are used by math-is-poly-rec
1577 (defvar math-is-poly-degree
)
1578 (defvar math-is-poly-loose
)
1580 (defun math-is-polynomial (expr var
&optional math-is-poly-degree math-is-poly-loose
)
1581 (let* ((math-poly-base-variable (if math-is-poly-loose
1582 (if (eq math-is-poly-loose
'gen
) var
'(var XXX XXX
))
1583 math-poly-base-variable
))
1584 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1585 (and (or (null math-is-poly-degree
)
1586 (<= (length poly
) (1+ math-is-poly-degree
)))
1589 (defun math-is-poly-rec (expr negpow
)
1591 (or (cond ((or (equal expr var
)
1592 (eq (car-safe expr
) '^
))
1595 (or (equal expr var
)
1596 (setq pow
(nth 2 expr
)
1598 (or (eq math-poly-mult-powers
1)
1599 (setq pow
(let ((m (math-is-multiple pow
1)))
1600 (and (eq (car-safe (car m
)) 'cplx
)
1601 (Math-zerop (nth 1 (car m
)))
1602 (setq m
(list (nth 2 (car m
))
1605 (and (if math-poly-mult-powers
1606 (equal math-poly-mult-powers
1608 (setq math-poly-mult-powers
(nth 1 m
)))
1609 (or (equal expr var
)
1610 (eq math-poly-mult-powers
1))
1614 (setq pow
(math-to-simple-fraction pow
))
1615 (and (eq (car-safe pow
) 'frac
)
1616 math-poly-frac-powers
1618 (setq math-poly-frac-powers
1619 (calcFunc-lcm math-poly-frac-powers
1621 (or (memq math-poly-frac-powers
'(1 nil
))
1622 (setq pow
(math-mul pow math-poly-frac-powers
)))
1628 (let ((p1 (if (equal expr var
)
1630 (math-is-poly-rec expr nil
)))
1634 (or (null math-is-poly-degree
)
1635 (<= (* (1- (length p1
)) n
) math-is-poly-degree
))
1638 (setq accum
(math-poly-mul accum p1
)
1642 (math-is-poly-rec expr nil
)
1643 (setq math-poly-neg-powers
1644 (cons (math-pow expr
(- pow
))
1645 math-poly-neg-powers
))
1646 (list (list '^ expr pow
))))))))
1647 ((Math-objectp expr
)
1649 ((memq (car expr
) '(+ -
))
1650 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1652 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1654 (math-poly-mix p1
1 p2
1655 (if (eq (car expr
) '+) 1 -
1)))))))
1656 ((eq (car expr
) 'neg
)
1657 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1659 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1661 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1663 (or (null math-is-poly-degree
)
1664 (<= (- (+ (length p1
) (length p2
)) 2)
1665 math-is-poly-degree
))
1666 (math-poly-mul p1 p2
))))))
1668 (and (or (not (math-poly-depends (nth 2 expr
) var
))
1670 (math-is-poly-rec (nth 2 expr
) nil
)
1671 (setq math-poly-neg-powers
1672 (cons (nth 2 expr
) math-poly-neg-powers
))))
1673 (not (Math-zerop (nth 2 expr
)))
1674 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1675 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1677 ((and (eq (car expr
) 'calcFunc-exp
)
1678 (equal var
'(var e var-e
)))
1679 (math-is-poly-rec (list '^ var
(nth 1 expr
)) negpow
))
1680 ((and (eq (car expr
) 'calcFunc-sqrt
)
1681 math-poly-frac-powers
)
1682 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1684 (and (or (not (math-poly-depends expr var
))
1686 (not (eq (car expr
) 'vec
))
1689 ;;; Check if expr is a polynomial in var; if so, return its degree.
1690 (defun math-polynomial-p (expr var
)
1691 (cond ((equal expr var
) 1)
1692 ((Math-primp expr
) 0)
1693 ((memq (car expr
) '(+ -
))
1694 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1696 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1699 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1701 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1703 ((eq (car expr
) 'neg
)
1704 (math-polynomial-p (nth 1 expr
) var
))
1705 ((and (eq (car expr
) '/)
1706 (not (math-poly-depends (nth 2 expr
) var
)))
1707 (math-polynomial-p (nth 1 expr
) var
))
1708 ((and (eq (car expr
) '^
)
1709 (natnump (nth 2 expr
)))
1710 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1711 (and p1
(* p1
(nth 2 expr
)))))
1712 ((math-poly-depends expr var
) nil
)
1715 (defun math-poly-depends (expr var
)
1716 (if math-poly-base-variable
1717 (math-expr-contains expr math-poly-base-variable
)
1718 (math-expr-depends expr var
)))
1720 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1721 ;; The variables math-poly-base-const-ok and math-poly-base-pred are
1722 ;; local to math-polynomial-base, but are used by math-polynomial-base-rec.
1723 (defvar math-poly-base-const-ok
)
1724 (defvar math-poly-base-pred
)
1726 ;; The variable math-poly-base-top-expr is local to math-polynomial-base,
1727 ;; but is used by math-polynomial-p1 in calc-poly.el, which is called
1728 ;; by math-polynomial-base.
1730 (defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred
)
1731 (or math-poly-base-pred
1732 (setq math-poly-base-pred
(function (lambda (base) (math-polynomial-p
1733 math-poly-base-top-expr base
)))))
1734 (or (let ((math-poly-base-const-ok nil
))
1735 (math-polynomial-base-rec math-poly-base-top-expr
))
1736 (let ((math-poly-base-const-ok t
))
1737 (math-polynomial-base-rec math-poly-base-top-expr
))))
1739 (defun math-polynomial-base-rec (mpb-expr)
1740 (and (not (Math-objvecp mpb-expr
))
1741 (or (and (memq (car mpb-expr
) '(+ -
*))
1742 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1743 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1744 (and (memq (car mpb-expr
) '(/ neg
))
1745 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1746 (and (eq (car mpb-expr
) '^
)
1747 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1748 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1749 (math-polynomial-base-rec '(var e var-e
)))
1750 (and (or math-poly-base-const-ok
(math-expr-contains-vars mpb-expr
))
1751 (funcall math-poly-base-pred mpb-expr
)
1754 ;;; Return non-nil if expr refers to any variables.
1755 (defun math-expr-contains-vars (expr)
1756 (or (eq (car-safe expr
) 'var
)
1757 (and (not (Math-primp expr
))
1759 (while (and (setq expr
(cdr expr
))
1760 (not (math-expr-contains-vars (car expr
)))))
1763 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1764 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1765 (defun math-poly-simplify (p)
1767 (if (Math-zerop (nth (1- (length p
)) p
))
1768 (let ((pp (copy-sequence p
)))
1769 (while (and (cdr pp
)
1770 (Math-zerop (nth (1- (length pp
)) pp
)))
1771 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1775 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1776 ;;; coefficients ac, bc. Result may be unsimplified.
1777 (defun math-poly-mix (a ac b bc
)
1779 (cons (math-add (math-mul (or (car a
) 0) ac
)
1780 (math-mul (or (car b
) 0) bc
))
1781 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1783 (defun math-poly-zerop (a)
1785 (and (null (cdr a
)) (Math-zerop (car a
)))))
1787 ;;; Multiply two polynomials in list form.
1788 (defun math-poly-mul (a b
)
1790 (math-poly-mix b
(car a
)
1791 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1793 ;;; Build an expression from a polynomial list.
1794 (defun math-build-polynomial-expr (p var
)
1796 (if (Math-numberp var
)
1797 (math-with-extra-prec 1
1798 (let* ((rp (reverse p
))
1800 (while (setq rp
(cdr rp
))
1801 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1803 (let* ((rp (reverse p
))
1804 (n (1- (length rp
)))
1805 (accum (math-mul (car rp
) (math-pow var n
)))
1807 (while (setq rp
(cdr rp
))
1809 (or (math-zerop (car rp
))
1810 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1812 (math-mul (if (math-looks-negp (car rp
))
1815 (math-pow var n
))))))
1820 (defun math-to-simple-fraction (f)
1821 (or (and (eq (car-safe f
) 'float
)
1822 (or (and (>= (nth 2 f
) 0)
1823 (math-scale-int (nth 1 f
) (nth 2 f
)))
1824 (and (integerp (nth 1 f
))
1827 (math-make-frac (nth 1 f
)
1828 (math-scale-int 1 (- (nth 2 f
)))))))
1833 ;;; arch-tag: 52e7dcdf-9688-464d-a02b-4bbe789348d0
1834 ;;; calc-alg.el ends here
HCoop / bpt / emacs.git / blob