Mercurial > emacs

comparison lisp/calc/calcalg2.el @ 105115:0c03b224b071

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(var): Define for compiler. Delete trailing whitespace.
author Glenn Morris <rgm@gnu.org>
date Sat, 19 Sep 2009 21:07:53 +0000
parents a9dc0e7c3f2b
children 1d1d5d9bd884
comparison
equal deleted inserted replaced
105114:c9577a1b5ce8 105115:0c03b224b071
196 (calc-top-n 1) 196 (calc-top-n 1)
197 var 197 var
198 (prefix-numeric-value nterms)))))) 198 (prefix-numeric-value nterms))))))
199 199
200 200
201 ;; The following are global variables used by math-derivative and some 201 ;; The following are global variables used by math-derivative and some
202 ;; related functions 202 ;; related functions
203 (defvar math-deriv-var) 203 (defvar math-deriv-var)
204 (defvar math-deriv-total) 204 (defvar math-deriv-total)
205 (defvar math-deriv-symb) 205 (defvar math-deriv-symb)
206 (defvar math-decls-cache) 206 (defvar math-decls-cache)
414 (math-sqr 414 (math-sqr
415 (math-normalize 415 (math-normalize
416 (list 'calcFunc-sec u))))))) 416 (list 'calcFunc-sec u)))))))
417 417
418 (put 'calcFunc-sec\' 'math-derivative-1 418 (put 'calcFunc-sec\' 'math-derivative-1
419 (function (lambda (u) (math-to-radians-2 419 (function (lambda (u) (math-to-radians-2
420 (math-mul 420 (math-mul
421 (math-normalize 421 (math-normalize
422 (list 'calcFunc-sec u)) 422 (list 'calcFunc-sec u))
423 (math-normalize 423 (math-normalize
424 (list 'calcFunc-tan u))))))) 424 (list 'calcFunc-tan u)))))))
425 425
426 (put 'calcFunc-csc\' 'math-derivative-1 426 (put 'calcFunc-csc\' 'math-derivative-1
427 (function (lambda (u) (math-neg 427 (function (lambda (u) (math-neg
428 (math-to-radians-2 428 (math-to-radians-2
429 (math-mul 429 (math-mul
430 (math-normalize 430 (math-normalize
431 (list 'calcFunc-csc u)) 431 (list 'calcFunc-csc u))
432 (math-normalize 432 (math-normalize
655 ;; math-integ-depth is a local variable for math-try-integral, but is used 655 ;; math-integ-depth is a local variable for math-try-integral, but is used
656 ;; by math-integral and math-tracing-integral 656 ;; by math-integral and math-tracing-integral
657 ;; which are called (directly or indirectly) by math-try-integral. 657 ;; which are called (directly or indirectly) by math-try-integral.
658 (defvar math-integ-depth) 658 (defvar math-integ-depth)
659 ;; math-integ-level is a local variable for math-try-integral, but is used 659 ;; math-integ-level is a local variable for math-try-integral, but is used
660 ;; by math-integral, math-do-integral, math-tracing-integral, 660 ;; by math-integral, math-do-integral, math-tracing-integral,
661 ;; math-sub-integration, math-integrate-by-parts and 661 ;; math-sub-integration, math-integrate-by-parts and
662 ;; math-integrate-by-substitution, which are called (directly or 662 ;; math-integrate-by-substitution, which are called (directly or
663 ;; indirectly) by math-try-integral. 663 ;; indirectly) by math-try-integral.
664 (defvar math-integ-level) 664 (defvar math-integ-level)
665 ;; math-integral-limit is a local variable for calcFunc-integ, but is 665 ;; math-integral-limit is a local variable for calcFunc-integ, but is
666 ;; used by math-tracing-integral, math-sub-integration and 666 ;; used by math-tracing-integral, math-sub-integration and
667 ;; math-try-integration. 667 ;; math-try-integration.
668 (defvar math-integral-limit) 668 (defvar math-integral-limit)
669 669
670 (defmacro math-tracing-integral (&rest parts) 670 (defmacro math-tracing-integral (&rest parts)
671 (list 'and 671 (list 'and
672 'trace-buffer 672 'trace-buffer
826 826
827 ;; math-old-integ is a local variable for math-do-integral, but is 827 ;; math-old-integ is a local variable for math-do-integral, but is
828 ;; used by math-sub-integration. 828 ;; used by math-sub-integration.
829 (defvar math-old-integ) 829 (defvar math-old-integ)
830 830
831 ;; The variables math-t1, math-t2 and math-t3 are local to 831 ;; The variables math-t1, math-t2 and math-t3 are local to
832 ;; math-do-integral, math-try-solve-for and math-decompose-poly, but 832 ;; math-do-integral, math-try-solve-for and math-decompose-poly, but
833 ;; are used by functions they call (directly or indirectly); 833 ;; are used by functions they call (directly or indirectly);
834 ;; math-do-integral calls math-do-integral-methods; 834 ;; math-do-integral calls math-do-integral-methods;
835 ;; math-try-solve-for calls math-try-solve-prod, 835 ;; math-try-solve-for calls math-try-solve-prod,
836 ;; math-solve-find-root-term and math-solve-find-root-in-prod; 836 ;; math-solve-find-root-term and math-solve-find-root-in-prod;
837 ;; math-decompose-poly calls math-solve-poly-funny-powers and 837 ;; math-decompose-poly calls math-solve-poly-funny-powers and
838 ;; math-solve-crunch-poly. 838 ;; math-solve-crunch-poly.
839 (defvar math-t1) 839 (defvar math-t1)
840 (defvar math-t2) 840 (defvar math-t2)
1073 (not (math-expr-calls res 'calcFunc-integ))) 1073 (not (math-expr-calls res 'calcFunc-integ)))
1074 res))) 1074 res)))
1075 (list 'calcFunc-integfailed expr))) 1075 (list 'calcFunc-integfailed expr)))
1076 1076
1077 ;; math-so-far is a local variable for math-do-integral-methods, but 1077 ;; math-so-far is a local variable for math-do-integral-methods, but
1078 ;; is used by math-integ-try-linear-substitutions and 1078 ;; is used by math-integ-try-linear-substitutions and
1079 ;; math-integ-try-substitutions. 1079 ;; math-integ-try-substitutions.
1080 (defvar math-so-far) 1080 (defvar math-so-far)
1081 1081
1082 ;; math-integ-expr is a local variable for math-do-integral-methods, 1082 ;; math-integ-expr is a local variable for math-do-integral-methods,
1083 ;; but is used by math-integ-try-linear-substitutions and 1083 ;; but is used by math-integ-try-linear-substitutions and
1084 ;; math-integ-try-substitutions. 1084 ;; math-integ-try-substitutions.
1085 (defvar math-integ-expr) 1085 (defvar math-integ-expr)
1086 1086
1087 (defun math-do-integral-methods (math-integ-expr) 1087 (defun math-do-integral-methods (math-integ-expr)
1088 (let ((math-so-far math-integ-var-list-list) 1088 (let ((math-so-far math-integ-var-list-list)
1251 (calcFunc-expand temp) 1251 (calcFunc-expand temp)
1252 (setq v (list 'var 'PARTS math-cur-record) 1252 (setq v (list 'var 'PARTS math-cur-record)
1253 temp (let (calc-next-why) 1253 temp (let (calc-next-why)
1254 (math-simplify-extended 1254 (math-simplify-extended
1255 (math-solve-for (math-sub v temp) 0 v nil))) 1255 (math-solve-for (math-sub v temp) 0 v nil)))
1256 temp (if (and (eq (car-safe temp) '/) 1256 temp (if (and (eq (car-safe temp) '/)
1257 (math-zerop (nth 2 temp))) 1257 (math-zerop (nth 2 temp)))
1258 nil temp))))) 1258 nil temp)))))
1259 (setcar (cdr math-cur-record) 'busy))))) 1259 (setcar (cdr math-cur-record) 'busy)))))
1260 1260
1261 ;;; This tries two different formulations, hoping the algebraic simplifier 1261 ;;; This tries two different formulations, hoping the algebraic simplifier
1262 ;;; will be strong enough to handle at least one. 1262 ;;; will be strong enough to handle at least one.
1673 (list 'calcFunc-ln (list 'calcFunc-sec u))))) 1673 (list 'calcFunc-ln (list 'calcFunc-sec u)))))
1674 1674
1675 (math-defintegral calcFunc-sec 1675 (math-defintegral calcFunc-sec
1676 (and (equal u math-integ-var) 1676 (and (equal u math-integ-var)
1677 (math-from-radians-2 1677 (math-from-radians-2
1678 (list 'calcFunc-ln 1678 (list 'calcFunc-ln
1679 (math-add 1679 (math-add
1680 (list 'calcFunc-sec u) 1680 (list 'calcFunc-sec u)
1681 (list 'calcFunc-tan u)))))) 1681 (list 'calcFunc-tan u))))))
1682 1682
1683 (math-defintegral calcFunc-csc 1683 (math-defintegral calcFunc-csc
1684 (and (equal u math-integ-var) 1684 (and (equal u math-integ-var)
1685 (math-from-radians-2 1685 (math-from-radians-2
1686 (list 'calcFunc-ln 1686 (list 'calcFunc-ln
1687 (math-sub 1687 (math-sub
1688 (list 'calcFunc-csc u) 1688 (list 'calcFunc-csc u)
1689 (list 'calcFunc-cot u)))))) 1689 (list 'calcFunc-cot u))))))
1690 1690
1691 (math-defintegral calcFunc-cot 1691 (math-defintegral calcFunc-cot
1880 1880
1881 1881
1882 (defvar math-tabulate-initial nil) 1882 (defvar math-tabulate-initial nil)
1883 (defvar math-tabulate-function nil) 1883 (defvar math-tabulate-function nil)
1884 1884
1885 ;; The variables calc-low and calc-high are local to calcFunc-table, 1885 ;; These variables are local to calcFunc-table, but are used by
1886 ;; but are used by math-scan-for-limits. 1886 ;; math-scan-for-limits.
1887 (defvar calc-low) 1887 (defvar calc-low)
1888 (defvar calc-high) 1888 (defvar calc-high)
1889 (defvar var)
1889 1890
1890 (defun calcFunc-table (expr var &optional calc-low calc-high step) 1891 (defun calcFunc-table (expr var &optional calc-low calc-high step)
1891 (or calc-low 1892 (or calc-low
1892 (setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf))) 1893 (setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf)))
1893 (or calc-high (setq calc-high calc-low calc-low 1)) 1894 (or calc-high (setq calc-high calc-low calc-low 1))
1894 (and (or (math-infinitep calc-low) (math-infinitep calc-high)) 1895 (and (or (math-infinitep calc-low) (math-infinitep calc-high))
1895 (not step) 1896 (not step)
1896 (math-scan-for-limits expr)) 1897 (math-scan-for-limits expr))
2346 2347
2347 2348
2348 2349
2349 (defvar math-solve-ranges nil) 2350 (defvar math-solve-ranges nil)
2350 (defvar math-solve-sign) 2351 (defvar math-solve-sign)
2351 ;;; Attempt to reduce math-solve-lhs = math-solve-rhs to 2352 ;;; Attempt to reduce math-solve-lhs = math-solve-rhs to
2352 ;;; math-solve-var = math-solve-rhs', where math-solve-var appears 2353 ;;; math-solve-var = math-solve-rhs', where math-solve-var appears
2353 ;;; in math-solve-lhs but not in math-solve-rhs or math-solve-rhs'; 2354 ;;; in math-solve-lhs but not in math-solve-rhs or math-solve-rhs';
2354 ;;; return math-solve-rhs'. 2355 ;;; return math-solve-rhs'.
2355 ;;; Uses global values: math-solve-var, math-solve-full. 2356 ;;; Uses global values: math-solve-var, math-solve-full.
2356 (defvar math-solve-var) 2357 (defvar math-solve-var)
2357 (defvar math-solve-full) 2358 (defvar math-solve-full)
2358 2359
2359 ;; The variables math-solve-lhs, math-solve-rhs and math-try-solve-sign 2360 ;; The variables math-solve-lhs, math-solve-rhs and math-try-solve-sign
2360 ;; are local to math-try-solve-for, but are used by math-try-solve-prod. 2361 ;; are local to math-try-solve-for, but are used by math-try-solve-prod.
2361 ;; (math-solve-lhs and math-solve-rhs are is also local to 2362 ;; (math-solve-lhs and math-solve-rhs are is also local to
2362 ;; math-decompose-poly, but used by math-solve-poly-funny-powers.) 2363 ;; math-decompose-poly, but used by math-solve-poly-funny-powers.)
2363 (defvar math-solve-lhs) 2364 (defvar math-solve-lhs)
2364 (defvar math-solve-rhs) 2365 (defvar math-solve-rhs)
2365 (defvar math-try-solve-sign) 2366 (defvar math-try-solve-sign)
2366 2367
2367 (defun math-try-solve-for 2368 (defun math-try-solve-for
2368 (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly) 2369 (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly)
2369 (let (math-t1 math-t2 math-t3) 2370 (let (math-t1 math-t2 math-t3)
2370 (cond ((equal math-solve-lhs math-solve-var) 2371 (cond ((equal math-solve-lhs math-solve-var)
2371 (setq math-solve-sign math-try-solve-sign) 2372 (setq math-solve-sign math-try-solve-sign)
2372 (if (eq math-solve-full 'all) 2373 (if (eq math-solve-full 'all)
2393 (= (length (nth 2 math-solve-lhs)) 2) 2394 (= (length (nth 2 math-solve-lhs)) 2)
2394 (setq math-t1 (get (car (nth 1 math-solve-lhs)) 'math-inverse)) 2395 (setq math-t1 (get (car (nth 1 math-solve-lhs)) 'math-inverse))
2395 (setq math-t2 (funcall math-t1 '(var SOLVEDUM SOLVEDUM))) 2396 (setq math-t2 (funcall math-t1 '(var SOLVEDUM SOLVEDUM)))
2396 (eq (math-expr-contains-count math-t2 '(var SOLVEDUM SOLVEDUM)) 1) 2397 (eq (math-expr-contains-count math-t2 '(var SOLVEDUM SOLVEDUM)) 1)
2397 (setq math-t3 (math-solve-above-dummy math-t2)) 2398 (setq math-t3 (math-solve-above-dummy math-t2))
2398 (setq math-t1 (math-try-solve-for 2399 (setq math-t1 (math-try-solve-for
2399 (math-sub (nth 1 (nth 1 math-solve-lhs)) 2400 (math-sub (nth 1 (nth 1 math-solve-lhs))
2400 (math-expr-subst 2401 (math-expr-subst
2401 math-t2 math-t3 2402 math-t2 math-t3
2402 (nth 1 (nth 2 math-solve-lhs)))) 2403 (nth 1 (nth 2 math-solve-lhs))))
2403 0))) 2404 0)))
2405 ((eq (car math-solve-lhs) 'neg) 2406 ((eq (car math-solve-lhs) 'neg)
2406 (math-try-solve-for (nth 1 math-solve-lhs) (math-neg math-solve-rhs) 2407 (math-try-solve-for (nth 1 math-solve-lhs) (math-neg math-solve-rhs)
2407 (and math-try-solve-sign (- math-try-solve-sign)))) 2408 (and math-try-solve-sign (- math-try-solve-sign))))
2408 ((and (not (eq math-solve-full 't)) (math-try-solve-prod))) 2409 ((and (not (eq math-solve-full 't)) (math-try-solve-prod)))
2409 ((and (not no-poly) 2410 ((and (not no-poly)
2410 (setq math-t2 2411 (setq math-t2
2411 (math-decompose-poly math-solve-lhs 2412 (math-decompose-poly math-solve-lhs
2412 math-solve-var 15 math-solve-rhs))) 2413 math-solve-var 15 math-solve-rhs)))
2413 (setq math-t1 (cdr (nth 1 math-t2)) 2414 (setq math-t1 (cdr (nth 1 math-t2))
2414 math-t1 (let ((math-solve-ranges math-solve-ranges)) 2415 math-t1 (let ((math-solve-ranges math-solve-ranges))
2415 (cond ((= (length math-t1) 5) 2416 (cond ((= (length math-t1) 5)
2416 (apply 'math-solve-quartic (car math-t2) math-t1)) 2417 (apply 'math-solve-quartic (car math-t2) math-t1))
2417 ((= (length math-t1) 4) 2418 ((= (length math-t1) 4)
2418 (apply 'math-solve-cubic (car math-t2) math-t1)) 2419 (apply 'math-solve-cubic (car math-t2) math-t1))
2419 ((= (length math-t1) 3) 2420 ((= (length math-t1) 3)
2420 (apply 'math-solve-quadratic (car math-t2) math-t1)) 2421 (apply 'math-solve-quadratic (car math-t2) math-t1))
2421 ((= (length math-t1) 2) 2422 ((= (length math-t1) 2)
2422 (apply 'math-solve-linear 2423 (apply 'math-solve-linear
2423 (car math-t2) math-try-solve-sign math-t1)) 2424 (car math-t2) math-try-solve-sign math-t1))
2424 (math-solve-full 2425 (math-solve-full
2425 (math-poly-all-roots (car math-t2) math-t1)) 2426 (math-poly-all-roots (car math-t2) math-t1))
2426 (calc-symbolic-mode nil) 2427 (calc-symbolic-mode nil)
2427 (t 2428 (t
2472 (nth 1 (nth 2 math-solve-lhs))))) 2473 (nth 1 (nth 2 math-solve-lhs)))))
2473 math-solve-rhs)) 2474 math-solve-rhs))
2474 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) 2475 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var))
2475 (math-try-solve-for (nth 2 math-solve-lhs) 2476 (math-try-solve-for (nth 2 math-solve-lhs)
2476 (math-sub (nth 1 math-solve-lhs) math-solve-rhs) 2477 (math-sub (nth 1 math-solve-lhs) math-solve-rhs)
2477 (and math-try-solve-sign 2478 (and math-try-solve-sign
2478 (- math-try-solve-sign)))) 2479 (- math-try-solve-sign))))
2479 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) 2480 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var))
2480 (math-try-solve-for (nth 1 math-solve-lhs) 2481 (math-try-solve-for (nth 1 math-solve-lhs)
2481 (math-add math-solve-rhs (nth 2 math-solve-lhs)) 2482 (math-add math-solve-rhs (nth 2 math-solve-lhs))
2482 math-try-solve-sign)))) 2483 math-try-solve-sign))))
2486 (math-try-solve-for (nth 1 math-solve-lhs) (math-add math-solve-rhs 2487 (math-try-solve-for (nth 1 math-solve-lhs) (math-add math-solve-rhs
2487 (math-solve-get-int 2488 (math-solve-get-int
2488 (nth 2 math-solve-lhs))))) 2489 (nth 2 math-solve-lhs)))))
2489 ((eq (car math-solve-lhs) 'calcFunc-log) 2490 ((eq (car math-solve-lhs) 'calcFunc-log)
2490 (cond ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) 2491 (cond ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var))
2491 (math-try-solve-for (nth 1 math-solve-lhs) 2492 (math-try-solve-for (nth 1 math-solve-lhs)
2492 (math-pow (nth 2 math-solve-lhs) math-solve-rhs))) 2493 (math-pow (nth 2 math-solve-lhs) math-solve-rhs)))
2493 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) 2494 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var))
2494 (math-try-solve-for (nth 2 math-solve-lhs) (math-pow 2495 (math-try-solve-for (nth 2 math-solve-lhs) (math-pow
2495 (nth 1 math-solve-lhs) 2496 (nth 1 math-solve-lhs)
2496 (math-div 1 math-solve-rhs)))))) 2497 (math-div 1 math-solve-rhs))))))
2501 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-sign)) 2502 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-sign))
2502 (math-try-solve-for (nth 1 math-solve-lhs) (math-normalize math-t2) 2503 (math-try-solve-for (nth 1 math-solve-lhs) (math-normalize math-t2)
2503 (and math-try-solve-sign math-t1 2504 (and math-try-solve-sign math-t1
2504 (if (integerp math-t1) 2505 (if (integerp math-t1)
2505 (* math-t1 math-try-solve-sign) 2506 (* math-t1 math-try-solve-sign)
2506 (funcall math-t1 math-solve-lhs 2507 (funcall math-t1 math-solve-lhs
2507 math-try-solve-sign))))) 2508 math-try-solve-sign)))))
2508 ((and (symbolp (car math-solve-lhs)) 2509 ((and (symbolp (car math-solve-lhs))
2509 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-n)) 2510 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-n))
2510 (setq math-t2 (funcall math-t1 math-solve-lhs math-solve-rhs))) 2511 (setq math-t2 (funcall math-t1 math-solve-lhs math-solve-rhs)))
2511 math-t2) 2512 math-t2)
2519 (defun math-try-solve-prod () 2520 (defun math-try-solve-prod ()
2520 (cond ((eq (car math-solve-lhs) '*) 2521 (cond ((eq (car math-solve-lhs) '*)
2521 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) 2522 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var))
2522 (math-try-solve-for (nth 2 math-solve-lhs) 2523 (math-try-solve-for (nth 2 math-solve-lhs)
2523 (math-div math-solve-rhs (nth 1 math-solve-lhs)) 2524 (math-div math-solve-rhs (nth 1 math-solve-lhs))
2524 (math-solve-sign math-try-solve-sign 2525 (math-solve-sign math-try-solve-sign
2525 (nth 1 math-solve-lhs)))) 2526 (nth 1 math-solve-lhs))))
2526 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) 2527 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var))
2527 (math-try-solve-for (nth 1 math-solve-lhs) 2528 (math-try-solve-for (nth 1 math-solve-lhs)
2528 (math-div math-solve-rhs (nth 2 math-solve-lhs)) 2529 (math-div math-solve-rhs (nth 2 math-solve-lhs))
2529 (math-solve-sign math-try-solve-sign 2530 (math-solve-sign math-try-solve-sign
2530 (nth 2 math-solve-lhs)))) 2531 (nth 2 math-solve-lhs))))
2531 ((Math-zerop math-solve-rhs) 2532 ((Math-zerop math-solve-rhs)
2532 (math-solve-prod (let ((math-solve-ranges math-solve-ranges)) 2533 (math-solve-prod (let ((math-solve-ranges math-solve-ranges))
2533 (math-try-solve-for (nth 2 math-solve-lhs) 0)) 2534 (math-try-solve-for (nth 2 math-solve-lhs) 0))
2534 (math-try-solve-for (nth 1 math-solve-lhs) 0))))) 2535 (math-try-solve-for (nth 1 math-solve-lhs) 0)))))
2535 ((eq (car math-solve-lhs) '/) 2536 ((eq (car math-solve-lhs) '/)
2536 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) 2537 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var))
2537 (math-try-solve-for (nth 2 math-solve-lhs) 2538 (math-try-solve-for (nth 2 math-solve-lhs)
2538 (math-div (nth 1 math-solve-lhs) math-solve-rhs) 2539 (math-div (nth 1 math-solve-lhs) math-solve-rhs)
2539 (math-solve-sign math-try-solve-sign 2540 (math-solve-sign math-try-solve-sign
2540 (nth 1 math-solve-lhs)))) 2541 (nth 1 math-solve-lhs))))
2541 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) 2542 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var))
2542 (math-try-solve-for (nth 1 math-solve-lhs) 2543 (math-try-solve-for (nth 1 math-solve-lhs)
2543 (math-mul math-solve-rhs (nth 2 math-solve-lhs)) 2544 (math-mul math-solve-rhs (nth 2 math-solve-lhs))
2544 (math-solve-sign math-try-solve-sign 2545 (math-solve-sign math-try-solve-sign
2545 (nth 2 math-solve-lhs)))) 2546 (nth 2 math-solve-lhs))))
2546 ((setq math-t1 (math-try-solve-for (math-sub (nth 1 math-solve-lhs) 2547 ((setq math-t1 (math-try-solve-for (math-sub (nth 1 math-solve-lhs)
2547 (math-mul (nth 2 math-solve-lhs) 2548 (math-mul (nth 2 math-solve-lhs)
2548 math-solve-rhs)) 2549 math-solve-rhs))
2549 0)) 2550 0))
2579 (math-try-solve-for 2580 (math-try-solve-for
2580 (nth 1 math-solve-lhs) 2581 (nth 1 math-solve-lhs)
2581 (math-normalize math-t2))) 2582 (math-normalize math-t2)))
2582 ((math-looks-negp (nth 2 math-solve-lhs)) 2583 ((math-looks-negp (nth 2 math-solve-lhs))
2583 (math-try-solve-for 2584 (math-try-solve-for
2584 (list '^ (nth 1 math-solve-lhs) 2585 (list '^ (nth 1 math-solve-lhs)
2585 (math-neg (nth 2 math-solve-lhs))) 2586 (math-neg (nth 2 math-solve-lhs)))
2586 (math-div 1 math-solve-rhs))) 2587 (math-div 1 math-solve-rhs)))
2587 ((and (eq math-solve-full t) 2588 ((and (eq math-solve-full t)
2588 (Math-integerp (nth 2 math-solve-lhs)) 2589 (Math-integerp (nth 2 math-solve-lhs))
2589 (math-known-realp (nth 1 math-solve-lhs))) 2590 (math-known-realp (nth 1 math-solve-lhs)))
2590 (setq math-t1 (math-normalize 2591 (setq math-t1 (math-normalize
2591 (list 'calcFunc-nroot math-solve-rhs 2592 (list 'calcFunc-nroot math-solve-rhs
2592 (nth 2 math-solve-lhs)))) 2593 (nth 2 math-solve-lhs))))
2593 (if (math-evenp (nth 2 math-solve-lhs)) 2594 (if (math-evenp (nth 2 math-solve-lhs))
2594 (setq math-t1 (math-solve-get-sign math-t1))) 2595 (setq math-t1 (math-solve-get-sign math-t1)))
2595 (math-try-solve-for 2596 (math-try-solve-for
2596 (nth 1 math-solve-lhs) math-t1 2597 (nth 1 math-solve-lhs) math-t1
2597 (and math-try-solve-sign 2598 (and math-try-solve-sign
2598 (math-oddp (nth 2 math-solve-lhs)) 2599 (math-oddp (nth 2 math-solve-lhs))
2599 (math-solve-sign math-try-solve-sign 2600 (math-solve-sign math-try-solve-sign
2600 (nth 2 math-solve-lhs))))) 2601 (nth 2 math-solve-lhs)))))
2601 (t (math-try-solve-for 2602 (t (math-try-solve-for
2602 (nth 1 math-solve-lhs) 2603 (nth 1 math-solve-lhs)
2603 (math-mul 2604 (math-mul
2604 (math-normalize 2605 (math-normalize
2626 (list 'calcFunc-nroot 2627 (list 'calcFunc-nroot
2627 math-solve-rhs 2628 math-solve-rhs
2628 (nth 2 math-solve-lhs)))) 2629 (nth 2 math-solve-lhs))))
2629 (and math-try-solve-sign 2630 (and math-try-solve-sign
2630 (math-oddp (nth 2 math-solve-lhs)) 2631 (math-oddp (nth 2 math-solve-lhs))
2631 (math-solve-sign math-try-solve-sign 2632 (math-solve-sign math-try-solve-sign
2632 (nth 2 math-solve-lhs))))))))) 2633 (nth 2 math-solve-lhs)))))))))
2633 (t nil))) 2634 (t nil)))
2634 2635
2635 (defun math-solve-prod (lsoln rsoln) 2636 (defun math-solve-prod (lsoln rsoln)
2636 (cond ((null lsoln) 2637 (cond ((null lsoln)
2663 (if sub-rhs (setq math-t1 (math-sub math-t1 math-solve-rhs))) 2664 (if sub-rhs (setq math-t1 (math-sub math-t1 math-solve-rhs)))
2664 (let ((math-poly-neg-powers nil)) 2665 (let ((math-poly-neg-powers nil))
2665 (setq math-t2 (math-mul (or math-poly-mult-powers 1) 2666 (setq math-t2 (math-mul (or math-poly-mult-powers 1)
2666 (let ((calc-prefer-frac t)) 2667 (let ((calc-prefer-frac t))
2667 (math-div 1 math-poly-frac-powers))) 2668 (math-div 1 math-poly-frac-powers)))
2668 math-t1 (math-is-polynomial 2669 math-t1 (math-is-polynomial
2669 (math-simplify (calcFunc-expand math-t1)) math-solve-b 50)))) 2670 (math-simplify (calcFunc-expand math-t1)) math-solve-b 50))))
2670 2671
2671 ;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2". 2672 ;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2".
2672 (defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3" 2673 (defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3"
2673 (let ((count 0)) 2674 (let ((count 0))
2692 n (1+ n))) 2693 n (1+ n)))
2693 (if okay 2694 (if okay
2694 (setq math-t3 (cons scale (cdr math-t3)) 2695 (setq math-t3 (cons scale (cdr math-t3))
2695 math-t1 new-t1)))) 2696 math-t1 new-t1))))
2696 (setq scale (1- scale))) 2697 (setq scale (1- scale)))
2697 (setq math-t3 (list (math-mul (car math-t3) math-t2) 2698 (setq math-t3 (list (math-mul (car math-t3) math-t2)
2698 (math-mul count math-t2))) 2699 (math-mul count math-t2)))
2699 (<= (1- (length math-t1)) max-degree))))) 2700 (<= (1- (length math-t1)) max-degree)))))
2700 2701
2701 (defun calcFunc-poly (expr var &optional degree) 2702 (defun calcFunc-poly (expr var &optional degree)
2702 (if degree 2703 (if degree
2731 (math-poly-frac-powers 1) 2732 (math-poly-frac-powers 1)
2732 (math-poly-exp-base t)) 2733 (math-poly-exp-base t))
2733 (and (not (equal math-solve-b math-solve-lhs)) 2734 (and (not (equal math-solve-b math-solve-lhs))
2734 (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs) 2735 (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs)
2735 (setq math-t3 '(1 0) math-t2 1 2736 (setq math-t3 '(1 0) math-t2 1
2736 math-t1 (math-is-polynomial math-solve-lhs 2737 math-t1 (math-is-polynomial math-solve-lhs
2737 math-solve-b 50)) 2738 math-solve-b 50))
2738 (if (and (equal math-poly-neg-powers '(1)) 2739 (if (and (equal math-poly-neg-powers '(1))
2739 (memq math-poly-mult-powers '(nil 1)) 2740 (memq math-poly-mult-powers '(nil 1))
2740 (eq math-poly-frac-powers 1) 2741 (eq math-poly-frac-powers 1)
2741 sub-rhs) 2742 sub-rhs)
3215 (or (and (not (math-expr-contains (nth 1 x) math-solve-var)) 3216 (or (and (not (math-expr-contains (nth 1 x) math-solve-var))
3216 (math-solve-find-root-in-prod (nth 2 x))) 3217 (math-solve-find-root-in-prod (nth 2 x)))
3217 (and (not (math-expr-contains (nth 2 x) math-solve-var)) 3218 (and (not (math-expr-contains (nth 2 x) math-solve-var))
3218 (math-solve-find-root-in-prod (nth 1 x)))))))) 3219 (math-solve-find-root-in-prod (nth 1 x))))))))
3219 3220
3220 ;; The variable math-solve-vars is local to math-solve-system, 3221 ;; The variable math-solve-vars is local to math-solve-system,
3221 ;; but is used by math-solve-system-rec. 3222 ;; but is used by math-solve-system-rec.
3222 (defvar math-solve-vars) 3223 (defvar math-solve-vars)
3223 3224
3224 ;; The variable math-solve-simplifying is local to math-solve-system 3225 ;; The variable math-solve-simplifying is local to math-solve-system
3225 ;; and math-solve-system-rec, but is used by math-solve-system-subst. 3226 ;; and math-solve-system-rec, but is used by math-solve-system-subst.
3280 3281
3281 ;; Try to solve for math-solve-system-vv the list of equations e2. 3282 ;; Try to solve for math-solve-system-vv the list of equations e2.
3282 (while (and e2 3283 (while (and e2
3283 (setq res2 (or (and (eq (car e2) eprev) 3284 (setq res2 (or (and (eq (car e2) eprev)
3284 res2) 3285 res2)
3285 (math-solve-for (car e2) 0 3286 (math-solve-for (car e2) 0
3286 math-solve-system-vv 3287 math-solve-system-vv
3287 math-solve-full)))) 3288 math-solve-full))))
3288 (setq eprev (car e2) 3289 (setq eprev (car e2)
3289 math-solve-system-res (cons (if (eq math-solve-full 'all) 3290 math-solve-system-res (cons (if (eq math-solve-full 'all)
3290 (cdr res2) 3291 (cdr res2)
3311 (math-solve-system-subst 3312 (math-solve-system-subst
3312 (cdr x))))) 3313 (cdr x)))))
3313 solns))) 3314 solns)))
3314 (if elim 3315 (if elim
3315 s 3316 s
3316 (cons (cons 3317 (cons (cons
3317 math-solve-system-vv 3318 math-solve-system-vv
3318 (apply 'append math-solve-system-res)) 3319 (apply 'append math-solve-system-res))
3319 s))))) 3320 s)))))
3320 (not math-solve-system-res)))) 3321 (not math-solve-system-res))))
3321 (setq e (cdr e))) 3322 (setq e (cdr e)))
3322 (not math-solve-system-res))) 3323 (not math-solve-system-res)))
3348 (setq accum (nconc accum 3349 (setq accum (nconc accum
3349 (mapcar (function 3350 (mapcar (function
3350 (lambda (r) 3351 (lambda (r)
3351 (if math-solve-simplifying 3352 (if math-solve-simplifying
3352 (math-simplify 3353 (math-simplify
3353 (math-expr-subst 3354 (math-expr-subst
3354 (car x) math-solve-system-vv r)) 3355 (car x) math-solve-system-vv r))
3355 (math-expr-subst 3356 (math-expr-subst
3356 (car x) math-solve-system-vv r)))) 3357 (car x) math-solve-system-vv r))))
3357 (car res2))) 3358 (car res2)))
3358 x (cdr x) 3359 x (cdr x)
3359 res2 (cdr res2))) 3360 res2 (cdr res2)))
3360 accum)) 3361 accum))