1 ;;; calc-alg.el --- algebraic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Colin Walters <walters@debian.org>
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.
34 (defun calc-Need-calc-alg () nil
)
38 (defun calc-alg-evaluate (arg)
41 (calc-with-default-simplification
42 (let ((math-simplify-only nil
))
43 (calc-modify-simplify-mode arg
)
44 (calc-enter-result 1 "dsmp" (calc-top 1))))))
46 (defun calc-modify-simplify-mode (arg)
47 (if (= (math-abs arg
) 2)
48 (setq calc-simplify-mode
'alg
)
49 (if (>= (math-abs arg
) 3)
50 (setq calc-simplify-mode
'ext
)))
52 (setq calc-simplify-mode
(list calc-simplify-mode
))))
54 (defun calc-simplify ()
57 (calc-with-default-simplification
58 (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))))
60 (defun calc-simplify-extended ()
63 (calc-with-default-simplification
64 (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))))
66 (defun calc-expand-formula (arg)
69 (calc-with-default-simplification
70 (let ((math-simplify-only nil
))
71 (calc-modify-simplify-mode arg
)
72 (calc-enter-result 1 "expf"
74 (let ((math-expand-formulas t
))
76 (let ((top (calc-top-n 1)))
77 (or (math-expand-formula top
)
80 (defun calc-factor (arg)
83 (calc-unary-op "fctr" (if (calc-is-hyperbolic)
84 'calcFunc-factors
'calcFunc-factor
)
87 (defun calc-expand (n)
90 (calc-enter-result 1 "expa"
91 (append (list 'calcFunc-expand
93 (and n
(list (prefix-numeric-value n
)))))))
95 (defun calc-collect (&optional var
)
96 (interactive "sCollect terms involving: ")
98 (if (or (equal var
"") (equal var
"$") (null var
))
99 (calc-enter-result 2 "clct" (cons 'calcFunc-collect
100 (calc-top-list-n 2)))
101 (let ((var (math-read-expr var
)))
102 (if (eq (car-safe var
) 'error
)
103 (error "Bad format in expression: %s" (nth 1 var
)))
104 (calc-enter-result 1 "clct" (list 'calcFunc-collect
108 (defun calc-apart (arg)
111 (calc-unary-op "aprt" 'calcFunc-apart arg
)))
113 (defun calc-normalize-rat (arg)
116 (calc-unary-op "nrat" 'calcFunc-nrat arg
)))
118 (defun calc-poly-gcd (arg)
121 (calc-binary-op "pgcd" 'calcFunc-pgcd arg
)))
123 (defun calc-poly-div (arg)
126 (setq calc-poly-div-remainder nil
)
127 (calc-binary-op "pdiv" 'calcFunc-pdiv arg
)
128 (if (and calc-poly-div-remainder
(null arg
))
130 (calc-clear-command-flag 'clear-message
)
131 (calc-record calc-poly-div-remainder
"prem")
132 (if (not (Math-zerop calc-poly-div-remainder
))
133 (message "(Remainder was %s)"
134 (math-format-flat-expr calc-poly-div-remainder
0))
135 (message "(No remainder)"))))))
137 (defun calc-poly-rem (arg)
140 (calc-binary-op "prem" 'calcFunc-prem arg
)))
142 (defun calc-poly-div-rem (arg)
145 (if (calc-is-hyperbolic)
146 (calc-binary-op "pdvr" 'calcFunc-pdivide arg
)
147 (calc-binary-op "pdvr" 'calcFunc-pdivrem arg
))))
149 (defun calc-substitute (&optional oldname newname
)
150 (interactive "sSubstitute old: ")
152 (let (old new
(num 1) expr
)
153 (if (or (equal oldname
"") (equal oldname
"$") (null oldname
))
154 (setq new
(calc-top-n 1)
159 (progn (calc-unread-command ?\C-a
)
160 (setq newname
(read-string (concat "Substitute old: "
164 (if (or (equal newname
"") (equal newname
"$") (null newname
))
165 (setq new
(calc-top-n 1)
168 (setq new
(if (stringp newname
) (math-read-expr newname
) newname
))
169 (if (eq (car-safe new
) 'error
)
170 (error "Bad format in expression: %s" (nth 1 new
)))
171 (setq expr
(calc-top-n 1)))
172 (setq old
(if (stringp oldname
) (math-read-expr oldname
) oldname
))
173 (if (eq (car-safe old
) 'error
)
174 (error "Bad format in expression: %s" (nth 1 old
)))
175 (or (math-expr-contains expr old
)
176 (error "No occurrences found")))
177 (calc-enter-result num
"sbst" (math-expr-subst expr old new
)))))
180 (defun calc-has-rules (name)
181 (setq name
(calc-var-value name
))
183 (memq (car name
) '(vec calcFunc-assign calcFunc-condition
))
186 (defun math-recompile-eval-rules ()
187 (setq math-eval-rules-cache
(and (calc-has-rules 'var-EvalRules
)
188 (math-compile-rewrites
189 '(var EvalRules var-EvalRules
)))
190 math-eval-rules-cache-other
(assq nil math-eval-rules-cache
)
191 math-eval-rules-cache-tag
(calc-var-value 'var-EvalRules
)))
194 ;;; Try to expand a formula according to its definition.
195 (defun math-expand-formula (expr)
198 (or (get (car expr
) 'calc-user-defn
)
199 (get (car expr
) 'math-expandable
))
200 (let ((res (let ((math-expand-formulas t
))
201 (apply (car expr
) (cdr expr
)))))
202 (and (not (eq (car-safe res
) (car expr
)))
208 ;;; True if A comes before B in a canonical ordering of expressions. [P X X]
209 (defun math-beforep (a b
) ; [Public]
210 (cond ((and (Math-realp a
) (Math-realp b
))
211 (let ((comp (math-compare a b
)))
215 (> (length (memq (car-safe a
)
216 '(bigneg nil bigpos frac float
)))
217 (length (memq (car-safe b
)
218 '(bigneg nil bigpos frac float
))))))))
219 ((equal b
'(neg (var inf var-inf
))) nil
)
220 ((equal a
'(neg (var inf var-inf
))) t
)
221 ((equal a
'(var inf var-inf
)) nil
)
222 ((equal b
'(var inf var-inf
)) t
)
224 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
))
225 (if (or (math-beforep a
(nth 2 b
)) (Math-equal a
(nth 2 b
)))
230 (if (and (eq (car-safe a
) 'intv
) (math-intv-constp a
))
231 (if (math-beforep (nth 2 a
) b
)
235 ((and (eq (car a
) 'intv
) (eq (car b
) 'intv
)
236 (math-intv-constp a
) (math-intv-constp b
))
237 (let ((comp (math-compare (nth 2 a
) (nth 2 b
))))
238 (cond ((eq comp -
1) t
)
240 ((and (memq (nth 1 a
) '(2 3)) (memq (nth 1 b
) '(0 1))) t
)
241 ((and (memq (nth 1 a
) '(0 1)) (memq (nth 1 b
) '(2 3))) nil
)
242 ((eq (setq comp
(math-compare (nth 3 a
) (nth 3 b
))) -
1) t
)
244 ((and (memq (nth 1 a
) '(0 2)) (memq (nth 1 b
) '(1 3))) t
)
246 ((not (eq (not (Math-objectp a
)) (not (Math-objectp b
))))
249 (if (eq (car b
) 'var
)
250 (string-lessp (symbol-name (nth 1 a
)) (symbol-name (nth 1 b
)))
251 (not (Math-numberp b
))))
252 ((eq (car b
) 'var
) (Math-numberp a
))
253 ((eq (car a
) (car b
))
254 (while (and (setq a
(cdr a
) b
(cdr b
)) a
255 (equal (car a
) (car b
))))
258 (math-beforep (car a
) (car b
)))))
259 (t (string-lessp (symbol-name (car a
)) (symbol-name (car b
))))))
262 (defsubst math-simplify-extended
(a)
263 (let ((math-living-dangerously t
))
266 (defalias 'calcFunc-esimplify
'math-simplify-extended
)
268 (defun math-simplify (top-expr)
269 (let ((math-simplifying t
)
270 (top-only (consp calc-simplify-mode
))
271 (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules
)
272 '((var AlgSimpRules var-AlgSimpRules
)))
273 (and math-living-dangerously
274 (calc-has-rules 'var-ExtSimpRules
)
275 '((var ExtSimpRules var-ExtSimpRules
)))
276 (and math-simplifying-units
277 (calc-has-rules 'var-UnitSimpRules
)
278 '((var UnitSimpRules var-UnitSimpRules
)))
279 (and math-integrating
280 (calc-has-rules 'var-IntegSimpRules
)
281 '((var IntegSimpRules var-IntegSimpRules
)))))
284 (let ((r simp-rules
))
285 (setq res
(math-simplify-step (math-normalize top-expr
))
286 calc-simplify-mode
'(nil)
287 top-expr
(math-normalize res
))
289 (setq top-expr
(math-rewrite top-expr
(car r
)
290 '(neg (var inf var-inf
)))
292 (calc-with-default-simplification
293 (while (let ((r simp-rules
))
294 (setq res
(math-normalize top-expr
))
296 (setq res
(math-rewrite res
(car r
))
298 (not (equal top-expr
(setq res
(math-simplify-step res
)))))
299 (setq top-expr res
)))))
302 (defalias 'calcFunc-simplify
'math-simplify
)
304 ;;; The following has a "bug" in that if any recursive simplifications
305 ;;; occur only the first handler will be tried; this doesn't really
306 ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
307 (defun math-simplify-step (a)
310 (let ((aa (if (or top-only
311 (memq (car a
) '(calcFunc-quote calcFunc-condition
314 (cons (car a
) (mapcar 'math-simplify-step
(cdr a
))))))
315 (and (symbolp (car aa
))
316 (let ((handler (get (car aa
) 'math-simplify
)))
319 (equal (setq aa
(or (funcall (car handler
) aa
)
322 (setq handler
(cdr handler
))))))
326 ;; Placeholder, to synchronize autoloading.
327 (defun math-need-std-simps ()
330 (math-defsimplify (+ -
)
331 (math-simplify-plus))
333 (defun math-simplify-plus ()
334 (cond ((and (memq (car-safe (nth 1 expr
)) '(+ -
))
335 (Math-numberp (nth 2 (nth 1 expr
)))
336 (not (Math-numberp (nth 2 expr
))))
337 (let ((x (nth 2 expr
))
339 (setcar (cdr (cdr expr
)) (nth 2 (nth 1 expr
)))
340 (setcar expr
(car (nth 1 expr
)))
341 (setcar (cdr (cdr (nth 1 expr
))) x
)
342 (setcar (nth 1 expr
) op
)))
343 ((and (eq (car expr
) '+)
344 (Math-numberp (nth 1 expr
))
345 (not (Math-numberp (nth 2 expr
))))
346 (let ((x (nth 2 expr
)))
347 (setcar (cdr (cdr expr
)) (nth 1 expr
))
348 (setcar (cdr expr
) x
))))
351 (while (memq (car-safe (setq aaa
(nth 1 aa
))) '(+ -
))
352 (if (setq temp
(math-combine-sum (nth 2 aaa
) (nth 2 expr
)
353 (eq (car aaa
) '-
) (eq (car expr
) '-
) t
))
355 (setcar (cdr (cdr expr
)) temp
)
357 (setcar (cdr (cdr aaa
)) 0)))
358 (setq aa
(nth 1 aa
)))
359 (if (setq temp
(math-combine-sum aaa
(nth 2 expr
)
360 nil
(eq (car expr
) '-
) t
))
362 (setcar (cdr (cdr expr
)) temp
)
364 (setcar (cdr aa
) 0)))
368 (math-simplify-times))
370 (defun math-simplify-times ()
371 (if (eq (car-safe (nth 2 expr
)) '*)
372 (and (math-beforep (nth 1 (nth 2 expr
)) (nth 1 expr
))
373 (or (math-known-scalarp (nth 1 expr
) t
)
374 (math-known-scalarp (nth 1 (nth 2 expr
)) t
))
375 (let ((x (nth 1 expr
)))
376 (setcar (cdr expr
) (nth 1 (nth 2 expr
)))
377 (setcar (cdr (nth 2 expr
)) x
)))
378 (and (math-beforep (nth 2 expr
) (nth 1 expr
))
379 (or (math-known-scalarp (nth 1 expr
) t
)
380 (math-known-scalarp (nth 2 expr
) t
))
381 (let ((x (nth 2 expr
)))
382 (setcar (cdr (cdr expr
)) (nth 1 expr
))
383 (setcar (cdr expr
) x
))))
386 (safe t
) (scalar (math-known-scalarp (nth 1 expr
))))
387 (if (and (Math-ratp (nth 1 expr
))
388 (setq temp
(math-common-constant-factor (nth 2 expr
))))
390 (setcar (cdr (cdr expr
))
391 (math-cancel-common-factor (nth 2 expr
) temp
))
392 (setcar (cdr expr
) (math-mul (nth 1 expr
) temp
))))
393 (while (and (eq (car-safe (setq aaa
(nth 2 aa
))) '*)
395 (if (setq temp
(math-combine-prod (nth 1 expr
) (nth 1 aaa
) nil nil t
))
397 (setcar (cdr expr
) temp
)
398 (setcar (cdr aaa
) 1)))
399 (setq safe
(or scalar
(math-known-scalarp (nth 1 aaa
) t
))
401 (if (and (setq temp
(math-combine-prod aaa
(nth 1 expr
) nil nil t
))
404 (setcar (cdr expr
) temp
)
405 (setcar (cdr (cdr aa
)) 1)))
406 (if (and (eq (car-safe (nth 1 expr
)) 'frac
)
407 (memq (nth 1 (nth 1 expr
)) '(1 -
1)))
408 (math-div (math-mul (nth 2 expr
) (nth 1 (nth 1 expr
)))
409 (nth 2 (nth 1 expr
)))
413 (math-simplify-divide))
415 (defun math-simplify-divide ()
416 (let ((np (cdr expr
))
418 (nn (and (or (eq (car expr
) '/) (not (Math-realp (nth 2 expr
))))
419 (math-common-constant-factor (nth 2 expr
))))
423 (setq n
(and (or (eq (car expr
) '/) (not (Math-realp (nth 1 expr
))))
424 (math-common-constant-factor (nth 1 expr
))))
425 (if (and (eq (car-safe nn
) 'frac
) (eq (nth 1 nn
) 1) (not n
))
427 (setcar (cdr expr
) (math-mul (nth 2 nn
) (nth 1 expr
)))
428 (setcar (cdr (cdr expr
))
429 (math-cancel-common-factor (nth 2 expr
) nn
))
430 (if (and (math-negp nn
)
431 (setq op
(assq (car expr
) calc-tweak-eqn-table
)))
432 (setcar expr
(nth 1 op
))))
433 (if (and n
(not (eq (setq n
(math-frac-gcd n nn
)) 1)))
436 (math-cancel-common-factor (nth 1 expr
) n
))
437 (setcar (cdr (cdr expr
))
438 (math-cancel-common-factor (nth 2 expr
) n
))
439 (if (and (math-negp n
)
440 (setq op
(assq (car expr
) calc-tweak-eqn-table
)))
441 (setcar expr
(nth 1 op
))))))))
442 (if (and (eq (car-safe (car np
)) '/)
443 (math-known-scalarp (nth 2 expr
) t
))
445 (setq np
(cdr (nth 1 expr
)))
446 (while (eq (car-safe (setq n
(car np
))) '*)
447 (and (math-known-scalarp (nth 2 n
) t
)
448 (math-simplify-divisor (cdr n
) (cdr (cdr expr
)) nil t
))
449 (setq np
(cdr (cdr n
))))
450 (math-simplify-divisor np
(cdr (cdr expr
)) nil t
)
452 np
(cdr (cdr (nth 1 expr
))))))
453 (while (eq (car-safe (setq n
(car np
))) '*)
454 (and (math-known-scalarp (nth 2 n
) t
)
455 (math-simplify-divisor (cdr n
) (cdr (cdr expr
)) nover t
))
456 (setq np
(cdr (cdr n
))))
457 (math-simplify-divisor np
(cdr (cdr expr
)) nover t
)
460 (defun math-simplify-divisor (np dp nover dover
)
461 (cond ((eq (car-safe (car dp
)) '/)
462 (math-simplify-divisor np
(cdr (car dp
)) nover dover
)
463 (and (math-known-scalarp (nth 1 (car dp
)) t
)
464 (math-simplify-divisor np
(cdr (cdr (car dp
)))
466 ((or (or (eq (car expr
) '/)
467 (let ((signs (math-possible-signs (car np
))))
468 (or (memq signs
'(1 4))
469 (and (memq (car expr
) '(calcFunc-eq calcFunc-neq
))
471 math-living-dangerously
)))
472 (math-numberp (car np
)))
475 (safe t
) (scalar (math-known-scalarp n
)))
476 (while (and (eq (car-safe (setq d
(car dp
))) '*)
478 (math-simplify-one-divisor np
(cdr d
))
479 (setq safe
(or scalar
(math-known-scalarp (nth 1 d
) t
))
482 (math-simplify-one-divisor np dp
))))))
484 (defun math-simplify-one-divisor (np dp
)
485 (if (setq temp
(math-combine-prod (car np
) (car dp
) nover dover t
))
487 (and (not (memq (car expr
) '(/ calcFunc-eq calcFunc-neq
)))
488 (math-known-negp (car dp
))
489 (setq op
(assq (car expr
) calc-tweak-eqn-table
))
490 (setcar expr
(nth 1 op
)))
491 (setcar np
(if nover
(math-div 1 temp
) temp
))
493 (and dover
(not nover
) (eq (car expr
) '/)
494 (eq (car-safe (car dp
)) 'calcFunc-sqrt
)
495 (Math-integerp (nth 1 (car dp
)))
497 (setcar np
(math-mul (car np
)
498 (list 'calcFunc-sqrt
(nth 1 (car dp
)))))
499 (setcar dp
(nth 1 (car dp
)))))))
501 (defun math-common-constant-factor (expr)
502 (if (Math-realp expr
)
504 (and (not (memq expr
'(0 1 -
1)))
506 (if (math-ratp (setq expr
(math-to-simple-fraction expr
)))
507 (math-common-constant-factor expr
)))
508 (if (memq (car expr
) '(+ - cplx sdev
))
509 (let ((f1 (math-common-constant-factor (nth 1 expr
)))
510 (f2 (math-common-constant-factor (nth 2 expr
))))
512 (not (eq (setq f1
(math-frac-gcd f1 f2
)) 1))
514 (if (memq (car expr
) '(* polar
))
515 (math-common-constant-factor (nth 1 expr
))
516 (if (eq (car expr
) '/)
517 (or (math-common-constant-factor (nth 1 expr
))
518 (and (Math-integerp (nth 2 expr
))
519 (list 'frac
1 (math-abs (nth 2 expr
))))))))))
521 (defun math-cancel-common-factor (expr val
)
522 (if (memq (car-safe expr
) '(+ - cplx sdev
))
524 (setcar (cdr expr
) (math-cancel-common-factor (nth 1 expr
) val
))
525 (setcar (cdr (cdr expr
)) (math-cancel-common-factor (nth 2 expr
) val
))
527 (if (eq (car-safe expr
) '*)
528 (math-mul (math-cancel-common-factor (nth 1 expr
) val
) (nth 2 expr
))
529 (math-div expr val
))))
531 (defun math-frac-gcd (a b
)
536 (if (and (Math-integerp a
)
539 (and (Math-integerp a
) (setq a
(list 'frac a
1)))
540 (and (Math-integerp b
) (setq b
(list 'frac b
1)))
541 (math-make-frac (math-gcd (nth 1 a
) (nth 1 b
))
542 (math-gcd (nth 2 a
) (nth 2 b
)))))))
547 (defun math-simplify-mod ()
548 (and (Math-realp (nth 2 expr
))
549 (Math-posp (nth 2 expr
))
550 (let ((lin (math-is-linear (nth 1 expr
)))
553 (or (math-negp (car lin
))
554 (not (Math-lessp (car lin
) (nth 2 expr
))))
557 (math-mul (nth 1 lin
) (nth 2 lin
))
558 (math-mod (car lin
) (nth 2 expr
)))
561 (not (math-equal-int (nth 1 lin
) 1))
562 (math-num-integerp (nth 1 lin
))
563 (math-num-integerp (nth 2 expr
))
564 (setq t1
(calcFunc-gcd (nth 1 lin
) (nth 2 expr
)))
565 (not (math-equal-int t1
1))
570 (math-mul (math-div (nth 1 lin
) t1
)
572 (let ((calc-prefer-frac t
))
573 (math-div (car lin
) t1
)))
574 (math-div (nth 2 expr
) t1
))))
575 (and (math-equal-int (nth 2 expr
) 1)
576 (math-known-integerp (if lin
577 (math-mul (nth 1 lin
) (nth 2 lin
))
579 (if lin
(math-mod (car lin
) 1) 0))))))
581 (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
582 calcFunc-gt calcFunc-leq calcFunc-geq
)
583 (if (= (length expr
) 3)
584 (math-simplify-ineq)))
586 (defun math-simplify-ineq ()
587 (let ((np (cdr expr
))
589 (while (memq (car-safe (setq n
(car np
))) '(+ -
))
590 (math-simplify-add-term (cdr (cdr n
)) (cdr (cdr expr
))
593 (math-simplify-add-term np
(cdr (cdr expr
)) nil
(eq np
(cdr expr
)))
594 (math-simplify-divide)
595 (let ((signs (math-possible-signs (cons '-
(cdr expr
)))))
596 (or (cond ((eq (car expr
) 'calcFunc-eq
)
597 (or (and (eq signs
2) 1)
598 (and (memq signs
'(1 4 5)) 0)))
599 ((eq (car expr
) 'calcFunc-neq
)
600 (or (and (eq signs
2) 0)
601 (and (memq signs
'(1 4 5)) 1)))
602 ((eq (car expr
) 'calcFunc-lt
)
603 (or (and (eq signs
1) 1)
604 (and (memq signs
'(2 4 6)) 0)))
605 ((eq (car expr
) 'calcFunc-gt
)
606 (or (and (eq signs
4) 1)
607 (and (memq signs
'(1 2 3)) 0)))
608 ((eq (car expr
) 'calcFunc-leq
)
609 (or (and (eq signs
4) 0)
610 (and (memq signs
'(1 2 3)) 1)))
611 ((eq (car expr
) 'calcFunc-geq
)
612 (or (and (eq signs
1) 0)
613 (and (memq signs
'(2 4 6)) 1))))
616 (defun math-simplify-add-term (np dp minus lplain
)
617 (or (math-vectorp (car np
))
620 (while (memq (car-safe (setq n
(car np
) d
(car dp
))) '(+ -
))
622 (if (setq temp
(math-combine-sum n
(nth 2 d
)
623 minus
(eq (car d
) '+) t
))
624 (if (or lplain
(eq (math-looks-negp temp
) minus
))
626 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
627 (setcar (cdr (cdr d
)) 0))
630 (setcar (cdr (cdr d
)) (setq n
(if (eq (car d
) '+)
634 (if (setq temp
(math-combine-sum n d minus t t
))
637 (eq (math-looks-negp temp
) minus
)))
639 (setcar np
(setq n
(if minus
(math-neg temp
) temp
)))
643 (setcar dp
(setq n
(math-neg temp
)))))))))
645 (math-defsimplify calcFunc-sin
646 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsin
)
647 (nth 1 (nth 1 expr
)))
648 (and (math-looks-negp (nth 1 expr
))
649 (math-neg (list 'calcFunc-sin
(math-neg (nth 1 expr
)))))
650 (and (eq calc-angle-mode
'rad
)
651 (let ((n (math-linear-in (nth 1 expr
) '(var pi var-pi
))))
653 (math-known-sin (car n
) (nth 1 n
) 120 0))))
654 (and (eq calc-angle-mode
'deg
)
655 (let ((n (math-integer-plus (nth 1 expr
))))
657 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 0))))
658 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccos
)
659 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr (nth 1 (nth 1 expr
))))))
660 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctan
)
661 (math-div (nth 1 (nth 1 expr
))
663 (math-add 1 (math-sqr (nth 1 (nth 1 expr
)))))))
664 (let ((m (math-should-expand-trig (nth 1 expr
))))
665 (and m
(integerp (car m
))
666 (let ((n (car m
)) (a (nth 1 m
)))
668 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
669 (list 'calcFunc-cos a
))
670 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
671 (list 'calcFunc-sin a
))))))))
673 (math-defsimplify calcFunc-cos
674 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccos
)
675 (nth 1 (nth 1 expr
)))
676 (and (math-looks-negp (nth 1 expr
))
677 (list 'calcFunc-cos
(math-neg (nth 1 expr
))))
678 (and (eq calc-angle-mode
'rad
)
679 (let ((n (math-linear-in (nth 1 expr
) '(var pi var-pi
))))
681 (math-known-sin (car n
) (nth 1 n
) 120 300))))
682 (and (eq calc-angle-mode
'deg
)
683 (let ((n (math-integer-plus (nth 1 expr
))))
685 (math-known-sin (car n
) (nth 1 n
) '(frac 2 3) 300))))
686 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsin
)
687 (list 'calcFunc-sqrt
(math-sub 1 (math-sqr (nth 1 (nth 1 expr
))))))
688 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctan
)
691 (math-add 1 (math-sqr (nth 1 (nth 1 expr
)))))))
692 (let ((m (math-should-expand-trig (nth 1 expr
))))
693 (and m
(integerp (car m
))
694 (let ((n (car m
)) (a (nth 1 m
)))
696 (list '* (list 'calcFunc-cos
(list '* (1- n
) a
))
697 (list 'calcFunc-cos a
))
698 (list '* (list 'calcFunc-sin
(list '* (1- n
) a
))
699 (list 'calcFunc-sin a
))))))))
701 (defun math-should-expand-trig (x &optional hyperbolic
)
702 (let ((m (math-is-multiple x
)))
703 (and math-living-dangerously
704 m
(or (and (integerp (car m
)) (> (car m
) 1))
705 (equal (car m
) '(frac 1 2)))
707 (memq (car-safe (nth 1 m
))
709 '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
)
710 '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan
)))
711 (and (eq (car-safe (nth 1 m
)) 'calcFunc-ln
)
712 (eq hyperbolic
'exp
)))
715 (defun math-known-sin (plus n mul off
)
716 (setq n
(math-mul n mul
))
717 (and (math-num-integerp n
)
718 (setq n
(math-mod (math-add (math-trunc n
) off
) 240))
720 (and (setq n
(math-known-sin plus
(- n
120) 1 0))
724 (if (math-zerop plus
)
725 (and (or calc-symbolic-mode
729 (10 .
(/ (calcFunc-sqrt
730 (- 2 (calcFunc-sqrt 3))) 2))
731 (12 .
(/ (- (calcFunc-sqrt 5) 1) 4))
732 (15 .
(/ (calcFunc-sqrt
733 (- 2 (calcFunc-sqrt 2))) 2))
735 (24 .
(* (^
(/ 1 2) (/ 3 2))
737 (- 5 (calcFunc-sqrt 5)))))
738 (30 .
(/ (calcFunc-sqrt 2) 2))
739 (36 .
(/ (+ (calcFunc-sqrt 5) 1) 4))
740 (40 .
(/ (calcFunc-sqrt 3) 2))
741 (45 .
(/ (calcFunc-sqrt
742 (+ 2 (calcFunc-sqrt 2))) 2))
743 (48 .
(* (^
(/ 1 2) (/ 3 2))
745 (+ 5 (calcFunc-sqrt 5)))))
746 (50 .
(/ (calcFunc-sqrt
747 (+ 2 (calcFunc-sqrt 3))) 2))
749 (cond ((eq n
0) (math-normalize (list 'calcFunc-sin plus
)))
750 ((eq n
60) (math-normalize (list 'calcFunc-cos plus
)))
753 (math-defsimplify calcFunc-tan
754 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctan
)
755 (nth 1 (nth 1 expr
)))
756 (and (math-looks-negp (nth 1 expr
))
757 (math-neg (list 'calcFunc-tan
(math-neg (nth 1 expr
)))))
758 (and (eq calc-angle-mode
'rad
)
759 (let ((n (math-linear-in (nth 1 expr
) '(var pi var-pi
))))
761 (math-known-tan (car n
) (nth 1 n
) 120))))
762 (and (eq calc-angle-mode
'deg
)
763 (let ((n (math-integer-plus (nth 1 expr
))))
765 (math-known-tan (car n
) (nth 1 n
) '(frac 2 3)))))
766 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsin
)
767 (math-div (nth 1 (nth 1 expr
))
769 (math-sub 1 (math-sqr (nth 1 (nth 1 expr
)))))))
770 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccos
)
771 (math-div (list 'calcFunc-sqrt
772 (math-sub 1 (math-sqr (nth 1 (nth 1 expr
)))))
773 (nth 1 (nth 1 expr
))))
774 (let ((m (math-should-expand-trig (nth 1 expr
))))
776 (if (equal (car m
) '(frac 1 2))
777 (math-div (math-sub 1 (list 'calcFunc-cos
(nth 1 m
)))
778 (list 'calcFunc-sin
(nth 1 m
)))
779 (math-div (list 'calcFunc-sin
(nth 1 expr
))
780 (list 'calcFunc-cos
(nth 1 expr
))))))))
782 (defun math-known-tan (plus n mul
)
783 (setq n
(math-mul n mul
))
784 (and (math-num-integerp n
)
785 (setq n
(math-mod (math-trunc n
) 120))
787 (and (setq n
(math-known-tan plus
(- 120 n
) 1))
789 (if (math-zerop plus
)
790 (and (or calc-symbolic-mode
792 (cdr (assq n
'( (0 .
0)
793 (10 .
(- 2 (calcFunc-sqrt 3)))
795 (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
796 (15 .
(- (calcFunc-sqrt 2) 1))
797 (20 .
(/ (calcFunc-sqrt 3) 3))
799 (- 5 (* 2 (calcFunc-sqrt 5)))))
802 (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
803 (40 .
(calcFunc-sqrt 3))
804 (45 .
(+ (calcFunc-sqrt 2) 1))
806 (+ 5 (* 2 (calcFunc-sqrt 5)))))
807 (50 .
(+ 2 (calcFunc-sqrt 3)))
808 (60 .
(var uinf var-uinf
))))))
809 (cond ((eq n
0) (math-normalize (list 'calcFunc-tan plus
)))
810 ((eq n
60) (math-normalize (list '/ -
1
811 (list 'calcFunc-tan plus
))))
814 (math-defsimplify calcFunc-sinh
815 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsinh
)
816 (nth 1 (nth 1 expr
)))
817 (and (math-looks-negp (nth 1 expr
))
818 (math-neg (list 'calcFunc-sinh
(math-neg (nth 1 expr
)))))
819 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccosh
)
820 math-living-dangerously
821 (list 'calcFunc-sqrt
(math-sub (math-sqr (nth 1 (nth 1 expr
))) 1)))
822 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctanh
)
823 math-living-dangerously
824 (math-div (nth 1 (nth 1 expr
))
826 (math-sub 1 (math-sqr (nth 1 (nth 1 expr
)))))))
827 (let ((m (math-should-expand-trig (nth 1 expr
) t
)))
828 (and m
(integerp (car m
))
829 (let ((n (car m
)) (a (nth 1 m
)))
832 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
833 (list 'calcFunc-cosh a
))
834 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
835 (list 'calcFunc-sinh a
)))))))))
837 (math-defsimplify calcFunc-cosh
838 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccosh
)
839 (nth 1 (nth 1 expr
)))
840 (and (math-looks-negp (nth 1 expr
))
841 (list 'calcFunc-cosh
(math-neg (nth 1 expr
))))
842 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsinh
)
843 math-living-dangerously
844 (list 'calcFunc-sqrt
(math-add (math-sqr (nth 1 (nth 1 expr
))) 1)))
845 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctanh
)
846 math-living-dangerously
849 (math-sub 1 (math-sqr (nth 1 (nth 1 expr
)))))))
850 (let ((m (math-should-expand-trig (nth 1 expr
) t
)))
851 (and m
(integerp (car m
))
852 (let ((n (car m
)) (a (nth 1 m
)))
855 (list '* (list 'calcFunc-cosh
(list '* (1- n
) a
))
856 (list 'calcFunc-cosh a
))
857 (list '* (list 'calcFunc-sinh
(list '* (1- n
) a
))
858 (list 'calcFunc-sinh a
)))))))))
860 (math-defsimplify calcFunc-tanh
861 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arctanh
)
862 (nth 1 (nth 1 expr
)))
863 (and (math-looks-negp (nth 1 expr
))
864 (math-neg (list 'calcFunc-tanh
(math-neg (nth 1 expr
)))))
865 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arcsinh
)
866 math-living-dangerously
867 (math-div (nth 1 (nth 1 expr
))
869 (math-add (math-sqr (nth 1 (nth 1 expr
))) 1))))
870 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-arccosh
)
871 math-living-dangerously
872 (math-div (list 'calcFunc-sqrt
873 (math-sub (math-sqr (nth 1 (nth 1 expr
))) 1))
874 (nth 1 (nth 1 expr
))))
875 (let ((m (math-should-expand-trig (nth 1 expr
) t
)))
877 (if (equal (car m
) '(frac 1 2))
878 (math-div (math-sub (list 'calcFunc-cosh
(nth 1 m
)) 1)
879 (list 'calcFunc-sinh
(nth 1 m
)))
880 (math-div (list 'calcFunc-sinh
(nth 1 expr
))
881 (list 'calcFunc-cosh
(nth 1 expr
))))))))
883 (math-defsimplify calcFunc-arcsin
884 (or (and (math-looks-negp (nth 1 expr
))
885 (math-neg (list 'calcFunc-arcsin
(math-neg (nth 1 expr
)))))
886 (and (eq (nth 1 expr
) 1)
887 (math-quarter-circle t
))
888 (and (equal (nth 1 expr
) '(frac 1 2))
889 (math-div (math-half-circle t
) 6))
890 (and math-living-dangerously
891 (eq (car-safe (nth 1 expr
)) 'calcFunc-sin
)
892 (nth 1 (nth 1 expr
)))
893 (and math-living-dangerously
894 (eq (car-safe (nth 1 expr
)) 'calcFunc-cos
)
895 (math-sub (math-quarter-circle t
)
896 (nth 1 (nth 1 expr
))))))
898 (math-defsimplify calcFunc-arccos
899 (or (and (eq (nth 1 expr
) 0)
900 (math-quarter-circle t
))
901 (and (eq (nth 1 expr
) -
1)
902 (math-half-circle t
))
903 (and (equal (nth 1 expr
) '(frac 1 2))
904 (math-div (math-half-circle t
) 3))
905 (and (equal (nth 1 expr
) '(frac -
1 2))
906 (math-div (math-mul (math-half-circle t
) 2) 3))
907 (and math-living-dangerously
908 (eq (car-safe (nth 1 expr
)) 'calcFunc-cos
)
909 (nth 1 (nth 1 expr
)))
910 (and math-living-dangerously
911 (eq (car-safe (nth 1 expr
)) 'calcFunc-sin
)
912 (math-sub (math-quarter-circle t
)
913 (nth 1 (nth 1 expr
))))))
915 (math-defsimplify calcFunc-arctan
916 (or (and (math-looks-negp (nth 1 expr
))
917 (math-neg (list 'calcFunc-arctan
(math-neg (nth 1 expr
)))))
918 (and (eq (nth 1 expr
) 1)
919 (math-div (math-half-circle t
) 4))
920 (and math-living-dangerously
921 (eq (car-safe (nth 1 expr
)) 'calcFunc-tan
)
922 (nth 1 (nth 1 expr
)))))
924 (math-defsimplify calcFunc-arcsinh
925 (or (and (math-looks-negp (nth 1 expr
))
926 (math-neg (list 'calcFunc-arcsinh
(math-neg (nth 1 expr
)))))
927 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-sinh
)
928 (or math-living-dangerously
929 (math-known-realp (nth 1 (nth 1 expr
))))
930 (nth 1 (nth 1 expr
)))))
932 (math-defsimplify calcFunc-arccosh
933 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-cosh
)
934 (or math-living-dangerously
935 (math-known-realp (nth 1 (nth 1 expr
))))
936 (nth 1 (nth 1 expr
))))
938 (math-defsimplify calcFunc-arctanh
939 (or (and (math-looks-negp (nth 1 expr
))
940 (math-neg (list 'calcFunc-arctanh
(math-neg (nth 1 expr
)))))
941 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-tanh
)
942 (or math-living-dangerously
943 (math-known-realp (nth 1 (nth 1 expr
))))
944 (nth 1 (nth 1 expr
)))))
946 (math-defsimplify calcFunc-sqrt
947 (math-simplify-sqrt))
949 (defun math-simplify-sqrt ()
950 (or (and (eq (car-safe (nth 1 expr
)) 'frac
)
951 (math-div (list 'calcFunc-sqrt
(math-mul (nth 1 (nth 1 expr
))
952 (nth 2 (nth 1 expr
))))
953 (nth 2 (nth 1 expr
))))
954 (let ((fac (if (math-objectp (nth 1 expr
))
955 (math-squared-factor (nth 1 expr
))
956 (math-common-constant-factor (nth 1 expr
)))))
957 (and fac
(not (eq fac
1))
958 (math-mul (math-normalize (list 'calcFunc-sqrt fac
))
961 (math-cancel-common-factor (nth 1 expr
) fac
))))))
962 (and math-living-dangerously
963 (or (and (eq (car-safe (nth 1 expr
)) '-
)
964 (math-equal-int (nth 1 (nth 1 expr
)) 1)
965 (eq (car-safe (nth 2 (nth 1 expr
))) '^
)
966 (math-equal-int (nth 2 (nth 2 (nth 1 expr
))) 2)
967 (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr
))))
970 (nth 1 (nth 1 (nth 2 (nth 1 expr
))))))
971 (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr
))))
974 (nth 1 (nth 1 (nth 2 (nth 1 expr
))))))))
975 (and (eq (car-safe (nth 1 expr
)) '-
)
976 (math-equal-int (nth 2 (nth 1 expr
)) 1)
977 (eq (car-safe (nth 1 (nth 1 expr
))) '^
)
978 (math-equal-int (nth 2 (nth 1 (nth 1 expr
))) 2)
979 (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr
))))
982 (nth 1 (nth 1 (nth 1 (nth 1 expr
)))))))
983 (and (eq (car-safe (nth 1 expr
)) '+)
984 (let ((a (nth 1 (nth 1 expr
)))
985 (b (nth 2 (nth 1 expr
))))
986 (and (or (and (math-equal-int a
1)
987 (setq a b b
(nth 1 (nth 1 expr
))))
988 (math-equal-int b
1))
990 (math-equal-int (nth 2 a
) 2)
991 (or (and (eq (car-safe (nth 1 a
)) 'calcFunc-sinh
)
992 (list 'calcFunc-cosh
(nth 1 (nth 1 a
))))
993 (and (eq (car-safe (nth 1 a
)) 'calcFunc-tan
)
994 (list '/ 1 (list 'calcFunc-cos
995 (nth 1 (nth 1 a
)))))))))
996 (and (eq (car-safe (nth 1 expr
)) '^
)
999 (math-div (nth 2 (nth 1 expr
)) 2)))
1000 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-sqrt
)
1001 (list '^
(nth 1 (nth 1 expr
)) (math-div 1 4)))
1002 (and (memq (car-safe (nth 1 expr
)) '(* /))
1003 (list (car (nth 1 expr
))
1004 (list 'calcFunc-sqrt
(nth 1 (nth 1 expr
)))
1005 (list 'calcFunc-sqrt
(nth 2 (nth 1 expr
)))))
1006 (and (memq (car-safe (nth 1 expr
)) '(+ -
))
1007 (not (math-any-floats (nth 1 expr
)))
1008 (let ((f (calcFunc-factors (calcFunc-expand
1010 (and (math-vectorp f
)
1011 (or (> (length f
) 2)
1012 (> (nth 2 (nth 1 f
)) 1))
1013 (let ((out 1) (rest 1) (sums 1) fac pow
)
1014 (while (setq f
(cdr f
))
1015 (setq fac
(nth 1 (car f
))
1016 pow
(nth 2 (car f
)))
1018 (setq out
(math-mul out
(math-pow
1022 (if (memq (car-safe fac
) '(+ -
))
1023 (setq sums
(math-mul-thru sums fac
))
1024 (setq rest
(math-mul rest fac
)))))
1025 (and (not (and (eq out
1) (memq rest
'(1 -
1))))
1028 (list 'calcFunc-sqrt
1029 (math-mul sums rest
))))))))))))
1031 ;;; Rather than factoring x into primes, just check for the first ten primes.
1032 (defun math-squared-factor (x)
1033 (if (Math-integerp x
)
1034 (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
1038 (if (eq (cdr (setq res
(math-idivmod x
(car prsqr
)))) 0)
1040 fac
(math-mul fac
(car prsqr
)))
1041 (setq prsqr
(cdr prsqr
))))
1044 (math-defsimplify calcFunc-exp
1045 (math-simplify-exp (nth 1 expr
)))
1047 (defun math-simplify-exp (x)
1048 (or (and (eq (car-safe x
) 'calcFunc-ln
)
1050 (and math-living-dangerously
1051 (or (and (eq (car-safe x
) 'calcFunc-arcsinh
)
1053 (list 'calcFunc-sqrt
1054 (math-add (math-sqr (nth 1 x
)) 1))))
1055 (and (eq (car-safe x
) 'calcFunc-arccosh
)
1057 (list 'calcFunc-sqrt
1058 (math-sub (math-sqr (nth 1 x
)) 1))))
1059 (and (eq (car-safe x
) 'calcFunc-arctanh
)
1060 (math-div (list 'calcFunc-sqrt
(math-add 1 (nth 1 x
)))
1061 (list 'calcFunc-sqrt
(math-sub 1 (nth 1 x
)))))
1062 (let ((m (math-should-expand-trig x
'exp
)))
1063 (and m
(integerp (car m
))
1064 (list '^
(list 'calcFunc-exp
(nth 1 m
)) (car m
))))))
1065 (and calc-symbolic-mode
1066 (math-known-imagp x
)
1067 (let* ((ip (calcFunc-im x
))
1068 (n (math-linear-in ip
'(var pi var-pi
)))
1071 (setq s
(math-known-sin (car n
) (nth 1 n
) 120 0))
1072 (setq c
(math-known-sin (car n
) (nth 1 n
) 120 300))
1073 (list '+ c
(list '* s
'(var i var-i
))))))))
1075 (math-defsimplify calcFunc-ln
1076 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-exp
)
1077 (or math-living-dangerously
1078 (math-known-realp (nth 1 (nth 1 expr
))))
1079 (nth 1 (nth 1 expr
)))
1080 (and (eq (car-safe (nth 1 expr
)) '^
)
1081 (equal (nth 1 (nth 1 expr
)) '(var e var-e
))
1082 (or math-living-dangerously
1083 (math-known-realp (nth 2 (nth 1 expr
))))
1084 (nth 2 (nth 1 expr
)))
1085 (and calc-symbolic-mode
1086 (math-known-negp (nth 1 expr
))
1087 (math-add (list 'calcFunc-ln
(math-neg (nth 1 expr
)))
1088 '(* (var pi var-pi
) (var i var-i
))))
1089 (and calc-symbolic-mode
1090 (math-known-imagp (nth 1 expr
))
1091 (let* ((ip (calcFunc-im (nth 1 expr
)))
1092 (ips (math-possible-signs ip
)))
1093 (or (and (memq ips
'(4 6))
1094 (math-add (list 'calcFunc-ln ip
)
1095 '(/ (* (var pi var-pi
) (var i var-i
)) 2)))
1096 (and (memq ips
'(1 3))
1097 (math-sub (list 'calcFunc-ln
(math-neg ip
))
1098 '(/ (* (var pi var-pi
) (var i var-i
)) 2))))))))
1101 (math-simplify-pow))
1103 (defun math-simplify-pow ()
1104 (or (and math-living-dangerously
1105 (or (and (eq (car-safe (nth 1 expr
)) '^
)
1107 (nth 1 (nth 1 expr
))
1108 (math-mul (nth 2 expr
) (nth 2 (nth 1 expr
)))))
1109 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-sqrt
)
1111 (nth 1 (nth 1 expr
))
1112 (math-div (nth 2 expr
) 2)))
1113 (and (memq (car-safe (nth 1 expr
)) '(* /))
1114 (list (car (nth 1 expr
))
1115 (list '^
(nth 1 (nth 1 expr
)) (nth 2 expr
))
1116 (list '^
(nth 2 (nth 1 expr
)) (nth 2 expr
))))))
1117 (and (math-equal-int (nth 1 expr
) 10)
1118 (eq (car-safe (nth 2 expr
)) 'calcFunc-log10
)
1119 (nth 1 (nth 2 expr
)))
1120 (and (equal (nth 1 expr
) '(var e var-e
))
1121 (math-simplify-exp (nth 2 expr
)))
1122 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-exp
)
1123 (not math-integrating
)
1124 (list 'calcFunc-exp
(math-mul (nth 1 (nth 1 expr
)) (nth 2 expr
))))
1125 (and (equal (nth 1 expr
) '(var i var-i
))
1127 (math-num-integerp (nth 2 expr
))
1128 (let ((x (math-mod (math-trunc (nth 2 expr
)) 4)))
1130 ((eq x
1) (nth 1 expr
))
1132 ((eq x
3) (math-neg (nth 1 expr
))))))
1133 (and math-integrating
1134 (integerp (nth 2 expr
))
1136 (or (and (eq (car-safe (nth 1 expr
)) 'calcFunc-cos
)
1137 (math-mul (math-pow (nth 1 expr
) (- (nth 2 expr
) 2))
1141 (nth 1 (nth 1 expr
)))))))
1142 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-cosh
)
1143 (math-mul (math-pow (nth 1 expr
) (- (nth 2 expr
) 2))
1146 (list 'calcFunc-sinh
1147 (nth 1 (nth 1 expr
)))))))))
1148 (and (eq (car-safe (nth 2 expr
)) 'frac
)
1149 (Math-ratp (nth 1 expr
))
1150 (Math-posp (nth 1 expr
))
1151 (if (equal (nth 2 expr
) '(frac 1 2))
1152 (list 'calcFunc-sqrt
(nth 1 expr
))
1153 (let ((flr (math-floor (nth 2 expr
))))
1154 (and (not (Math-zerop flr
))
1155 (list '* (list '^
(nth 1 expr
) flr
)
1156 (list '^
(nth 1 expr
)
1157 (math-sub (nth 2 expr
) flr
)))))))
1158 (and (eq (math-quarter-integer (nth 2 expr
)) 2)
1159 (let ((temp (math-simplify-sqrt)))
1161 (list '^ temp
(math-mul (nth 2 expr
) 2)))))))
1163 (math-defsimplify calcFunc-log10
1164 (and (eq (car-safe (nth 1 expr
)) '^
)
1165 (math-equal-int (nth 1 (nth 1 expr
)) 10)
1166 (or math-living-dangerously
1167 (math-known-realp (nth 2 (nth 1 expr
))))
1168 (nth 2 (nth 1 expr
))))
1171 (math-defsimplify calcFunc-erf
1172 (or (and (math-looks-negp (nth 1 expr
))
1173 (math-neg (list 'calcFunc-erf
(math-neg (nth 1 expr
)))))
1174 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-conj
)
1175 (list 'calcFunc-conj
(list 'calcFunc-erf
(nth 1 (nth 1 expr
)))))))
1177 (math-defsimplify calcFunc-erfc
1178 (or (and (math-looks-negp (nth 1 expr
))
1179 (math-sub 2 (list 'calcFunc-erfc
(math-neg (nth 1 expr
)))))
1180 (and (eq (car-safe (nth 1 expr
)) 'calcFunc-conj
)
1181 (list 'calcFunc-conj
(list 'calcFunc-erfc
(nth 1 (nth 1 expr
)))))))
1184 (defun math-linear-in (expr term
&optional always
)
1185 (if (math-expr-contains expr term
)
1186 (let* ((calc-prefer-frac t
)
1187 (p (math-is-polynomial expr term
1)))
1190 (and always
(list expr
0))))
1192 (defun math-multiple-of (expr term
)
1193 (let ((p (math-linear-in expr term
)))
1195 (math-zerop (car p
))
1198 ; not perfect, but it'll do
1199 (defun math-integer-plus (expr)
1200 (cond ((Math-integerp expr
)
1202 ((and (memq (car expr
) '(+ -
))
1203 (Math-integerp (nth 1 expr
)))
1204 (list (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))
1206 ((and (memq (car expr
) '(+ -
))
1207 (Math-integerp (nth 2 expr
)))
1209 (if (eq (car expr
) '+) (nth 2 expr
) (math-neg (nth 2 expr
)))))
1212 (defun math-is-linear (expr &optional always
)
1215 (if (eq (car-safe expr
) '+)
1216 (if (Math-objectp (nth 1 expr
))
1217 (setq offset
(nth 1 expr
)
1219 (if (Math-objectp (nth 2 expr
))
1220 (setq offset
(nth 2 expr
)
1221 expr
(nth 1 expr
))))
1222 (if (eq (car-safe expr
) '-
)
1223 (if (Math-objectp (nth 1 expr
))
1224 (setq offset
(nth 1 expr
)
1225 expr
(math-neg (nth 2 expr
)))
1226 (if (Math-objectp (nth 2 expr
))
1227 (setq offset
(math-neg (nth 2 expr
))
1228 expr
(nth 1 expr
))))))
1229 (setq coef
(math-is-multiple expr always
))
1231 (list offset
(or (car coef
) 1) (or (nth 1 coef
) expr
))
1235 (defun math-is-multiple (expr &optional always
)
1236 (or (if (eq (car-safe expr
) '*)
1237 (if (Math-objectp (nth 1 expr
))
1238 (list (nth 1 expr
) (nth 2 expr
)))
1239 (if (eq (car-safe expr
) '/)
1240 (if (and (Math-objectp (nth 1 expr
))
1241 (not (math-equal-int (nth 1 expr
) 1)))
1242 (list (nth 1 expr
) (math-div 1 (nth 2 expr
)))
1243 (if (Math-objectp (nth 2 expr
))
1244 (list (math-div 1 (nth 2 expr
)) (nth 1 expr
))
1245 (let ((res (math-is-multiple (nth 1 expr
))))
1248 (math-div (nth 2 (nth 1 expr
)) (nth 2 expr
)))
1249 (setq res
(math-is-multiple (nth 2 expr
)))
1251 (list (math-div 1 (car res
))
1252 (math-div (nth 1 expr
)
1253 (nth 2 (nth 2 expr
)))))))))
1254 (if (eq (car-safe expr
) 'neg
)
1255 (list -
1 (nth 1 expr
)))))
1256 (if (Math-objvecp expr
)
1262 (defun calcFunc-lin (expr &optional var
)
1264 (let ((res (math-linear-in expr var t
)))
1265 (or res
(math-reject-arg expr
"Linear term expected"))
1266 (list 'vec
(car res
) (nth 1 res
) var
))
1267 (let ((res (math-is-linear expr t
)))
1268 (or res
(math-reject-arg expr
"Linear term expected"))
1271 (defun calcFunc-linnt (expr &optional var
)
1273 (let ((res (math-linear-in expr var
)))
1274 (or res
(math-reject-arg expr
"Linear term expected"))
1275 (list 'vec
(car res
) (nth 1 res
) var
))
1276 (let ((res (math-is-linear expr
)))
1277 (or res
(math-reject-arg expr
"Linear term expected"))
1280 (defun calcFunc-islin (expr &optional var
)
1281 (if (and (Math-objvecp expr
) (not var
))
1283 (calcFunc-lin expr var
)
1286 (defun calcFunc-islinnt (expr &optional var
)
1287 (if (Math-objvecp expr
)
1289 (calcFunc-linnt expr var
)
1295 ;;; Simple operations on expressions.
1297 ;;; Return number of occurrences of thing in expr, or nil if none.
1298 (defun math-expr-contains-count (expr thing
)
1299 (cond ((equal expr thing
) 1)
1300 ((Math-primp expr
) nil
)
1303 (while (setq expr
(cdr expr
))
1304 (setq num
(+ num
(or (math-expr-contains-count
1305 (car expr
) thing
) 0))))
1309 (defun math-expr-contains (expr thing
)
1310 (cond ((equal expr thing
) 1)
1311 ((Math-primp expr
) nil
)
1313 (while (and (setq expr
(cdr expr
))
1314 (not (math-expr-contains (car expr
) thing
))))
1317 ;;; Return non-nil if any variable of thing occurs in expr.
1318 (defun math-expr-depends (expr thing
)
1319 (if (Math-primp thing
)
1320 (and (eq (car-safe thing
) 'var
)
1321 (math-expr-contains expr thing
))
1322 (while (and (setq thing
(cdr thing
))
1323 (not (math-expr-depends expr
(car thing
)))))
1326 ;;; Substitute all occurrences of old for new in expr (non-destructive).
1327 (defun math-expr-subst (expr old new
)
1328 (math-expr-subst-rec expr
))
1330 (defalias 'calcFunc-subst
'math-expr-subst
)
1332 (defun math-expr-subst-rec (expr)
1333 (cond ((equal expr old
) new
)
1334 ((Math-primp expr
) expr
)
1335 ((memq (car expr
) '(calcFunc-deriv
1337 (if (= (length expr
) 2)
1338 (if (equal (nth 1 expr
) old
)
1339 (append expr
(list new
))
1341 (list (car expr
) (nth 1 expr
)
1342 (math-expr-subst-rec (nth 2 expr
)))))
1345 (mapcar 'math-expr-subst-rec
(cdr expr
))))))
1347 ;;; Various measures of the size of an expression.
1348 (defun math-expr-weight (expr)
1349 (if (Math-primp expr
)
1352 (while (setq expr
(cdr expr
))
1353 (setq w
(+ w
(math-expr-weight (car expr
)))))
1356 (defun math-expr-height (expr)
1357 (if (Math-primp expr
)
1360 (while (setq expr
(cdr expr
))
1361 (setq h
(max h
(math-expr-height (car expr
)))))
1367 ;;; Polynomial operations (to support the integrator and solve-for).
1369 (defun calcFunc-collect (expr base
)
1370 (let ((p (math-is-polynomial expr base
50 t
)))
1372 (math-normalize ; fix selection bug
1373 (math-build-polynomial-expr p base
))
1376 ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
1377 ;;; else return nil if not in polynomial form. If "loose", coefficients
1378 ;;; may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
1379 (defun math-is-polynomial (expr var
&optional degree loose
)
1380 (let* ((math-poly-base-variable (if loose
1381 (if (eq loose
'gen
) var
'(var XXX XXX
))
1382 math-poly-base-variable
))
1383 (poly (math-is-poly-rec expr math-poly-neg-powers
)))
1384 (and (or (null degree
)
1385 (<= (length poly
) (1+ degree
)))
1388 (defun math-is-poly-rec (expr negpow
)
1390 (or (cond ((or (equal expr var
)
1391 (eq (car-safe expr
) '^
))
1394 (or (equal expr var
)
1395 (setq pow
(nth 2 expr
)
1397 (or (eq math-poly-mult-powers
1)
1398 (setq pow
(let ((m (math-is-multiple pow
1)))
1399 (and (eq (car-safe (car m
)) 'cplx
)
1400 (Math-zerop (nth 1 (car m
)))
1401 (setq m
(list (nth 2 (car m
))
1404 (and (if math-poly-mult-powers
1405 (equal math-poly-mult-powers
1407 (setq math-poly-mult-powers
(nth 1 m
)))
1408 (or (equal expr var
)
1409 (eq math-poly-mult-powers
1))
1413 (setq pow
(math-to-simple-fraction pow
))
1414 (and (eq (car-safe pow
) 'frac
)
1415 math-poly-frac-powers
1417 (setq math-poly-frac-powers
1418 (calcFunc-lcm math-poly-frac-powers
1420 (or (memq math-poly-frac-powers
'(1 nil
))
1421 (setq pow
(math-mul pow math-poly-frac-powers
)))
1427 (let ((p1 (if (equal expr var
)
1429 (math-is-poly-rec expr nil
)))
1434 (<= (* (1- (length p1
)) n
) degree
))
1437 (setq accum
(math-poly-mul accum p1
)
1441 (math-is-poly-rec expr nil
)
1442 (setq math-poly-neg-powers
1443 (cons (math-pow expr
(- pow
))
1444 math-poly-neg-powers
))
1445 (list (list '^ expr pow
))))))))
1446 ((Math-objectp expr
)
1448 ((memq (car expr
) '(+ -
))
1449 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1451 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1453 (math-poly-mix p1
1 p2
1454 (if (eq (car expr
) '+) 1 -
1)))))))
1455 ((eq (car expr
) 'neg
)
1456 (mapcar 'math-neg
(math-is-poly-rec (nth 1 expr
) negpow
)))
1458 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1460 (let ((p2 (math-is-poly-rec (nth 2 expr
) negpow
)))
1463 (<= (- (+ (length p1
) (length p2
)) 2) degree
))
1464 (math-poly-mul p1 p2
))))))
1466 (and (or (not (math-poly-depends (nth 2 expr
) var
))
1468 (math-is-poly-rec (nth 2 expr
) nil
)
1469 (setq math-poly-neg-powers
1470 (cons (nth 2 expr
) math-poly-neg-powers
))))
1471 (not (Math-zerop (nth 2 expr
)))
1472 (let ((p1 (math-is-poly-rec (nth 1 expr
) negpow
)))
1473 (mapcar (function (lambda (x) (math-div x
(nth 2 expr
))))
1475 ((and (eq (car expr
) 'calcFunc-exp
)
1476 (equal var
'(var e var-e
)))
1477 (math-is-poly-rec (list '^ var
(nth 1 expr
)) negpow
))
1478 ((and (eq (car expr
) 'calcFunc-sqrt
)
1479 math-poly-frac-powers
)
1480 (math-is-poly-rec (list '^
(nth 1 expr
) '(frac 1 2)) negpow
))
1482 (and (or (not (math-poly-depends expr var
))
1484 (not (eq (car expr
) 'vec
))
1487 ;;; Check if expr is a polynomial in var; if so, return its degree.
1488 (defun math-polynomial-p (expr var
)
1489 (cond ((equal expr var
) 1)
1490 ((Math-primp expr
) 0)
1491 ((memq (car expr
) '(+ -
))
1492 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1494 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1497 (let ((p1 (math-polynomial-p (nth 1 expr
) var
))
1499 (and p1
(setq p2
(math-polynomial-p (nth 2 expr
) var
))
1501 ((eq (car expr
) 'neg
)
1502 (math-polynomial-p (nth 1 expr
) var
))
1503 ((and (eq (car expr
) '/)
1504 (not (math-poly-depends (nth 2 expr
) var
)))
1505 (math-polynomial-p (nth 1 expr
) var
))
1506 ((and (eq (car expr
) '^
)
1507 (natnump (nth 2 expr
)))
1508 (let ((p1 (math-polynomial-p (nth 1 expr
) var
)))
1509 (and p1
(* p1
(nth 2 expr
)))))
1510 ((math-poly-depends expr var
) nil
)
1513 (defun math-poly-depends (expr var
)
1514 (if math-poly-base-variable
1515 (math-expr-contains expr math-poly-base-variable
)
1516 (math-expr-depends expr var
)))
1518 ;;; Find the variable (or sub-expression) which is the base of polynomial expr.
1519 (defun math-polynomial-base (mpb-top-expr &optional mpb-pred
)
1521 (setq mpb-pred
(function (lambda (base) (math-polynomial-p
1522 mpb-top-expr base
)))))
1523 (or (let ((const-ok nil
))
1524 (math-polynomial-base-rec mpb-top-expr
))
1526 (math-polynomial-base-rec mpb-top-expr
))))
1528 (defun math-polynomial-base-rec (mpb-expr)
1529 (and (not (Math-objvecp mpb-expr
))
1530 (or (and (memq (car mpb-expr
) '(+ -
*))
1531 (or (math-polynomial-base-rec (nth 1 mpb-expr
))
1532 (math-polynomial-base-rec (nth 2 mpb-expr
))))
1533 (and (memq (car mpb-expr
) '(/ neg
))
1534 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1535 (and (eq (car mpb-expr
) '^
)
1536 (math-polynomial-base-rec (nth 1 mpb-expr
)))
1537 (and (eq (car mpb-expr
) 'calcFunc-exp
)
1538 (math-polynomial-base-rec '(var e var-e
)))
1539 (and (or const-ok
(math-expr-contains-vars mpb-expr
))
1540 (funcall mpb-pred mpb-expr
)
1543 ;;; Return non-nil if expr refers to any variables.
1544 (defun math-expr-contains-vars (expr)
1545 (or (eq (car-safe expr
) 'var
)
1546 (and (not (Math-primp expr
))
1548 (while (and (setq expr
(cdr expr
))
1549 (not (math-expr-contains-vars (car expr
)))))
1552 ;;; Simplify a polynomial in list form by stripping off high-end zeros.
1553 ;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
1554 (defun math-poly-simplify (p)
1556 (if (Math-zerop (nth (1- (length p
)) p
))
1557 (let ((pp (copy-sequence p
)))
1558 (while (and (cdr pp
)
1559 (Math-zerop (nth (1- (length pp
)) pp
)))
1560 (setcdr (nthcdr (- (length pp
) 2) pp
) nil
))
1564 ;;; Compute ac*a + bc*b for polynomials in list form a, b and
1565 ;;; coefficients ac, bc. Result may be unsimplified.
1566 (defun math-poly-mix (a ac b bc
)
1568 (cons (math-add (math-mul (or (car a
) 0) ac
)
1569 (math-mul (or (car b
) 0) bc
))
1570 (math-poly-mix (cdr a
) ac
(cdr b
) bc
))))
1572 (defun math-poly-zerop (a)
1574 (and (null (cdr a
)) (Math-zerop (car a
)))))
1576 ;;; Multiply two polynomials in list form.
1577 (defun math-poly-mul (a b
)
1579 (math-poly-mix b
(car a
)
1580 (math-poly-mul (cdr a
) (cons 0 b
)) 1)))
1582 ;;; Build an expression from a polynomial list.
1583 (defun math-build-polynomial-expr (p var
)
1585 (if (Math-numberp var
)
1586 (math-with-extra-prec 1
1587 (let* ((rp (reverse p
))
1589 (while (setq rp
(cdr rp
))
1590 (setq accum
(math-add (car rp
) (math-mul accum var
))))
1592 (let* ((rp (reverse p
))
1593 (n (1- (length rp
)))
1594 (accum (math-mul (car rp
) (math-pow var n
)))
1596 (while (setq rp
(cdr rp
))
1598 (or (math-zerop (car rp
))
1599 (setq accum
(list (if (math-looks-negp (car rp
)) '-
'+)
1601 (math-mul (if (math-looks-negp (car rp
))
1604 (math-pow var n
))))))
1609 (defun math-to-simple-fraction (f)
1610 (or (and (eq (car-safe f
) 'float
)
1611 (or (and (>= (nth 2 f
) 0)
1612 (math-scale-int (nth 1 f
) (nth 2 f
)))
1613 (and (integerp (nth 1 f
))
1616 (math-make-frac (nth 1 f
)
1617 (math-scale-int 1 (- (nth 2 f
)))))))
1620 ;;; calc-alg.el ends here