Mercurial > emacs
comparison lisp/calc/calcalg2.el @ 58229:7f5b01c17652
(math-integrate-by-parts): Removed unused variable var-thing.
(math-integ-depth, math-integ-level, math-integral-limit)
(math-enable-subst, math-any-substs, math-integ-msg)
(math-prev-parts-v, math-good-parts, math-max-integral-limit)
(math-int-threshold, math-int-factors, math-double-roots)
(math-solve-simplifying, var-IntegLimit, math-solve-sign)
(var-GenCount): Declared these variables.
(calcFunc-integ): Don't check if var-IntegLimit is bound.
(math-integral-cache, math-integral-cache-state): Move declarations
to earlier in the file.
(math-deriv-var, math-deriv-total, math-deriv-symb): New variables.
(math-derivative, calcFunc-deriv, calcFunc-tderiv): Replace
variables deriv-var, deriv-total and deriv-symb by declared variables
math-deriv-var, math-deriv-total and math-deriv-symb.
(math-cur-record): New variable.
(math-integral, math-replace-integral-parts, math-integrate-by-parts)
(calc-dump-integral-cache, math-try-integral): Replace variable
cur-record by declared variable math-cur-record.
(math-has-rules): New variable.
(math-try-integral, math-do-integral): Use declared variable
math-has-rules instead of has-rules.
(math-t1, math-t2, math-t3): New variables.
(math-do-integral, math-do-integral-methods, math-try-solve-for)
(math-try-solve-prod, math-solve-poly-funny-powers)
(math-solve-crunch-poly, math-decompose-poly)
(math-solve-find-root-term, math-find-root-in-prod): Replace
variables t1, t2, t3 by declared variables math-t1, math-t2,
math-t3.
(math-so-far, math-integ-expr): New variables.
(math-do-integral-methods, math-integ-try-linear-substitutions)
(math-integ-try-substitutions): Replace variables so-far and expr by
declared variables math-so-far and math-integ-expr.
(math-expr-parts): New variable.
(math-expr-rational-in, math-expr-rational-in-rec): Replace variable
parts by declared variable math-expr-parts.
(calc-low, calc-high): New variables.
(calcFunc-table, math-scan-for-limits): Replaced variable low and
high with the declared variable calc-low and calc-high.
(math-solve-var, math-solve-full): New variables.
(math-try-solve-for, math-try-solve-prod, math-solve-prod)
(math-decompose-poly, math-solve-quartic, math-poly-all-roots)
(math-solve-find-root-in-prod, math-solve-for, math-solve-system)
(math-solve-system-rec, math-solve-get-sign, math-solve-get-int):
Replace variables solve-var and solve-full with declared variables
math-solve-var and math-solve-full.
(math-solve-vars): New variable.
(math-solve-system, math-solve-system-rec): Replace variable
solve-vars with declared variable math-solve-vars.
(math-try-solve-sign): New variable.
(math-try-solve-for, math-try-solve-prod): Replace variable
sign by declared variable math-try-solve-sign.
(math-solve-b): New variable.
(math-solve-poly-funny-powers, math-decompose-poly): Replace variable
b by declared variable math-solve-b.
(math-solve-system-vv, math-solve-res): New variables
(math-solve-system-rec, math-solve-system-subst): Replaced variables
vv and res with declared variables math-solve-system-vv and
math-solve-system-res.
author | Jay Belanger <jay.p.belanger@gmail.com> |
---|---|
date | Mon, 15 Nov 2004 06:16:21 +0000 |
parents | 771eb065ad11 |
children | 87c7dff39cb0 b637c617432f |
comparison
equal
deleted
inserted
replaced
58228:4d76ea02ae1a | 58229:7f5b01c17652 |
---|---|
199 (calc-top-n 1) | 199 (calc-top-n 1) |
200 var | 200 var |
201 (prefix-numeric-value nterms)))))) | 201 (prefix-numeric-value nterms)))))) |
202 | 202 |
203 | 203 |
204 (defun math-derivative (expr) ; uses global values: deriv-var, deriv-total. | 204 ;; The following are global variables used by math-derivative and some |
205 (cond ((equal expr deriv-var) | 205 ;; related functions |
206 (defvar math-deriv-var) | |
207 (defvar math-deriv-total) | |
208 (defvar math-deriv-symb) | |
209 | |
210 (defun math-derivative (expr) | |
211 (cond ((equal expr math-deriv-var) | |
206 1) | 212 1) |
207 ((or (Math-scalarp expr) | 213 ((or (Math-scalarp expr) |
208 (eq (car expr) 'sdev) | 214 (eq (car expr) 'sdev) |
209 (and (eq (car expr) 'var) | 215 (and (eq (car expr) 'var) |
210 (or (not deriv-total) | 216 (or (not math-deriv-total) |
211 (math-const-var expr) | 217 (math-const-var expr) |
212 (progn | 218 (progn |
213 (math-setup-declarations) | 219 (math-setup-declarations) |
214 (memq 'const (nth 1 (or (assq (nth 2 expr) | 220 (memq 'const (nth 1 (or (assq (nth 2 expr) |
215 math-decls-cache) | 221 math-decls-cache) |
277 (math-mul (funcall handler (nth 1 expr)) | 283 (math-mul (funcall handler (nth 1 expr)) |
278 deriv))))) | 284 deriv))))) |
279 (let ((handler (get (car expr) 'math-derivative-n))) | 285 (let ((handler (get (car expr) 'math-derivative-n))) |
280 (and handler | 286 (and handler |
281 (funcall handler expr))))) | 287 (funcall handler expr))))) |
282 (and (not (eq deriv-symb 'pre-expand)) | 288 (and (not (eq math-deriv-symb 'pre-expand)) |
283 (let ((exp (math-expand-formula expr))) | 289 (let ((exp (math-expand-formula expr))) |
284 (and exp | 290 (and exp |
285 (or (let ((deriv-symb 'pre-expand)) | 291 (or (let ((math-deriv-symb 'pre-expand)) |
286 (catch 'math-deriv (math-derivative expr))) | 292 (catch 'math-deriv (math-derivative expr))) |
287 (math-derivative exp))))) | 293 (math-derivative exp))))) |
288 (if (or (Math-objvecp expr) | 294 (if (or (Math-objvecp expr) |
289 (eq (car expr) 'var) | 295 (eq (car expr) 'var) |
290 (not (symbolp (car expr)))) | 296 (not (symbolp (car expr)))) |
291 (if deriv-symb | 297 (if math-deriv-symb |
292 (throw 'math-deriv nil) | 298 (throw 'math-deriv nil) |
293 (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv) | 299 (list (if math-deriv-total 'calcFunc-tderiv 'calcFunc-deriv) |
294 expr | 300 expr |
295 deriv-var)) | 301 math-deriv-var)) |
296 (let ((accum 0) | 302 (let ((accum 0) |
297 (arg expr) | 303 (arg expr) |
298 (n 1) | 304 (n 1) |
299 derv) | 305 derv) |
300 (while (setq arg (cdr arg)) | 306 (while (setq arg (cdr arg)) |
320 (math-mul | 326 (math-mul |
321 derv | 327 derv |
322 (let ((handler (get func prop))) | 328 (let ((handler (get func prop))) |
323 (or (and prop handler | 329 (or (and prop handler |
324 (apply handler (cdr expr))) | 330 (apply handler (cdr expr))) |
325 (if (and deriv-symb | 331 (if (and math-deriv-symb |
326 (not (get func | 332 (not (get func |
327 'calc-user-defn))) | 333 'calc-user-defn))) |
328 (throw 'math-deriv nil) | 334 (throw 'math-deriv nil) |
329 (cons func (cdr expr)))))))))) | 335 (cons func (cdr expr)))))))))) |
330 (setq n (1+ n))) | 336 (setq n (1+ n))) |
331 accum)))))) | 337 accum)))))) |
332 | 338 |
333 (defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb) | 339 (defun calcFunc-deriv (expr math-deriv-var &optional deriv-value math-deriv-symb) |
334 (let* ((deriv-total nil) | 340 (let* ((math-deriv-total nil) |
335 (res (catch 'math-deriv (math-derivative expr)))) | 341 (res (catch 'math-deriv (math-derivative expr)))) |
336 (or (eq (car-safe res) 'calcFunc-deriv) | 342 (or (eq (car-safe res) 'calcFunc-deriv) |
337 (null res) | 343 (null res) |
338 (setq res (math-normalize res))) | 344 (setq res (math-normalize res))) |
339 (and res | 345 (and res |
340 (if deriv-value | 346 (if deriv-value |
341 (math-expr-subst res deriv-var deriv-value) | 347 (math-expr-subst res math-deriv-var deriv-value) |
342 res)))) | 348 res)))) |
343 | 349 |
344 (defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb) | 350 (defun calcFunc-tderiv (expr math-deriv-var &optional deriv-value math-deriv-symb) |
345 (math-setup-declarations) | 351 (math-setup-declarations) |
346 (let* ((deriv-total t) | 352 (let* ((math-deriv-total t) |
347 (res (catch 'math-deriv (math-derivative expr)))) | 353 (res (catch 'math-deriv (math-derivative expr)))) |
348 (or (eq (car-safe res) 'calcFunc-tderiv) | 354 (or (eq (car-safe res) 'calcFunc-tderiv) |
349 (null res) | 355 (null res) |
350 (setq res (math-normalize res))) | 356 (setq res (math-normalize res))) |
351 (and res | 357 (and res |
352 (if deriv-value | 358 (if deriv-value |
353 (math-expr-subst res deriv-var deriv-value) | 359 (math-expr-subst res math-deriv-var deriv-value) |
354 res)))) | 360 res)))) |
355 | 361 |
356 (put 'calcFunc-inv\' 'math-derivative-1 | 362 (put 'calcFunc-inv\' 'math-derivative-1 |
357 (function (lambda (u) (math-neg (math-div 1 (math-sqr u)))))) | 363 (function (lambda (u) (math-neg (math-div 1 (math-sqr u)))))) |
358 | 364 |
538 2)))) | 544 2)))) |
539 | 545 |
540 (put 'calcFunc-sum 'math-derivative-n | 546 (put 'calcFunc-sum 'math-derivative-n |
541 (function | 547 (function |
542 (lambda (expr) | 548 (lambda (expr) |
543 (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var) | 549 (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) |
544 (throw 'math-deriv nil) | 550 (throw 'math-deriv nil) |
545 (cons 'calcFunc-sum | 551 (cons 'calcFunc-sum |
546 (cons (math-derivative (nth 1 expr)) | 552 (cons (math-derivative (nth 1 expr)) |
547 (cdr (cdr expr)))))))) | 553 (cdr (cdr expr)))))))) |
548 | 554 |
549 (put 'calcFunc-prod 'math-derivative-n | 555 (put 'calcFunc-prod 'math-derivative-n |
550 (function | 556 (function |
551 (lambda (expr) | 557 (lambda (expr) |
552 (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var) | 558 (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var) |
553 (throw 'math-deriv nil) | 559 (throw 'math-deriv nil) |
554 (math-mul expr | 560 (math-mul expr |
555 (cons 'calcFunc-sum | 561 (cons 'calcFunc-sum |
556 (cons (math-div (math-derivative (nth 1 expr)) | 562 (cons (math-div (math-derivative (nth 1 expr)) |
557 (nth 1 expr)) | 563 (nth 1 expr)) |
559 | 565 |
560 (put 'calcFunc-integ 'math-derivative-n | 566 (put 'calcFunc-integ 'math-derivative-n |
561 (function | 567 (function |
562 (lambda (expr) | 568 (lambda (expr) |
563 (if (= (length expr) 3) | 569 (if (= (length expr) 3) |
564 (if (equal (nth 2 expr) deriv-var) | 570 (if (equal (nth 2 expr) math-deriv-var) |
565 (nth 1 expr) | 571 (nth 1 expr) |
566 (math-normalize | 572 (math-normalize |
567 (list 'calcFunc-integ | 573 (list 'calcFunc-integ |
568 (math-derivative (nth 1 expr)) | 574 (math-derivative (nth 1 expr)) |
569 (nth 2 expr)))) | 575 (nth 2 expr)))) |
574 (nth 4 expr)))) | 580 (nth 4 expr)))) |
575 (math-add (math-sub (math-mul upper | 581 (math-add (math-sub (math-mul upper |
576 (math-derivative (nth 4 expr))) | 582 (math-derivative (nth 4 expr))) |
577 (math-mul lower | 583 (math-mul lower |
578 (math-derivative (nth 3 expr)))) | 584 (math-derivative (nth 3 expr)))) |
579 (if (equal (nth 2 expr) deriv-var) | 585 (if (equal (nth 2 expr) math-deriv-var) |
580 0 | 586 0 |
581 (math-normalize | 587 (math-normalize |
582 (list 'calcFunc-integ | 588 (list 'calcFunc-integ |
583 (math-derivative (nth 1 expr)) (nth 2 expr) | 589 (math-derivative (nth 1 expr)) (nth 2 expr) |
584 (nth 3 expr) (nth 4 expr))))))))))) | 590 (nth 3 expr) (nth 4 expr))))))))))) |
602 (defvar math-integ-var '(var X ---)) | 608 (defvar math-integ-var '(var X ---)) |
603 (defvar math-integ-var-2 '(var Y ---)) | 609 (defvar math-integ-var-2 '(var Y ---)) |
604 (defvar math-integ-vars (list 'f math-integ-var math-integ-var-2)) | 610 (defvar math-integ-vars (list 'f math-integ-var math-integ-var-2)) |
605 (defvar math-integ-var-list (list math-integ-var)) | 611 (defvar math-integ-var-list (list math-integ-var)) |
606 (defvar math-integ-var-list-list (list math-integ-var-list)) | 612 (defvar math-integ-var-list-list (list math-integ-var-list)) |
613 | |
614 ;; math-integ-depth is a local variable for math-try-integral, but is used | |
615 ;; by math-integral and math-tracing-integral | |
616 ;; which are called (directly or indirectly) by math-try-integral. | |
617 (defvar math-integ-depth) | |
618 ;; math-integ-level is a local variable for math-try-integral, but is used | |
619 ;; by math-integral, math-do-integral, math-tracing-integral, | |
620 ;; math-sub-integration, math-integrate-by-parts and | |
621 ;; math-integrate-by-substitution, which are called (directly or | |
622 ;; indirectly) by math-try-integral. | |
623 (defvar math-integ-level) | |
624 ;; math-integral-limit is a local variable for calcFunc-integ, but is | |
625 ;; used by math-tracing-integral, math-sub-integration and | |
626 ;; math-try-integration. | |
627 (defvar math-integral-limit) | |
607 | 628 |
608 (defmacro math-tracing-integral (&rest parts) | 629 (defmacro math-tracing-integral (&rest parts) |
609 (list 'and | 630 (list 'and |
610 'trace-buffer | 631 'trace-buffer |
611 (list 'save-excursion | 632 (list 'save-excursion |
627 ;;; ( A N ) Integral of A failed at level N; | 648 ;;; ( A N ) Integral of A failed at level N; |
628 ;;; ( A busy ) Currently working on integral of A; | 649 ;;; ( A busy ) Currently working on integral of A; |
629 ;;; ( A parts ) Currently working, integ-by-parts; | 650 ;;; ( A parts ) Currently working, integ-by-parts; |
630 ;;; ( A parts2 ) Currently working, integ-by-parts; | 651 ;;; ( A parts2 ) Currently working, integ-by-parts; |
631 ;;; ( A cancelled ) Ignore this cache entry; | 652 ;;; ( A cancelled ) Ignore this cache entry; |
632 ;;; ( A [B] ) Same result as for cur-record = B. | 653 ;;; ( A [B] ) Same result as for math-cur-record = B. |
654 | |
655 ;; math-cur-record is a local variable for math-try-integral, but is used | |
656 ;; by math-integral, math-replace-integral-parts and math-integrate-by-parts | |
657 ;; which are called (directly or indirectly) by math-try-integral, as well as | |
658 ;; by calc-dump-integral-cache | |
659 (defvar math-cur-record) | |
660 ;; math-enable-subst and math-any-substs are local variables for | |
661 ;; calcFunc-integ, but are used by math-integral and math-try-integral. | |
662 (defvar math-enable-subst) | |
663 (defvar math-any-substs) | |
664 | |
665 ;; math-integ-msg is a local variable for math-try-integral, but is | |
666 ;; used (both locally and non-locally) by math-integral. | |
667 (defvar math-integ-msg) | |
668 | |
669 (defvar math-integral-cache nil) | |
670 (defvar math-integral-cache-state nil) | |
671 | |
633 (defun math-integral (expr &optional simplify same-as-above) | 672 (defun math-integral (expr &optional simplify same-as-above) |
634 (let* ((simp cur-record) | 673 (let* ((simp math-cur-record) |
635 (cur-record (assoc expr math-integral-cache)) | 674 (math-cur-record (assoc expr math-integral-cache)) |
636 (math-integ-depth (1+ math-integ-depth)) | 675 (math-integ-depth (1+ math-integ-depth)) |
637 (val 'cancelled)) | 676 (val 'cancelled)) |
638 (math-tracing-integral "Integrating " | 677 (math-tracing-integral "Integrating " |
639 (math-format-value expr 1000) | 678 (math-format-value expr 1000) |
640 "...\n") | 679 "...\n") |
641 (and cur-record | 680 (and math-cur-record |
642 (progn | 681 (progn |
643 (math-tracing-integral "Found " | 682 (math-tracing-integral "Found " |
644 (math-format-value (nth 1 cur-record) 1000)) | 683 (math-format-value (nth 1 math-cur-record) 1000)) |
645 (and (consp (nth 1 cur-record)) | 684 (and (consp (nth 1 math-cur-record)) |
646 (math-replace-integral-parts cur-record)) | 685 (math-replace-integral-parts math-cur-record)) |
647 (math-tracing-integral " => " | 686 (math-tracing-integral " => " |
648 (math-format-value (nth 1 cur-record) 1000) | 687 (math-format-value (nth 1 math-cur-record) 1000) |
649 "\n"))) | 688 "\n"))) |
650 (or (and cur-record | 689 (or (and math-cur-record |
651 (not (eq (nth 1 cur-record) 'cancelled)) | 690 (not (eq (nth 1 math-cur-record) 'cancelled)) |
652 (or (not (integerp (nth 1 cur-record))) | 691 (or (not (integerp (nth 1 math-cur-record))) |
653 (>= (nth 1 cur-record) math-integ-level))) | 692 (>= (nth 1 math-cur-record) math-integ-level))) |
654 (and (math-integral-contains-parts expr) | 693 (and (math-integral-contains-parts expr) |
655 (progn | 694 (progn |
656 (setq val nil) | 695 (setq val nil) |
657 t)) | 696 t)) |
658 (unwind-protect | 697 (unwind-protect |
663 (calc-set-command-flag 'clear-message) | 702 (calc-set-command-flag 'clear-message) |
664 (setq math-integ-msg (format | 703 (setq math-integ-msg (format |
665 "Working... Integrating %s" | 704 "Working... Integrating %s" |
666 (math-format-flat-expr expr 0))) | 705 (math-format-flat-expr expr 0))) |
667 (message math-integ-msg))) | 706 (message math-integ-msg))) |
668 (if cur-record | 707 (if math-cur-record |
669 (setcar (cdr cur-record) | 708 (setcar (cdr math-cur-record) |
670 (if same-as-above (vector simp) 'busy)) | 709 (if same-as-above (vector simp) 'busy)) |
671 (setq cur-record | 710 (setq math-cur-record |
672 (list expr (if same-as-above (vector simp) 'busy)) | 711 (list expr (if same-as-above (vector simp) 'busy)) |
673 math-integral-cache (cons cur-record | 712 math-integral-cache (cons math-cur-record |
674 math-integral-cache))) | 713 math-integral-cache))) |
675 (if (eq simplify 'yes) | 714 (if (eq simplify 'yes) |
676 (progn | 715 (progn |
677 (math-tracing-integral "Simplifying...") | 716 (math-tracing-integral "Simplifying...") |
678 (setq simp (math-simplify expr)) | 717 (setq simp (math-simplify expr)) |
690 (math-tracing-integral "Trying again after " | 729 (math-tracing-integral "Trying again after " |
691 "simplification...\n") | 730 "simplification...\n") |
692 (setq val (math-integral simp 'no t)))))))) | 731 (setq val (math-integral simp 'no t)))))))) |
693 (if (eq calc-display-working-message 'lots) | 732 (if (eq calc-display-working-message 'lots) |
694 (message math-integ-msg))) | 733 (message math-integ-msg))) |
695 (setcar (cdr cur-record) (or val | 734 (setcar (cdr math-cur-record) (or val |
696 (if (or math-enable-subst | 735 (if (or math-enable-subst |
697 (not math-any-substs)) | 736 (not math-any-substs)) |
698 math-integ-level | 737 math-integ-level |
699 'cancelled))))) | 738 'cancelled))))) |
700 (setq val cur-record) | 739 (setq val math-cur-record) |
701 (while (vectorp (nth 1 val)) | 740 (while (vectorp (nth 1 val)) |
702 (setq val (aref (nth 1 val) 0))) | 741 (setq val (aref (nth 1 val) 0))) |
703 (setq val (if (memq (nth 1 val) '(parts parts2)) | 742 (setq val (if (memq (nth 1 val) '(parts parts2)) |
704 (progn | 743 (progn |
705 (setcar (cdr val) 'parts2) | 744 (setcar (cdr val) 'parts2) |
710 (math-format-value expr 1000) | 749 (math-format-value expr 1000) |
711 " is " | 750 " is " |
712 (math-format-value val 1000) | 751 (math-format-value val 1000) |
713 "\n") | 752 "\n") |
714 val)) | 753 val)) |
715 (defvar math-integral-cache nil) | |
716 (defvar math-integral-cache-state nil) | |
717 | 754 |
718 (defun math-integral-contains-parts (expr) | 755 (defun math-integral-contains-parts (expr) |
719 (if (Math-primp expr) | 756 (if (Math-primp expr) |
720 (and (eq (car-safe expr) 'var) | 757 (and (eq (car-safe expr) 'var) |
721 (eq (nth 1 expr) 'PARTS) | 758 (eq (nth 1 expr) 'PARTS) |
733 (consp (nth 2 (car expr))) | 770 (consp (nth 2 (car expr))) |
734 (if (listp (nth 1 (nth 2 (car expr)))) | 771 (if (listp (nth 1 (nth 2 (car expr)))) |
735 (progn | 772 (progn |
736 (setcar expr (nth 1 (nth 2 (car expr)))) | 773 (setcar expr (nth 1 (nth 2 (car expr)))) |
737 (math-replace-integral-parts (cons 'foo expr))) | 774 (math-replace-integral-parts (cons 'foo expr))) |
738 (setcar (cdr cur-record) 'cancelled))) | 775 (setcar (cdr math-cur-record) 'cancelled))) |
739 (math-replace-integral-parts (car expr))))))) | 776 (math-replace-integral-parts (car expr))))))) |
740 | 777 |
741 (defvar math-linear-subst-tried t | 778 (defvar math-linear-subst-tried t |
742 "Non-nil means that a linear substitution has been tried.") | 779 "Non-nil means that a linear substitution has been tried.") |
743 | 780 |
781 ;; The variable math-has-rules is a local variable for math-try-integral, | |
782 ;; but is used by math-do-integral, which is called (non-directly) by | |
783 ;; math-try-integral. | |
784 (defvar math-has-rules) | |
785 | |
786 ;; math-old-integ is a local variable for math-do-integral, but is | |
787 ;; used by math-sub-integration. | |
788 (defvar math-old-integ) | |
789 | |
790 ;; The variables math-t1, math-t2 and math-t3 are local to | |
791 ;; math-do-integral, math-try-solve-for and math-decompose-poly, but | |
792 ;; are used by functions they call (directly or indirectly); | |
793 ;; math-do-integral calls math-do-integral-methods; | |
794 ;; math-try-solve-for calls math-try-solve-prod, | |
795 ;; math-solve-find-root-term and math-solve-find-root-in-prod; | |
796 ;; math-decompose-poly calls math-solve-poly-funny-powers and | |
797 ;; math-solve-crunch-poly. | |
798 (defvar math-t1) | |
799 (defvar math-t2) | |
800 (defvar math-t3) | |
801 | |
744 (defun math-do-integral (expr) | 802 (defun math-do-integral (expr) |
745 (let ((math-linear-subst-tried nil) | 803 (let ((math-linear-subst-tried nil) |
746 t1 t2) | 804 math-t1 math-t2) |
747 (or (cond ((not (math-expr-contains expr math-integ-var)) | 805 (or (cond ((not (math-expr-contains expr math-integ-var)) |
748 (math-mul expr math-integ-var)) | 806 (math-mul expr math-integ-var)) |
749 ((equal expr math-integ-var) | 807 ((equal expr math-integ-var) |
750 (math-div (math-sqr expr) 2)) | 808 (math-div (math-sqr expr) 2)) |
751 ((eq (car expr) '+) | 809 ((eq (car expr) '+) |
752 (and (setq t1 (math-integral (nth 1 expr))) | 810 (and (setq math-t1 (math-integral (nth 1 expr))) |
753 (setq t2 (math-integral (nth 2 expr))) | 811 (setq math-t2 (math-integral (nth 2 expr))) |
754 (math-add t1 t2))) | 812 (math-add math-t1 math-t2))) |
755 ((eq (car expr) '-) | 813 ((eq (car expr) '-) |
756 (and (setq t1 (math-integral (nth 1 expr))) | 814 (and (setq math-t1 (math-integral (nth 1 expr))) |
757 (setq t2 (math-integral (nth 2 expr))) | 815 (setq math-t2 (math-integral (nth 2 expr))) |
758 (math-sub t1 t2))) | 816 (math-sub math-t1 math-t2))) |
759 ((eq (car expr) 'neg) | 817 ((eq (car expr) 'neg) |
760 (and (setq t1 (math-integral (nth 1 expr))) | 818 (and (setq math-t1 (math-integral (nth 1 expr))) |
761 (math-neg t1))) | 819 (math-neg math-t1))) |
762 ((eq (car expr) '*) | 820 ((eq (car expr) '*) |
763 (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) | 821 (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) |
764 (and (setq t1 (math-integral (nth 2 expr))) | 822 (and (setq math-t1 (math-integral (nth 2 expr))) |
765 (math-mul (nth 1 expr) t1))) | 823 (math-mul (nth 1 expr) math-t1))) |
766 ((not (math-expr-contains (nth 2 expr) math-integ-var)) | 824 ((not (math-expr-contains (nth 2 expr) math-integ-var)) |
767 (and (setq t1 (math-integral (nth 1 expr))) | 825 (and (setq math-t1 (math-integral (nth 1 expr))) |
768 (math-mul t1 (nth 2 expr)))) | 826 (math-mul math-t1 (nth 2 expr)))) |
769 ((memq (car-safe (nth 1 expr)) '(+ -)) | 827 ((memq (car-safe (nth 1 expr)) '(+ -)) |
770 (math-integral (list (car (nth 1 expr)) | 828 (math-integral (list (car (nth 1 expr)) |
771 (math-mul (nth 1 (nth 1 expr)) | 829 (math-mul (nth 1 (nth 1 expr)) |
772 (nth 2 expr)) | 830 (nth 2 expr)) |
773 (math-mul (nth 2 (nth 1 expr)) | 831 (math-mul (nth 2 (nth 1 expr)) |
782 'yes t)))) | 840 'yes t)))) |
783 ((eq (car expr) '/) | 841 ((eq (car expr) '/) |
784 (cond ((and (not (math-expr-contains (nth 1 expr) | 842 (cond ((and (not (math-expr-contains (nth 1 expr) |
785 math-integ-var)) | 843 math-integ-var)) |
786 (not (math-equal-int (nth 1 expr) 1))) | 844 (not (math-equal-int (nth 1 expr) 1))) |
787 (and (setq t1 (math-integral (math-div 1 (nth 2 expr)))) | 845 (and (setq math-t1 (math-integral (math-div 1 (nth 2 expr)))) |
788 (math-mul (nth 1 expr) t1))) | 846 (math-mul (nth 1 expr) math-t1))) |
789 ((not (math-expr-contains (nth 2 expr) math-integ-var)) | 847 ((not (math-expr-contains (nth 2 expr) math-integ-var)) |
790 (and (setq t1 (math-integral (nth 1 expr))) | 848 (and (setq math-t1 (math-integral (nth 1 expr))) |
791 (math-div t1 (nth 2 expr)))) | 849 (math-div math-t1 (nth 2 expr)))) |
792 ((and (eq (car-safe (nth 1 expr)) '*) | 850 ((and (eq (car-safe (nth 1 expr)) '*) |
793 (not (math-expr-contains (nth 1 (nth 1 expr)) | 851 (not (math-expr-contains (nth 1 (nth 1 expr)) |
794 math-integ-var))) | 852 math-integ-var))) |
795 (and (setq t1 (math-integral | 853 (and (setq math-t1 (math-integral |
796 (math-div (nth 2 (nth 1 expr)) | 854 (math-div (nth 2 (nth 1 expr)) |
797 (nth 2 expr)))) | 855 (nth 2 expr)))) |
798 (math-mul t1 (nth 1 (nth 1 expr))))) | 856 (math-mul math-t1 (nth 1 (nth 1 expr))))) |
799 ((and (eq (car-safe (nth 1 expr)) '*) | 857 ((and (eq (car-safe (nth 1 expr)) '*) |
800 (not (math-expr-contains (nth 2 (nth 1 expr)) | 858 (not (math-expr-contains (nth 2 (nth 1 expr)) |
801 math-integ-var))) | 859 math-integ-var))) |
802 (and (setq t1 (math-integral | 860 (and (setq math-t1 (math-integral |
803 (math-div (nth 1 (nth 1 expr)) | 861 (math-div (nth 1 (nth 1 expr)) |
804 (nth 2 expr)))) | 862 (nth 2 expr)))) |
805 (math-mul t1 (nth 2 (nth 1 expr))))) | 863 (math-mul math-t1 (nth 2 (nth 1 expr))))) |
806 ((and (eq (car-safe (nth 2 expr)) '*) | 864 ((and (eq (car-safe (nth 2 expr)) '*) |
807 (not (math-expr-contains (nth 1 (nth 2 expr)) | 865 (not (math-expr-contains (nth 1 (nth 2 expr)) |
808 math-integ-var))) | 866 math-integ-var))) |
809 (and (setq t1 (math-integral | 867 (and (setq math-t1 (math-integral |
810 (math-div (nth 1 expr) | 868 (math-div (nth 1 expr) |
811 (nth 2 (nth 2 expr))))) | 869 (nth 2 (nth 2 expr))))) |
812 (math-div t1 (nth 1 (nth 2 expr))))) | 870 (math-div math-t1 (nth 1 (nth 2 expr))))) |
813 ((and (eq (car-safe (nth 2 expr)) '*) | 871 ((and (eq (car-safe (nth 2 expr)) '*) |
814 (not (math-expr-contains (nth 2 (nth 2 expr)) | 872 (not (math-expr-contains (nth 2 (nth 2 expr)) |
815 math-integ-var))) | 873 math-integ-var))) |
816 (and (setq t1 (math-integral | 874 (and (setq math-t1 (math-integral |
817 (math-div (nth 1 expr) | 875 (math-div (nth 1 expr) |
818 (nth 1 (nth 2 expr))))) | 876 (nth 1 (nth 2 expr))))) |
819 (math-div t1 (nth 2 (nth 2 expr))))) | 877 (math-div math-t1 (nth 2 (nth 2 expr))))) |
820 ((eq (car-safe (nth 2 expr)) 'calcFunc-exp) | 878 ((eq (car-safe (nth 2 expr)) 'calcFunc-exp) |
821 (math-integral | 879 (math-integral |
822 (math-mul (nth 1 expr) | 880 (math-mul (nth 1 expr) |
823 (list 'calcFunc-exp | 881 (list 'calcFunc-exp |
824 (math-neg (nth 1 (nth 2 expr))))))))) | 882 (math-neg (nth 1 (nth 2 expr))))))))) |
825 ((eq (car expr) '^) | 883 ((eq (car expr) '^) |
826 (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) | 884 (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) |
827 (or (and (setq t1 (math-is-polynomial (nth 2 expr) | 885 (or (and (setq math-t1 (math-is-polynomial (nth 2 expr) |
828 math-integ-var 1)) | 886 math-integ-var 1)) |
829 (math-div expr | 887 (math-div expr |
830 (math-mul (nth 1 t1) | 888 (math-mul (nth 1 math-t1) |
831 (math-normalize | 889 (math-normalize |
832 (list 'calcFunc-ln | 890 (list 'calcFunc-ln |
833 (nth 1 expr)))))) | 891 (nth 1 expr)))))) |
834 (math-integral | 892 (math-integral |
835 (list 'calcFunc-exp | 893 (list 'calcFunc-exp |
841 ((not (math-expr-contains (nth 2 expr) math-integ-var)) | 899 ((not (math-expr-contains (nth 2 expr) math-integ-var)) |
842 (if (and (integerp (nth 2 expr)) (< (nth 2 expr) 0)) | 900 (if (and (integerp (nth 2 expr)) (< (nth 2 expr) 0)) |
843 (math-integral | 901 (math-integral |
844 (list '/ 1 (math-pow (nth 1 expr) (- (nth 2 expr)))) | 902 (list '/ 1 (math-pow (nth 1 expr) (- (nth 2 expr)))) |
845 nil t) | 903 nil t) |
846 (or (and (setq t1 (math-is-polynomial (nth 1 expr) | 904 (or (and (setq math-t1 (math-is-polynomial (nth 1 expr) |
847 math-integ-var | 905 math-integ-var |
848 1)) | 906 1)) |
849 (setq t2 (math-add (nth 2 expr) 1)) | 907 (setq math-t2 (math-add (nth 2 expr) 1)) |
850 (math-div (math-pow (nth 1 expr) t2) | 908 (math-div (math-pow (nth 1 expr) math-t2) |
851 (math-mul t2 (nth 1 t1)))) | 909 (math-mul math-t2 (nth 1 math-t1)))) |
852 (and (Math-negp (nth 2 expr)) | 910 (and (Math-negp (nth 2 expr)) |
853 (math-integral | 911 (math-integral |
854 (math-div 1 | 912 (math-div 1 |
855 (math-pow (nth 1 expr) | 913 (math-pow (nth 1 expr) |
856 (math-neg | 914 (math-neg |
857 (nth 2 expr)))) | 915 (nth 2 expr)))) |
858 nil t)) | 916 nil t)) |
859 nil)))))) | 917 nil)))))) |
860 | 918 |
861 ;; Integral of a polynomial. | 919 ;; Integral of a polynomial. |
862 (and (setq t1 (math-is-polynomial expr math-integ-var 20)) | 920 (and (setq math-t1 (math-is-polynomial expr math-integ-var 20)) |
863 (let ((accum 0) | 921 (let ((accum 0) |
864 (n 1)) | 922 (n 1)) |
865 (while t1 | 923 (while math-t1 |
866 (if (setq accum (math-add accum | 924 (if (setq accum (math-add accum |
867 (math-div (math-mul (car t1) | 925 (math-div (math-mul (car math-t1) |
868 (math-pow | 926 (math-pow |
869 math-integ-var | 927 math-integ-var |
870 n)) | 928 n)) |
871 n)) | 929 n)) |
872 t1 (cdr t1)) | 930 math-t1 (cdr math-t1)) |
873 (setq n (1+ n)))) | 931 (setq n (1+ n)))) |
874 accum)) | 932 accum)) |
875 | 933 |
876 ;; Try looking it up! | 934 ;; Try looking it up! |
877 (cond ((= (length expr) 2) | 935 (cond ((= (length expr) 2) |
878 (and (symbolp (car expr)) | 936 (and (symbolp (car expr)) |
879 (setq t1 (get (car expr) 'math-integral)) | 937 (setq math-t1 (get (car expr) 'math-integral)) |
880 (progn | 938 (progn |
881 (while (and t1 | 939 (while (and math-t1 |
882 (not (setq t2 (funcall (car t1) | 940 (not (setq math-t2 (funcall (car math-t1) |
883 (nth 1 expr))))) | 941 (nth 1 expr))))) |
884 (setq t1 (cdr t1))) | 942 (setq math-t1 (cdr math-t1))) |
885 (and t2 (math-normalize t2))))) | 943 (and math-t2 (math-normalize math-t2))))) |
886 ((= (length expr) 3) | 944 ((= (length expr) 3) |
887 (and (symbolp (car expr)) | 945 (and (symbolp (car expr)) |
888 (setq t1 (get (car expr) 'math-integral-2)) | 946 (setq math-t1 (get (car expr) 'math-integral-2)) |
889 (progn | 947 (progn |
890 (while (and t1 | 948 (while (and math-t1 |
891 (not (setq t2 (funcall (car t1) | 949 (not (setq math-t2 (funcall (car math-t1) |
892 (nth 1 expr) | 950 (nth 1 expr) |
893 (nth 2 expr))))) | 951 (nth 2 expr))))) |
894 (setq t1 (cdr t1))) | 952 (setq math-t1 (cdr math-t1))) |
895 (and t2 (math-normalize t2)))))) | 953 (and math-t2 (math-normalize math-t2)))))) |
896 | 954 |
897 ;; Integral of a rational function. | 955 ;; Integral of a rational function. |
898 (and (math-ratpoly-p expr math-integ-var) | 956 (and (math-ratpoly-p expr math-integ-var) |
899 (setq t1 (calcFunc-apart expr math-integ-var)) | 957 (setq math-t1 (calcFunc-apart expr math-integ-var)) |
900 (not (equal t1 expr)) | 958 (not (equal math-t1 expr)) |
901 (math-integral t1)) | 959 (math-integral math-t1)) |
902 | 960 |
903 ;; Try user-defined integration rules. | 961 ;; Try user-defined integration rules. |
904 (and has-rules | 962 (and math-has-rules |
905 (let ((math-old-integ (symbol-function 'calcFunc-integ)) | 963 (let ((math-old-integ (symbol-function 'calcFunc-integ)) |
906 (input (list 'calcFunc-integtry expr math-integ-var)) | 964 (input (list 'calcFunc-integtry expr math-integ-var)) |
907 res part) | 965 res part) |
908 (unwind-protect | 966 (unwind-protect |
909 (progn | 967 (progn |
973 (and (or (= math-integ-level math-integral-limit) | 1031 (and (or (= math-integ-level math-integral-limit) |
974 (not (math-expr-calls res 'calcFunc-integ))) | 1032 (not (math-expr-calls res 'calcFunc-integ))) |
975 res))) | 1033 res))) |
976 (list 'calcFunc-integfailed expr))) | 1034 (list 'calcFunc-integfailed expr))) |
977 | 1035 |
978 (defun math-do-integral-methods (expr) | 1036 ;; math-so-far is a local variable for math-do-integral-methods, but |
979 (let ((so-far math-integ-var-list-list) | 1037 ;; is used by math-integ-try-linear-substitutions and |
1038 ;; math-integ-try-substitutions. | |
1039 (defvar math-so-far) | |
1040 | |
1041 ;; math-integ-expr is a local variable for math-do-integral-methods, | |
1042 ;; but is used by math-integ-try-linear-substitutions and | |
1043 ;; math-integ-try-substitutions. | |
1044 (defvar math-integ-expr) | |
1045 | |
1046 (defun math-do-integral-methods (math-integ-expr) | |
1047 (let ((math-so-far math-integ-var-list-list) | |
980 rat-in) | 1048 rat-in) |
981 | 1049 |
982 ;; Integration by substitution, for various likely sub-expressions. | 1050 ;; Integration by substitution, for various likely sub-expressions. |
983 ;; (In first pass, we look only for sub-exprs that are linear in X.) | 1051 ;; (In first pass, we look only for sub-exprs that are linear in X.) |
984 (or (math-integ-try-linear-substitutions expr) | 1052 (or (math-integ-try-linear-substitutions math-integ-expr) |
985 (math-integ-try-substitutions expr) | 1053 (math-integ-try-substitutions math-integ-expr) |
986 | 1054 |
987 ;; If function has sines and cosines, try tan(x/2) substitution. | 1055 ;; If function has sines and cosines, try tan(x/2) substitution. |
988 (and (let ((p (setq rat-in (math-expr-rational-in expr)))) | 1056 (and (let ((p (setq rat-in (math-expr-rational-in math-integ-expr)))) |
989 (while (and p | 1057 (while (and p |
990 (memq (car (car p)) '(calcFunc-sin | 1058 (memq (car (car p)) '(calcFunc-sin |
991 calcFunc-cos | 1059 calcFunc-cos |
992 calcFunc-tan)) | 1060 calcFunc-tan)) |
993 (equal (nth 1 (car p)) math-integ-var)) | 1061 (equal (nth 1 (car p)) math-integ-var)) |
994 (setq p (cdr p))) | 1062 (setq p (cdr p))) |
995 (null p)) | 1063 (null p)) |
996 (or (and (math-integ-parts-easy expr) | 1064 (or (and (math-integ-parts-easy math-integ-expr) |
997 (math-integ-try-parts expr t)) | 1065 (math-integ-try-parts math-integ-expr t)) |
998 (math-integrate-by-good-substitution | 1066 (math-integrate-by-good-substitution |
999 expr (list 'calcFunc-tan (math-div math-integ-var 2))))) | 1067 math-integ-expr (list 'calcFunc-tan (math-div math-integ-var 2))))) |
1000 | 1068 |
1001 ;; If function has sinh and cosh, try tanh(x/2) substitution. | 1069 ;; If function has sinh and cosh, try tanh(x/2) substitution. |
1002 (and (let ((p rat-in)) | 1070 (and (let ((p rat-in)) |
1003 (while (and p | 1071 (while (and p |
1004 (memq (car (car p)) '(calcFunc-sinh | 1072 (memq (car (car p)) '(calcFunc-sinh |
1006 calcFunc-tanh | 1074 calcFunc-tanh |
1007 calcFunc-exp)) | 1075 calcFunc-exp)) |
1008 (equal (nth 1 (car p)) math-integ-var)) | 1076 (equal (nth 1 (car p)) math-integ-var)) |
1009 (setq p (cdr p))) | 1077 (setq p (cdr p))) |
1010 (null p)) | 1078 (null p)) |
1011 (or (and (math-integ-parts-easy expr) | 1079 (or (and (math-integ-parts-easy math-integ-expr) |
1012 (math-integ-try-parts expr t)) | 1080 (math-integ-try-parts math-integ-expr t)) |
1013 (math-integrate-by-good-substitution | 1081 (math-integrate-by-good-substitution |
1014 expr (list 'calcFunc-tanh (math-div math-integ-var 2))))) | 1082 math-integ-expr (list 'calcFunc-tanh (math-div math-integ-var 2))))) |
1015 | 1083 |
1016 ;; If function has square roots, try sin, tan, or sec substitution. | 1084 ;; If function has square roots, try sin, tan, or sec substitution. |
1017 (and (let ((p rat-in)) | 1085 (and (let ((p rat-in)) |
1018 (setq t1 nil) | 1086 (setq math-t1 nil) |
1019 (while (and p | 1087 (while (and p |
1020 (or (equal (car p) math-integ-var) | 1088 (or (equal (car p) math-integ-var) |
1021 (and (eq (car (car p)) 'calcFunc-sqrt) | 1089 (and (eq (car (car p)) 'calcFunc-sqrt) |
1022 (setq t1 (math-is-polynomial | 1090 (setq math-t1 (math-is-polynomial |
1023 (nth 1 (setq t2 (car p))) | 1091 (nth 1 (setq math-t2 (car p))) |
1024 math-integ-var 2))))) | 1092 math-integ-var 2))))) |
1025 (setq p (cdr p))) | 1093 (setq p (cdr p))) |
1026 (and (null p) t1)) | 1094 (and (null p) math-t1)) |
1027 (if (cdr (cdr t1)) | 1095 (if (cdr (cdr math-t1)) |
1028 (if (math-guess-if-neg (nth 2 t1)) | 1096 (if (math-guess-if-neg (nth 2 math-t1)) |
1029 (let* ((c (math-sqrt (math-neg (nth 2 t1)))) | 1097 (let* ((c (math-sqrt (math-neg (nth 2 math-t1)))) |
1030 (d (math-div (nth 1 t1) (math-mul -2 c))) | 1098 (d (math-div (nth 1 math-t1) (math-mul -2 c))) |
1031 (a (math-sqrt (math-add (car t1) (math-sqr d))))) | 1099 (a (math-sqrt (math-add (car math-t1) (math-sqr d))))) |
1032 (math-integrate-by-good-substitution | 1100 (math-integrate-by-good-substitution |
1033 expr (list 'calcFunc-arcsin | 1101 math-integ-expr (list 'calcFunc-arcsin |
1034 (math-div-thru | 1102 (math-div-thru |
1035 (math-add (math-mul c math-integ-var) d) | 1103 (math-add (math-mul c math-integ-var) d) |
1036 a)))) | 1104 a)))) |
1037 (let* ((c (math-sqrt (nth 2 t1))) | 1105 (let* ((c (math-sqrt (nth 2 math-t1))) |
1038 (d (math-div (nth 1 t1) (math-mul 2 c))) | 1106 (d (math-div (nth 1 math-t1) (math-mul 2 c))) |
1039 (aa (math-sub (car t1) (math-sqr d)))) | 1107 (aa (math-sub (car math-t1) (math-sqr d)))) |
1040 (if (and nil (not (and (eq d 0) (eq c 1)))) | 1108 (if (and nil (not (and (eq d 0) (eq c 1)))) |
1041 (math-integrate-by-good-substitution | 1109 (math-integrate-by-good-substitution |
1042 expr (math-add (math-mul c math-integ-var) d)) | 1110 math-integ-expr (math-add (math-mul c math-integ-var) d)) |
1043 (if (math-guess-if-neg aa) | 1111 (if (math-guess-if-neg aa) |
1044 (math-integrate-by-good-substitution | 1112 (math-integrate-by-good-substitution |
1045 expr (list 'calcFunc-arccosh | 1113 math-integ-expr (list 'calcFunc-arccosh |
1046 (math-div-thru | 1114 (math-div-thru |
1047 (math-add (math-mul c math-integ-var) | 1115 (math-add (math-mul c math-integ-var) |
1048 d) | 1116 d) |
1049 (math-sqrt (math-neg aa))))) | 1117 (math-sqrt (math-neg aa))))) |
1050 (math-integrate-by-good-substitution | 1118 (math-integrate-by-good-substitution |
1051 expr (list 'calcFunc-arcsinh | 1119 math-integ-expr (list 'calcFunc-arcsinh |
1052 (math-div-thru | 1120 (math-div-thru |
1053 (math-add (math-mul c math-integ-var) | 1121 (math-add (math-mul c math-integ-var) |
1054 d) | 1122 d) |
1055 (math-sqrt aa)))))))) | 1123 (math-sqrt aa)))))))) |
1056 (math-integrate-by-good-substitution expr t2)) ) | 1124 (math-integrate-by-good-substitution math-integ-expr math-t2)) ) |
1057 | 1125 |
1058 ;; Try integration by parts. | 1126 ;; Try integration by parts. |
1059 (math-integ-try-parts expr) | 1127 (math-integ-try-parts math-integ-expr) |
1060 | 1128 |
1061 ;; Give up. | 1129 ;; Give up. |
1062 nil))) | 1130 nil))) |
1063 | 1131 |
1064 (defun math-integ-parts-easy (expr) | 1132 (defun math-integ-parts-easy (expr) |
1073 (and (natnump (nth 2 expr)) | 1141 (and (natnump (nth 2 expr)) |
1074 (math-integ-parts-easy (nth 1 expr)))) | 1142 (math-integ-parts-easy (nth 1 expr)))) |
1075 ((eq (car expr) 'neg) | 1143 ((eq (car expr) 'neg) |
1076 (math-integ-parts-easy (nth 1 expr))) | 1144 (math-integ-parts-easy (nth 1 expr))) |
1077 (t t))) | 1145 (t t))) |
1146 | |
1147 ;; math-prev-parts-v is local to calcFunc-integ (as well as | |
1148 ;; math-integrate-by-parts), but is used by math-integ-try-parts. | |
1149 (defvar math-prev-parts-v) | |
1150 | |
1151 ;; math-good-parts is local to calcFunc-integ (as well as | |
1152 ;; math-integ-try-parts), but is used by math-integrate-by-parts. | |
1153 (defvar math-good-parts) | |
1154 | |
1078 | 1155 |
1079 (defun math-integ-try-parts (expr &optional math-good-parts) | 1156 (defun math-integ-try-parts (expr &optional math-good-parts) |
1080 ;; Integration by parts: | 1157 ;; Integration by parts: |
1081 ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) | 1158 ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) |
1082 ;; where h(x) = integ(g(x),x). | 1159 ;; where h(x) = integ(g(x),x). |
1110 (math-doing-parts t) | 1187 (math-doing-parts t) |
1111 v temp) | 1188 v temp) |
1112 (and (>= math-integ-level 0) | 1189 (and (>= math-integ-level 0) |
1113 (unwind-protect | 1190 (unwind-protect |
1114 (progn | 1191 (progn |
1115 (setcar (cdr cur-record) 'parts) | 1192 (setcar (cdr math-cur-record) 'parts) |
1116 (math-tracing-integral "Integrating by parts, u = " | 1193 (math-tracing-integral "Integrating by parts, u = " |
1117 (math-format-value u 1000) | 1194 (math-format-value u 1000) |
1118 ", v' = " | 1195 ", v' = " |
1119 (math-format-value vprime 1000) | 1196 (math-format-value vprime 1000) |
1120 "\n") | 1197 "\n") |
1121 (and (setq v (math-integral vprime)) | 1198 (and (setq v (math-integral vprime)) |
1122 (setq temp (calcFunc-deriv u math-integ-var nil t)) | 1199 (setq temp (calcFunc-deriv u math-integ-var nil t)) |
1123 (setq temp (let ((math-prev-parts-v v)) | 1200 (setq temp (let ((math-prev-parts-v v)) |
1124 (math-integral (math-mul v temp) 'yes))) | 1201 (math-integral (math-mul v temp) 'yes))) |
1125 (setq temp (math-sub (math-mul u v) temp)) | 1202 (setq temp (math-sub (math-mul u v) temp)) |
1126 (if (eq (nth 1 cur-record) 'parts) | 1203 (if (eq (nth 1 math-cur-record) 'parts) |
1127 (calcFunc-expand temp) | 1204 (calcFunc-expand temp) |
1128 (setq v (list 'var 'PARTS cur-record) | 1205 (setq v (list 'var 'PARTS math-cur-record) |
1129 var-thing (list 'vec (math-sub v temp) v) | |
1130 temp (let (calc-next-why) | 1206 temp (let (calc-next-why) |
1131 (math-solve-for (math-sub v temp) 0 v nil))) | 1207 (math-solve-for (math-sub v temp) 0 v nil))) |
1132 (and temp (not (integerp temp)) | 1208 (and temp (not (integerp temp)) |
1133 (math-simplify-extended temp))))) | 1209 (math-simplify-extended temp))))) |
1134 (setcar (cdr cur-record) 'busy))))) | 1210 (setcar (cdr math-cur-record) 'busy))))) |
1135 | 1211 |
1136 ;;; This tries two different formulations, hoping the algebraic simplifier | 1212 ;;; This tries two different formulations, hoping the algebraic simplifier |
1137 ;;; will be strong enough to handle at least one. | 1213 ;;; will be strong enough to handle at least one. |
1138 (defun math-integrate-by-substitution (expr u &optional user uinv uinvprime) | 1214 (defun math-integrate-by-substitution (expr u &optional user uinv uinvprime) |
1139 (and (> math-integ-level 0) | 1215 (and (> math-integ-level 0) |
1200 (math-expr-contains sub-expr math-integ-var) | 1276 (math-expr-contains sub-expr math-integ-var) |
1201 (let ((res nil)) | 1277 (let ((res nil)) |
1202 (while (and (setq sub-expr (cdr sub-expr)) | 1278 (while (and (setq sub-expr (cdr sub-expr)) |
1203 (or (not (math-linear-in (car sub-expr) | 1279 (or (not (math-linear-in (car sub-expr) |
1204 math-integ-var)) | 1280 math-integ-var)) |
1205 (assoc (car sub-expr) so-far) | 1281 (assoc (car sub-expr) math-so-far) |
1206 (progn | 1282 (progn |
1207 (setq so-far (cons (list (car sub-expr)) | 1283 (setq math-so-far (cons (list (car sub-expr)) |
1208 so-far)) | 1284 math-so-far)) |
1209 (not (setq res | 1285 (not (setq res |
1210 (math-integrate-by-substitution | 1286 (math-integrate-by-substitution |
1211 expr (car sub-expr)))))))) | 1287 math-integ-expr (car sub-expr)))))))) |
1212 res)) | 1288 res)) |
1213 (let ((res nil)) | 1289 (let ((res nil)) |
1214 (while (and (setq sub-expr (cdr sub-expr)) | 1290 (while (and (setq sub-expr (cdr sub-expr)) |
1215 (not (setq res (math-integ-try-linear-substitutions | 1291 (not (setq res (math-integ-try-linear-substitutions |
1216 (car sub-expr)))))) | 1292 (car sub-expr)))))) |
1217 res)))) | 1293 res)))) |
1218 | 1294 |
1219 ;;; Recursively try different substitutions based on various sub-expressions. | 1295 ;;; Recursively try different substitutions based on various sub-expressions. |
1220 (defun math-integ-try-substitutions (sub-expr &optional allow-rat) | 1296 (defun math-integ-try-substitutions (sub-expr &optional allow-rat) |
1221 (and (not (Math-primp sub-expr)) | 1297 (and (not (Math-primp sub-expr)) |
1222 (not (assoc sub-expr so-far)) | 1298 (not (assoc sub-expr math-so-far)) |
1223 (math-expr-contains sub-expr math-integ-var) | 1299 (math-expr-contains sub-expr math-integ-var) |
1224 (or (and (if (and (not (memq (car sub-expr) '(+ - * / neg))) | 1300 (or (and (if (and (not (memq (car sub-expr) '(+ - * / neg))) |
1225 (not (and (eq (car sub-expr) '^) | 1301 (not (and (eq (car sub-expr) '^) |
1226 (integerp (nth 2 sub-expr))))) | 1302 (integerp (nth 2 sub-expr))))) |
1227 (setq allow-rat t) | 1303 (setq allow-rat t) |
1228 (prog1 allow-rat (setq allow-rat nil))) | 1304 (prog1 allow-rat (setq allow-rat nil))) |
1229 (not (eq sub-expr expr)) | 1305 (not (eq sub-expr math-integ-expr)) |
1230 (or (math-integrate-by-substitution expr sub-expr) | 1306 (or (math-integrate-by-substitution math-integ-expr sub-expr) |
1231 (and (eq (car sub-expr) '^) | 1307 (and (eq (car sub-expr) '^) |
1232 (integerp (nth 2 sub-expr)) | 1308 (integerp (nth 2 sub-expr)) |
1233 (< (nth 2 sub-expr) 0) | 1309 (< (nth 2 sub-expr) 0) |
1234 (math-integ-try-substitutions | 1310 (math-integ-try-substitutions |
1235 (math-pow (nth 1 sub-expr) (- (nth 2 sub-expr))) | 1311 (math-pow (nth 1 sub-expr) (- (nth 2 sub-expr))) |
1236 t)))) | 1312 t)))) |
1237 (let ((res nil)) | 1313 (let ((res nil)) |
1238 (setq so-far (cons (list sub-expr) so-far)) | 1314 (setq math-so-far (cons (list sub-expr) math-so-far)) |
1239 (while (and (setq sub-expr (cdr sub-expr)) | 1315 (while (and (setq sub-expr (cdr sub-expr)) |
1240 (not (setq res (math-integ-try-substitutions | 1316 (not (setq res (math-integ-try-substitutions |
1241 (car sub-expr) allow-rat))))) | 1317 (car sub-expr) allow-rat))))) |
1242 res)))) | 1318 res)))) |
1243 | 1319 |
1320 ;; The variable math-expr-parts is local to math-expr-rational-in, | |
1321 ;; but is used by math-expr-rational-in-rec | |
1322 | |
1244 (defun math-expr-rational-in (expr) | 1323 (defun math-expr-rational-in (expr) |
1245 (let ((parts nil)) | 1324 (let ((math-expr-parts nil)) |
1246 (math-expr-rational-in-rec expr) | 1325 (math-expr-rational-in-rec expr) |
1247 (mapcar 'car parts))) | 1326 (mapcar 'car math-expr-parts))) |
1248 | 1327 |
1249 (defun math-expr-rational-in-rec (expr) | 1328 (defun math-expr-rational-in-rec (expr) |
1250 (cond ((Math-primp expr) | 1329 (cond ((Math-primp expr) |
1251 (and (equal expr math-integ-var) | 1330 (and (equal expr math-integ-var) |
1252 (not (assoc expr parts)) | 1331 (not (assoc expr math-expr-parts)) |
1253 (setq parts (cons (list expr) parts)))) | 1332 (setq math-expr-parts (cons (list expr) math-expr-parts)))) |
1254 ((or (memq (car expr) '(+ - * / neg)) | 1333 ((or (memq (car expr) '(+ - * / neg)) |
1255 (and (eq (car expr) '^) (integerp (nth 2 expr)))) | 1334 (and (eq (car expr) '^) (integerp (nth 2 expr)))) |
1256 (math-expr-rational-in-rec (nth 1 expr)) | 1335 (math-expr-rational-in-rec (nth 1 expr)) |
1257 (and (nth 2 expr) (math-expr-rational-in-rec (nth 2 expr)))) | 1336 (and (nth 2 expr) (math-expr-rational-in-rec (nth 2 expr)))) |
1258 ((and (eq (car expr) '^) | 1337 ((and (eq (car expr) '^) |
1259 (eq (math-quarter-integer (nth 2 expr)) 2)) | 1338 (eq (math-quarter-integer (nth 2 expr)) 2)) |
1260 (math-expr-rational-in-rec (list 'calcFunc-sqrt (nth 1 expr)))) | 1339 (math-expr-rational-in-rec (list 'calcFunc-sqrt (nth 1 expr)))) |
1261 (t | 1340 (t |
1262 (and (not (assoc expr parts)) | 1341 (and (not (assoc expr math-expr-parts)) |
1263 (math-expr-contains expr math-integ-var) | 1342 (math-expr-contains expr math-integ-var) |
1264 (setq parts (cons (list expr) parts)))))) | 1343 (setq math-expr-parts (cons (list expr) math-expr-parts)))))) |
1265 | 1344 |
1266 (defun math-expr-calls (expr funcs &optional arg-contains) | 1345 (defun math-expr-calls (expr funcs &optional arg-contains) |
1267 (if (consp expr) | 1346 (if (consp expr) |
1268 (if (or (memq (car expr) funcs) | 1347 (if (or (memq (car expr) funcs) |
1269 (and (eq (car expr) '^) (eq (car funcs) 'calcFunc-sqrt) | 1348 (and (eq (car expr) '^) (eq (car funcs) 'calcFunc-sqrt) |
1293 (defun calc-dump-integral-cache (&optional arg) | 1372 (defun calc-dump-integral-cache (&optional arg) |
1294 (interactive "P") | 1373 (interactive "P") |
1295 (let ((buf (current-buffer))) | 1374 (let ((buf (current-buffer))) |
1296 (unwind-protect | 1375 (unwind-protect |
1297 (let ((p math-integral-cache) | 1376 (let ((p math-integral-cache) |
1298 cur-record) | 1377 math-cur-record) |
1299 (display-buffer (get-buffer-create "*Integral Cache*")) | 1378 (display-buffer (get-buffer-create "*Integral Cache*")) |
1300 (set-buffer (get-buffer "*Integral Cache*")) | 1379 (set-buffer (get-buffer "*Integral Cache*")) |
1301 (erase-buffer) | 1380 (erase-buffer) |
1302 (while p | 1381 (while p |
1303 (setq cur-record (car p)) | 1382 (setq math-cur-record (car p)) |
1304 (or arg (math-replace-integral-parts cur-record)) | 1383 (or arg (math-replace-integral-parts math-cur-record)) |
1305 (insert (math-format-flat-expr (car cur-record) 0) | 1384 (insert (math-format-flat-expr (car math-cur-record) 0) |
1306 " --> " | 1385 " --> " |
1307 (if (symbolp (nth 1 cur-record)) | 1386 (if (symbolp (nth 1 math-cur-record)) |
1308 (concat "(" (symbol-name (nth 1 cur-record)) ")") | 1387 (concat "(" (symbol-name (nth 1 math-cur-record)) ")") |
1309 (math-format-flat-expr (nth 1 cur-record) 0)) | 1388 (math-format-flat-expr (nth 1 math-cur-record) 0)) |
1310 "\n") | 1389 "\n") |
1311 (setq p (cdr p))) | 1390 (setq p (cdr p))) |
1312 (goto-char (point-min))) | 1391 (goto-char (point-min))) |
1313 (set-buffer buf)))) | 1392 (set-buffer buf)))) |
1314 | 1393 |
1394 ;; The variable math-max-integral-limit is local to calcFunc-integ, | |
1395 ;; but is used by math-try-integral. | |
1396 (defvar math-max-integral-limit) | |
1397 | |
1315 (defun math-try-integral (expr) | 1398 (defun math-try-integral (expr) |
1316 (let ((math-integ-level math-integral-limit) | 1399 (let ((math-integ-level math-integral-limit) |
1317 (math-integ-depth 0) | 1400 (math-integ-depth 0) |
1318 (math-integ-msg "Working...done") | 1401 (math-integ-msg "Working...done") |
1319 (cur-record nil) ; a technicality | 1402 (math-cur-record nil) ; a technicality |
1320 (math-integrating t) | 1403 (math-integrating t) |
1321 (calc-prefer-frac t) | 1404 (calc-prefer-frac t) |
1322 (calc-symbolic-mode t) | 1405 (calc-symbolic-mode t) |
1323 (has-rules (calc-has-rules 'var-IntegRules))) | 1406 (math-has-rules (calc-has-rules 'var-IntegRules))) |
1324 (or (math-integral expr 'yes) | 1407 (or (math-integral expr 'yes) |
1325 (and math-any-substs | 1408 (and math-any-substs |
1326 (setq math-enable-subst t) | 1409 (setq math-enable-subst t) |
1327 (math-integral expr 'yes)) | 1410 (math-integral expr 'yes)) |
1328 (and (> math-max-integral-limit math-integral-limit) | 1411 (and (> math-max-integral-limit math-integral-limit) |
1329 (setq math-integral-limit math-max-integral-limit | 1412 (setq math-integral-limit math-max-integral-limit |
1330 math-integ-level math-integral-limit) | 1413 math-integ-level math-integral-limit) |
1331 (math-integral expr 'yes))))) | 1414 (math-integral expr 'yes))))) |
1415 | |
1416 (defvar var-IntegLimit nil) | |
1332 | 1417 |
1333 (defun calcFunc-integ (expr var &optional low high) | 1418 (defun calcFunc-integ (expr var &optional low high) |
1334 (cond | 1419 (cond |
1335 ;; Do these even if the parts turn out not to be integrable. | 1420 ;; Do these even if the parts turn out not to be integrable. |
1336 ((eq (car-safe expr) '+) | 1421 ((eq (car-safe expr) '+) |
1390 (calc-var-value 'var-IntegRules) | 1475 (calc-var-value 'var-IntegRules) |
1391 (calc-var-value 'var-IntegSimpRules)))) | 1476 (calc-var-value 'var-IntegSimpRules)))) |
1392 (or (equal state math-integral-cache-state) | 1477 (or (equal state math-integral-cache-state) |
1393 (setq math-integral-cache-state state | 1478 (setq math-integral-cache-state state |
1394 math-integral-cache nil))) | 1479 math-integral-cache nil))) |
1395 (let* ((math-max-integral-limit (or (and (boundp 'var-IntegLimit) | 1480 (let* ((math-max-integral-limit (or (and (natnump var-IntegLimit) |
1396 (natnump var-IntegLimit) | |
1397 var-IntegLimit) | 1481 var-IntegLimit) |
1398 3)) | 1482 3)) |
1399 (math-integral-limit 1) | 1483 (math-integral-limit 1) |
1400 (sexpr (math-expr-subst expr var math-integ-var)) | 1484 (sexpr (math-expr-subst expr var math-integ-var)) |
1401 (trace-buffer (get-buffer "*Trace*")) | 1485 (trace-buffer (get-buffer "*Trace*")) |
1712 | 1796 |
1713 | 1797 |
1714 | 1798 |
1715 (defvar math-tabulate-initial nil) | 1799 (defvar math-tabulate-initial nil) |
1716 (defvar math-tabulate-function nil) | 1800 (defvar math-tabulate-function nil) |
1717 (defun calcFunc-table (expr var &optional low high step) | 1801 |
1718 (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf))) | 1802 ;; The variables calc-low and calc-high are local to calcFunc-table, |
1719 (or high (setq high low low 1)) | 1803 ;; but are used by math-scan-for-limits. |
1720 (and (or (math-infinitep low) (math-infinitep high)) | 1804 (defvar calc-low) |
1805 (defvar calc-high) | |
1806 | |
1807 (defun calcFunc-table (expr var &optional calc-low calc-high step) | |
1808 (or calc-low | |
1809 (setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf))) | |
1810 (or calc-high (setq calc-high calc-low calc-low 1)) | |
1811 (and (or (math-infinitep calc-low) (math-infinitep calc-high)) | |
1721 (not step) | 1812 (not step) |
1722 (math-scan-for-limits expr)) | 1813 (math-scan-for-limits expr)) |
1723 (and step (math-zerop step) (math-reject-arg step 'nonzerop)) | 1814 (and step (math-zerop step) (math-reject-arg step 'nonzerop)) |
1724 (let ((known (+ (if (Math-objectp low) 1 0) | 1815 (let ((known (+ (if (Math-objectp calc-low) 1 0) |
1725 (if (Math-objectp high) 1 0) | 1816 (if (Math-objectp calc-high) 1 0) |
1726 (if (or (null step) (Math-objectp step)) 1 0))) | 1817 (if (or (null step) (Math-objectp step)) 1 0))) |
1727 (count '(var inf var-inf)) | 1818 (count '(var inf var-inf)) |
1728 vec) | 1819 vec) |
1729 (or (= known 2) ; handy optimization | 1820 (or (= known 2) ; handy optimization |
1730 (equal high '(var inf var-inf)) | 1821 (equal calc-high '(var inf var-inf)) |
1731 (progn | 1822 (progn |
1732 (setq count (math-div (math-sub high low) (or step 1))) | 1823 (setq count (math-div (math-sub calc-high calc-low) (or step 1))) |
1733 (or (Math-objectp count) | 1824 (or (Math-objectp count) |
1734 (setq count (math-simplify count))) | 1825 (setq count (math-simplify count))) |
1735 (if (Math-messy-integerp count) | 1826 (if (Math-messy-integerp count) |
1736 (setq count (math-trunc count))))) | 1827 (setq count (math-trunc count))))) |
1737 (if (Math-negp count) | 1828 (if (Math-negp count) |
1743 (math-working-step 0)) | 1834 (math-working-step 0)) |
1744 (setq expr (math-evaluate-expr | 1835 (setq expr (math-evaluate-expr |
1745 (math-expr-subst expr var '(var DUMMY var-DUMMY)))) | 1836 (math-expr-subst expr var '(var DUMMY var-DUMMY)))) |
1746 (while (>= count 0) | 1837 (while (>= count 0) |
1747 (setq math-working-step (1+ math-working-step) | 1838 (setq math-working-step (1+ math-working-step) |
1748 var-DUMMY low | 1839 var-DUMMY calc-low |
1749 vec (cond ((eq math-tabulate-function 'calcFunc-sum) | 1840 vec (cond ((eq math-tabulate-function 'calcFunc-sum) |
1750 (math-add vec (math-evaluate-expr expr))) | 1841 (math-add vec (math-evaluate-expr expr))) |
1751 ((eq math-tabulate-function 'calcFunc-prod) | 1842 ((eq math-tabulate-function 'calcFunc-prod) |
1752 (math-mul vec (math-evaluate-expr expr))) | 1843 (math-mul vec (math-evaluate-expr expr))) |
1753 (t | 1844 (t |
1754 (cons (math-evaluate-expr expr) vec))) | 1845 (cons (math-evaluate-expr expr) vec))) |
1755 low (math-add low (or step 1)) | 1846 calc-low (math-add calc-low (or step 1)) |
1756 count (1- count))) | 1847 count (1- count))) |
1757 (if math-tabulate-function | 1848 (if math-tabulate-function |
1758 vec | 1849 vec |
1759 (cons 'vec (nreverse vec)))) | 1850 (cons 'vec (nreverse vec)))) |
1760 (if (Math-integerp count) | 1851 (if (Math-integerp count) |
1761 (calc-record-why 'fixnump high) | 1852 (calc-record-why 'fixnump calc-high) |
1762 (if (Math-num-integerp low) | 1853 (if (Math-num-integerp calc-low) |
1763 (if (Math-num-integerp high) | 1854 (if (Math-num-integerp calc-high) |
1764 (calc-record-why 'integerp step) | 1855 (calc-record-why 'integerp step) |
1765 (calc-record-why 'integerp high)) | 1856 (calc-record-why 'integerp calc-high)) |
1766 (calc-record-why 'integerp low))) | 1857 (calc-record-why 'integerp calc-low))) |
1767 (append (list (or math-tabulate-function 'calcFunc-table) | 1858 (append (list (or math-tabulate-function 'calcFunc-table) |
1768 expr var) | 1859 expr var) |
1769 (and (not (and (equal low '(neg (var inf var-inf))) | 1860 (and (not (and (equal calc-low '(neg (var inf var-inf))) |
1770 (equal high '(var inf var-inf)))) | 1861 (equal calc-high '(var inf var-inf)))) |
1771 (list low high)) | 1862 (list calc-low calc-high)) |
1772 (and step (list step)))))) | 1863 (and step (list step)))))) |
1773 | 1864 |
1774 (defun math-scan-for-limits (x) | 1865 (defun math-scan-for-limits (x) |
1775 (cond ((Math-primp x)) | 1866 (cond ((Math-primp x)) |
1776 ((and (eq (car x) 'calcFunc-subscr) | 1867 ((and (eq (car x) 'calcFunc-subscr) |
1783 temp) | 1874 temp) |
1784 (and low-val (math-realp low-val) | 1875 (and low-val (math-realp low-val) |
1785 high-val (math-realp high-val)) | 1876 high-val (math-realp high-val)) |
1786 (and (Math-lessp high-val low-val) | 1877 (and (Math-lessp high-val low-val) |
1787 (setq temp low-val low-val high-val high-val temp)) | 1878 (setq temp low-val low-val high-val high-val temp)) |
1788 (setq low (math-max low (math-ceiling low-val)) | 1879 (setq calc-low (math-max calc-low (math-ceiling low-val)) |
1789 high (math-min high (math-floor high-val))))) | 1880 calc-high (math-min calc-high (math-floor high-val))))) |
1790 (t | 1881 (t |
1791 (while (setq x (cdr x)) | 1882 (while (setq x (cdr x)) |
1792 (math-scan-for-limits (car x)))))) | 1883 (math-scan-for-limits (car x)))))) |
1793 | 1884 |
1794 | 1885 |
2171 | 2262 |
2172 | 2263 |
2173 | 2264 |
2174 | 2265 |
2175 (defvar math-solve-ranges nil) | 2266 (defvar math-solve-ranges nil) |
2176 ;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears | 2267 (defvar math-solve-sign) |
2177 ;;; in lhs but not in rhs or rhs'; return rhs'. | 2268 ;;; Attempt to reduce math-solve-lhs = math-solve-rhs to |
2178 ;;; Uses global values: solve-*. | 2269 ;;; math-solve-var = math-solve-rhs', where math-solve-var appears |
2179 (defun math-try-solve-for (lhs rhs &optional sign no-poly) | 2270 ;;; in math-solve-lhs but not in math-solve-rhs or math-solve-rhs'; |
2180 (let (t1 t2 t3) | 2271 ;;; return math-solve-rhs'. |
2181 (cond ((equal lhs solve-var) | 2272 ;;; Uses global values: math-solve-var, math-solve-full. |
2182 (setq math-solve-sign sign) | 2273 (defvar math-solve-var) |
2183 (if (eq solve-full 'all) | 2274 (defvar math-solve-full) |
2184 (let ((vec (list 'vec (math-evaluate-expr rhs))) | 2275 |
2276 ;; The variables math-solve-lhs, math-solve-rhs and math-try-solve-sign | |
2277 ;; are local to math-try-solve-for, but are used by math-try-solve-prod. | |
2278 ;; (math-solve-lhs and math-solve-rhs are is also local to | |
2279 ;; math-decompose-poly, but used by math-solve-poly-funny-powers.) | |
2280 (defvar math-solve-lhs) | |
2281 (defvar math-solve-rhs) | |
2282 | |
2283 (defun math-try-solve-for | |
2284 (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly) | |
2285 (let (math-t1 math-t2 math-t3) | |
2286 (cond ((equal math-solve-lhs math-solve-var) | |
2287 (setq math-solve-sign math-try-solve-sign) | |
2288 (if (eq math-solve-full 'all) | |
2289 (let ((vec (list 'vec (math-evaluate-expr math-solve-rhs))) | |
2185 newvec var p) | 2290 newvec var p) |
2186 (while math-solve-ranges | 2291 (while math-solve-ranges |
2187 (setq p (car math-solve-ranges) | 2292 (setq p (car math-solve-ranges) |
2188 var (car p) | 2293 var (car p) |
2189 newvec (list 'vec)) | 2294 newvec (list 'vec)) |
2192 (cdr (math-expr-subst | 2297 (cdr (math-expr-subst |
2193 vec var (car p)))))) | 2298 vec var (car p)))))) |
2194 (setq vec newvec | 2299 (setq vec newvec |
2195 math-solve-ranges (cdr math-solve-ranges))) | 2300 math-solve-ranges (cdr math-solve-ranges))) |
2196 (math-normalize vec)) | 2301 (math-normalize vec)) |
2197 rhs)) | 2302 math-solve-rhs)) |
2198 ((Math-primp lhs) | 2303 ((Math-primp math-solve-lhs) |
2199 nil) | 2304 nil) |
2200 ((and (eq (car lhs) '-) | 2305 ((and (eq (car math-solve-lhs) '-) |
2201 (eq (car-safe (nth 1 lhs)) (car-safe (nth 2 lhs))) | 2306 (eq (car-safe (nth 1 math-solve-lhs)) (car-safe (nth 2 math-solve-lhs))) |
2202 (Math-zerop rhs) | 2307 (Math-zerop math-solve-rhs) |
2203 (= (length (nth 1 lhs)) 2) | 2308 (= (length (nth 1 math-solve-lhs)) 2) |
2204 (= (length (nth 2 lhs)) 2) | 2309 (= (length (nth 2 math-solve-lhs)) 2) |
2205 (setq t1 (get (car (nth 1 lhs)) 'math-inverse)) | 2310 (setq math-t1 (get (car (nth 1 math-solve-lhs)) 'math-inverse)) |
2206 (setq t2 (funcall t1 '(var SOLVEDUM SOLVEDUM))) | 2311 (setq math-t2 (funcall math-t1 '(var SOLVEDUM SOLVEDUM))) |
2207 (eq (math-expr-contains-count t2 '(var SOLVEDUM SOLVEDUM)) 1) | 2312 (eq (math-expr-contains-count math-t2 '(var SOLVEDUM SOLVEDUM)) 1) |
2208 (setq t3 (math-solve-above-dummy t2)) | 2313 (setq math-t3 (math-solve-above-dummy math-t2)) |
2209 (setq t1 (math-try-solve-for (math-sub (nth 1 (nth 1 lhs)) | 2314 (setq math-t1 (math-try-solve-for |
2210 (math-expr-subst | 2315 (math-sub (nth 1 (nth 1 math-solve-lhs)) |
2211 t2 t3 | 2316 (math-expr-subst |
2212 (nth 1 (nth 2 lhs)))) | 2317 math-t2 math-t3 |
2213 0))) | 2318 (nth 1 (nth 2 math-solve-lhs)))) |
2214 t1) | 2319 0))) |
2215 ((eq (car lhs) 'neg) | 2320 math-t1) |
2216 (math-try-solve-for (nth 1 lhs) (math-neg rhs) | 2321 ((eq (car math-solve-lhs) 'neg) |
2217 (and sign (- sign)))) | 2322 (math-try-solve-for (nth 1 math-solve-lhs) (math-neg math-solve-rhs) |
2218 ((and (not (eq solve-full 't)) (math-try-solve-prod))) | 2323 (and math-try-solve-sign (- math-try-solve-sign)))) |
2324 ((and (not (eq math-solve-full 't)) (math-try-solve-prod))) | |
2219 ((and (not no-poly) | 2325 ((and (not no-poly) |
2220 (setq t2 (math-decompose-poly lhs solve-var 15 rhs))) | 2326 (setq math-t2 |
2221 (setq t1 (cdr (nth 1 t2)) | 2327 (math-decompose-poly math-solve-lhs |
2222 t1 (let ((math-solve-ranges math-solve-ranges)) | 2328 math-solve-var 15 math-solve-rhs))) |
2223 (cond ((= (length t1) 5) | 2329 (setq math-t1 (cdr (nth 1 math-t2)) |
2224 (apply 'math-solve-quartic (car t2) t1)) | 2330 math-t1 (let ((math-solve-ranges math-solve-ranges)) |
2225 ((= (length t1) 4) | 2331 (cond ((= (length math-t1) 5) |
2226 (apply 'math-solve-cubic (car t2) t1)) | 2332 (apply 'math-solve-quartic (car math-t2) math-t1)) |
2227 ((= (length t1) 3) | 2333 ((= (length math-t1) 4) |
2228 (apply 'math-solve-quadratic (car t2) t1)) | 2334 (apply 'math-solve-cubic (car math-t2) math-t1)) |
2229 ((= (length t1) 2) | 2335 ((= (length math-t1) 3) |
2230 (apply 'math-solve-linear (car t2) sign t1)) | 2336 (apply 'math-solve-quadratic (car math-t2) math-t1)) |
2231 (solve-full | 2337 ((= (length math-t1) 2) |
2232 (math-poly-all-roots (car t2) t1)) | 2338 (apply 'math-solve-linear |
2339 (car math-t2) math-try-solve-sign math-t1)) | |
2340 (math-solve-full | |
2341 (math-poly-all-roots (car math-t2) math-t1)) | |
2233 (calc-symbolic-mode nil) | 2342 (calc-symbolic-mode nil) |
2234 (t | 2343 (t |
2235 (math-try-solve-for | 2344 (math-try-solve-for |
2236 (car t2) | 2345 (car math-t2) |
2237 (math-poly-any-root (reverse t1) 0 t) | 2346 (math-poly-any-root (reverse math-t1) 0 t) |
2238 nil t))))) | 2347 nil t))))) |
2239 (if t1 | 2348 (if math-t1 |
2240 (if (eq (nth 2 t2) 1) | 2349 (if (eq (nth 2 math-t2) 1) |
2241 t1 | 2350 math-t1 |
2242 (math-solve-prod t1 (math-try-solve-for (nth 2 t2) 0 nil t))) | 2351 (math-solve-prod math-t1 (math-try-solve-for (nth 2 math-t2) 0 nil t))) |
2243 (calc-record-why "*Unable to find a symbolic solution") | 2352 (calc-record-why "*Unable to find a symbolic solution") |
2244 nil)) | 2353 nil)) |
2245 ((and (math-solve-find-root-term lhs nil) | 2354 ((and (math-solve-find-root-term math-solve-lhs nil) |
2246 (eq (math-expr-contains-count lhs t1) 1)) ; just in case | 2355 (eq (math-expr-contains-count math-solve-lhs math-t1) 1)) ; just in case |
2247 (math-try-solve-for (math-simplify | 2356 (math-try-solve-for (math-simplify |
2248 (math-sub (if (or t3 (math-evenp t2)) | 2357 (math-sub (if (or math-t3 (math-evenp math-t2)) |
2249 (math-pow t1 t2) | 2358 (math-pow math-t1 math-t2) |
2250 (math-neg (math-pow t1 t2))) | 2359 (math-neg (math-pow math-t1 math-t2))) |
2251 (math-expand-power | 2360 (math-expand-power |
2252 (math-sub (math-normalize | 2361 (math-sub (math-normalize |
2253 (math-expr-subst | 2362 (math-expr-subst |
2254 lhs t1 0)) | 2363 math-solve-lhs math-t1 0)) |
2255 rhs) | 2364 math-solve-rhs) |
2256 t2 solve-var))) | 2365 math-t2 math-solve-var))) |
2257 0)) | 2366 0)) |
2258 ((eq (car lhs) '+) | 2367 ((eq (car math-solve-lhs) '+) |
2259 (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2368 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2260 (math-try-solve-for (nth 2 lhs) | 2369 (math-try-solve-for (nth 2 math-solve-lhs) |
2261 (math-sub rhs (nth 1 lhs)) | 2370 (math-sub math-solve-rhs (nth 1 math-solve-lhs)) |
2262 sign)) | 2371 math-try-solve-sign)) |
2263 ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2372 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2264 (math-try-solve-for (nth 1 lhs) | 2373 (math-try-solve-for (nth 1 math-solve-lhs) |
2265 (math-sub rhs (nth 2 lhs)) | 2374 (math-sub math-solve-rhs (nth 2 math-solve-lhs)) |
2266 sign)))) | 2375 math-try-solve-sign)))) |
2267 ((eq (car lhs) 'calcFunc-eq) | 2376 ((eq (car math-solve-lhs) 'calcFunc-eq) |
2268 (math-try-solve-for (math-sub (nth 1 lhs) (nth 2 lhs)) | 2377 (math-try-solve-for (math-sub (nth 1 math-solve-lhs) (nth 2 math-solve-lhs)) |
2269 rhs sign no-poly)) | 2378 math-solve-rhs math-try-solve-sign no-poly)) |
2270 ((eq (car lhs) '-) | 2379 ((eq (car math-solve-lhs) '-) |
2271 (cond ((or (and (eq (car-safe (nth 1 lhs)) 'calcFunc-sin) | 2380 (cond ((or (and (eq (car-safe (nth 1 math-solve-lhs)) 'calcFunc-sin) |
2272 (eq (car-safe (nth 2 lhs)) 'calcFunc-cos)) | 2381 (eq (car-safe (nth 2 math-solve-lhs)) 'calcFunc-cos)) |
2273 (and (eq (car-safe (nth 1 lhs)) 'calcFunc-cos) | 2382 (and (eq (car-safe (nth 1 math-solve-lhs)) 'calcFunc-cos) |
2274 (eq (car-safe (nth 2 lhs)) 'calcFunc-sin))) | 2383 (eq (car-safe (nth 2 math-solve-lhs)) 'calcFunc-sin))) |
2275 (math-try-solve-for (math-sub (nth 1 lhs) | 2384 (math-try-solve-for (math-sub (nth 1 math-solve-lhs) |
2276 (list (car (nth 1 lhs)) | 2385 (list (car (nth 1 math-solve-lhs)) |
2277 (math-sub | 2386 (math-sub |
2278 (math-quarter-circle t) | 2387 (math-quarter-circle t) |
2279 (nth 1 (nth 2 lhs))))) | 2388 (nth 1 (nth 2 math-solve-lhs))))) |
2280 rhs)) | 2389 math-solve-rhs)) |
2281 ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2390 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2282 (math-try-solve-for (nth 2 lhs) | 2391 (math-try-solve-for (nth 2 math-solve-lhs) |
2283 (math-sub (nth 1 lhs) rhs) | 2392 (math-sub (nth 1 math-solve-lhs) math-solve-rhs) |
2284 (and sign (- sign)))) | 2393 (and math-try-solve-sign |
2285 ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2394 (- math-try-solve-sign)))) |
2286 (math-try-solve-for (nth 1 lhs) | 2395 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2287 (math-add rhs (nth 2 lhs)) | 2396 (math-try-solve-for (nth 1 math-solve-lhs) |
2288 sign)))) | 2397 (math-add math-solve-rhs (nth 2 math-solve-lhs)) |
2289 ((and (eq solve-full 't) (math-try-solve-prod))) | 2398 math-try-solve-sign)))) |
2290 ((and (eq (car lhs) '%) | 2399 ((and (eq math-solve-full 't) (math-try-solve-prod))) |
2291 (not (math-expr-contains (nth 2 lhs) solve-var))) | 2400 ((and (eq (car math-solve-lhs) '%) |
2292 (math-try-solve-for (nth 1 lhs) (math-add rhs | 2401 (not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var))) |
2402 (math-try-solve-for (nth 1 math-solve-lhs) (math-add math-solve-rhs | |
2293 (math-solve-get-int | 2403 (math-solve-get-int |
2294 (nth 2 lhs))))) | 2404 (nth 2 math-solve-lhs))))) |
2295 ((eq (car lhs) 'calcFunc-log) | 2405 ((eq (car math-solve-lhs) 'calcFunc-log) |
2296 (cond ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2406 (cond ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2297 (math-try-solve-for (nth 1 lhs) (math-pow (nth 2 lhs) rhs))) | 2407 (math-try-solve-for (nth 1 math-solve-lhs) |
2298 ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2408 (math-pow (nth 2 math-solve-lhs) math-solve-rhs))) |
2299 (math-try-solve-for (nth 2 lhs) (math-pow | 2409 ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2300 (nth 1 lhs) | 2410 (math-try-solve-for (nth 2 math-solve-lhs) (math-pow |
2301 (math-div 1 rhs)))))) | 2411 (nth 1 math-solve-lhs) |
2302 ((and (= (length lhs) 2) | 2412 (math-div 1 math-solve-rhs)))))) |
2303 (symbolp (car lhs)) | 2413 ((and (= (length math-solve-lhs) 2) |
2304 (setq t1 (get (car lhs) 'math-inverse)) | 2414 (symbolp (car math-solve-lhs)) |
2305 (setq t2 (funcall t1 rhs))) | 2415 (setq math-t1 (get (car math-solve-lhs) 'math-inverse)) |
2306 (setq t1 (get (car lhs) 'math-inverse-sign)) | 2416 (setq math-t2 (funcall math-t1 math-solve-rhs))) |
2307 (math-try-solve-for (nth 1 lhs) (math-normalize t2) | 2417 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-sign)) |
2308 (and sign t1 | 2418 (math-try-solve-for (nth 1 math-solve-lhs) (math-normalize math-t2) |
2309 (if (integerp t1) | 2419 (and math-try-solve-sign math-t1 |
2310 (* t1 sign) | 2420 (if (integerp math-t1) |
2311 (funcall t1 lhs sign))))) | 2421 (* math-t1 math-try-solve-sign) |
2312 ((and (symbolp (car lhs)) | 2422 (funcall math-t1 math-solve-lhs |
2313 (setq t1 (get (car lhs) 'math-inverse-n)) | 2423 math-try-solve-sign))))) |
2314 (setq t2 (funcall t1 lhs rhs))) | 2424 ((and (symbolp (car math-solve-lhs)) |
2315 t2) | 2425 (setq math-t1 (get (car math-solve-lhs) 'math-inverse-n)) |
2316 ((setq t1 (math-expand-formula lhs)) | 2426 (setq math-t2 (funcall math-t1 math-solve-lhs math-solve-rhs))) |
2317 (math-try-solve-for t1 rhs sign)) | 2427 math-t2) |
2428 ((setq math-t1 (math-expand-formula math-solve-lhs)) | |
2429 (math-try-solve-for math-t1 math-solve-rhs math-try-solve-sign)) | |
2318 (t | 2430 (t |
2319 (calc-record-why "*No inverse known" lhs) | 2431 (calc-record-why "*No inverse known" math-solve-lhs) |
2320 nil)))) | 2432 nil)))) |
2321 | 2433 |
2322 | 2434 |
2323 (defun math-try-solve-prod () | 2435 (defun math-try-solve-prod () |
2324 (cond ((eq (car lhs) '*) | 2436 (cond ((eq (car math-solve-lhs) '*) |
2325 (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2437 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2326 (math-try-solve-for (nth 2 lhs) | 2438 (math-try-solve-for (nth 2 math-solve-lhs) |
2327 (math-div rhs (nth 1 lhs)) | 2439 (math-div math-solve-rhs (nth 1 math-solve-lhs)) |
2328 (math-solve-sign sign (nth 1 lhs)))) | 2440 (math-solve-sign math-try-solve-sign |
2329 ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2441 (nth 1 math-solve-lhs)))) |
2330 (math-try-solve-for (nth 1 lhs) | 2442 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2331 (math-div rhs (nth 2 lhs)) | 2443 (math-try-solve-for (nth 1 math-solve-lhs) |
2332 (math-solve-sign sign (nth 2 lhs)))) | 2444 (math-div math-solve-rhs (nth 2 math-solve-lhs)) |
2333 ((Math-zerop rhs) | 2445 (math-solve-sign math-try-solve-sign |
2446 (nth 2 math-solve-lhs)))) | |
2447 ((Math-zerop math-solve-rhs) | |
2334 (math-solve-prod (let ((math-solve-ranges math-solve-ranges)) | 2448 (math-solve-prod (let ((math-solve-ranges math-solve-ranges)) |
2335 (math-try-solve-for (nth 2 lhs) 0)) | 2449 (math-try-solve-for (nth 2 math-solve-lhs) 0)) |
2336 (math-try-solve-for (nth 1 lhs) 0))))) | 2450 (math-try-solve-for (nth 1 math-solve-lhs) 0))))) |
2337 ((eq (car lhs) '/) | 2451 ((eq (car math-solve-lhs) '/) |
2338 (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2452 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2339 (math-try-solve-for (nth 2 lhs) | 2453 (math-try-solve-for (nth 2 math-solve-lhs) |
2340 (math-div (nth 1 lhs) rhs) | 2454 (math-div (nth 1 math-solve-lhs) math-solve-rhs) |
2341 (math-solve-sign sign (nth 1 lhs)))) | 2455 (math-solve-sign math-try-solve-sign |
2342 ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2456 (nth 1 math-solve-lhs)))) |
2343 (math-try-solve-for (nth 1 lhs) | 2457 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2344 (math-mul rhs (nth 2 lhs)) | 2458 (math-try-solve-for (nth 1 math-solve-lhs) |
2345 (math-solve-sign sign (nth 2 lhs)))) | 2459 (math-mul math-solve-rhs (nth 2 math-solve-lhs)) |
2346 ((setq t1 (math-try-solve-for (math-sub (nth 1 lhs) | 2460 (math-solve-sign math-try-solve-sign |
2347 (math-mul (nth 2 lhs) | 2461 (nth 2 math-solve-lhs)))) |
2348 rhs)) | 2462 ((setq math-t1 (math-try-solve-for (math-sub (nth 1 math-solve-lhs) |
2463 (math-mul (nth 2 math-solve-lhs) | |
2464 math-solve-rhs)) | |
2349 0)) | 2465 0)) |
2350 t1))) | 2466 math-t1))) |
2351 ((eq (car lhs) '^) | 2467 ((eq (car math-solve-lhs) '^) |
2352 (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) | 2468 (cond ((not (math-expr-contains (nth 1 math-solve-lhs) math-solve-var)) |
2353 (math-try-solve-for | 2469 (math-try-solve-for |
2354 (nth 2 lhs) | 2470 (nth 2 math-solve-lhs) |
2355 (math-add (math-normalize | 2471 (math-add (math-normalize |
2356 (list 'calcFunc-log rhs (nth 1 lhs))) | 2472 (list 'calcFunc-log math-solve-rhs (nth 1 math-solve-lhs))) |
2357 (math-div | 2473 (math-div |
2358 (math-mul 2 | 2474 (math-mul 2 |
2359 (math-mul '(var pi var-pi) | 2475 (math-mul '(var pi var-pi) |
2360 (math-solve-get-int | 2476 (math-solve-get-int |
2361 '(var i var-i)))) | 2477 '(var i var-i)))) |
2362 (math-normalize | 2478 (math-normalize |
2363 (list 'calcFunc-ln (nth 1 lhs))))))) | 2479 (list 'calcFunc-ln (nth 1 math-solve-lhs))))))) |
2364 ((not (math-expr-contains (nth 2 lhs) solve-var)) | 2480 ((not (math-expr-contains (nth 2 math-solve-lhs) math-solve-var)) |
2365 (cond ((and (integerp (nth 2 lhs)) | 2481 (cond ((and (integerp (nth 2 math-solve-lhs)) |
2366 (>= (nth 2 lhs) 2) | 2482 (>= (nth 2 math-solve-lhs) 2) |
2367 (setq t1 (math-integer-log2 (nth 2 lhs)))) | 2483 (setq math-t1 (math-integer-log2 (nth 2 math-solve-lhs)))) |
2368 (setq t2 rhs) | 2484 (setq math-t2 math-solve-rhs) |
2369 (if (and (eq solve-full t) | 2485 (if (and (eq math-solve-full t) |
2370 (math-known-realp (nth 1 lhs))) | 2486 (math-known-realp (nth 1 math-solve-lhs))) |
2371 (progn | 2487 (progn |
2372 (while (>= (setq t1 (1- t1)) 0) | 2488 (while (>= (setq math-t1 (1- math-t1)) 0) |
2373 (setq t2 (list 'calcFunc-sqrt t2))) | 2489 (setq math-t2 (list 'calcFunc-sqrt math-t2))) |
2374 (setq t2 (math-solve-get-sign t2))) | 2490 (setq math-t2 (math-solve-get-sign math-t2))) |
2375 (while (>= (setq t1 (1- t1)) 0) | 2491 (while (>= (setq math-t1 (1- math-t1)) 0) |
2376 (setq t2 (math-solve-get-sign | 2492 (setq math-t2 (math-solve-get-sign |
2377 (math-normalize | 2493 (math-normalize |
2378 (list 'calcFunc-sqrt t2)))))) | 2494 (list 'calcFunc-sqrt math-t2)))))) |
2379 (math-try-solve-for | 2495 (math-try-solve-for |
2380 (nth 1 lhs) | 2496 (nth 1 math-solve-lhs) |
2381 (math-normalize t2))) | 2497 (math-normalize math-t2))) |
2382 ((math-looks-negp (nth 2 lhs)) | 2498 ((math-looks-negp (nth 2 math-solve-lhs)) |
2383 (math-try-solve-for | 2499 (math-try-solve-for |
2384 (list '^ (nth 1 lhs) (math-neg (nth 2 lhs))) | 2500 (list '^ (nth 1 math-solve-lhs) |
2385 (math-div 1 rhs))) | 2501 (math-neg (nth 2 math-solve-lhs))) |
2386 ((and (eq solve-full t) | 2502 (math-div 1 math-solve-rhs))) |
2387 (Math-integerp (nth 2 lhs)) | 2503 ((and (eq math-solve-full t) |
2388 (math-known-realp (nth 1 lhs))) | 2504 (Math-integerp (nth 2 math-solve-lhs)) |
2389 (setq t1 (math-normalize | 2505 (math-known-realp (nth 1 math-solve-lhs))) |
2390 (list 'calcFunc-nroot rhs (nth 2 lhs)))) | 2506 (setq math-t1 (math-normalize |
2391 (if (math-evenp (nth 2 lhs)) | 2507 (list 'calcFunc-nroot math-solve-rhs |
2392 (setq t1 (math-solve-get-sign t1))) | 2508 (nth 2 math-solve-lhs)))) |
2509 (if (math-evenp (nth 2 math-solve-lhs)) | |
2510 (setq math-t1 (math-solve-get-sign math-t1))) | |
2393 (math-try-solve-for | 2511 (math-try-solve-for |
2394 (nth 1 lhs) t1 | 2512 (nth 1 math-solve-lhs) math-t1 |
2395 (and sign | 2513 (and math-try-solve-sign |
2396 (math-oddp (nth 2 lhs)) | 2514 (math-oddp (nth 2 math-solve-lhs)) |
2397 (math-solve-sign sign (nth 2 lhs))))) | 2515 (math-solve-sign math-try-solve-sign |
2516 (nth 2 math-solve-lhs))))) | |
2398 (t (math-try-solve-for | 2517 (t (math-try-solve-for |
2399 (nth 1 lhs) | 2518 (nth 1 math-solve-lhs) |
2400 (math-mul | 2519 (math-mul |
2401 (math-normalize | 2520 (math-normalize |
2402 (list 'calcFunc-exp | 2521 (list 'calcFunc-exp |
2403 (if (Math-realp (nth 2 lhs)) | 2522 (if (Math-realp (nth 2 math-solve-lhs)) |
2404 (math-div (math-mul | 2523 (math-div (math-mul |
2405 '(var pi var-pi) | 2524 '(var pi var-pi) |
2406 (math-solve-get-int | 2525 (math-solve-get-int |
2407 '(var i var-i) | 2526 '(var i var-i) |
2408 (and (integerp (nth 2 lhs)) | 2527 (and (integerp (nth 2 math-solve-lhs)) |
2409 (math-abs | 2528 (math-abs |
2410 (nth 2 lhs))))) | 2529 (nth 2 math-solve-lhs))))) |
2411 (math-div (nth 2 lhs) 2)) | 2530 (math-div (nth 2 math-solve-lhs) 2)) |
2412 (math-div (math-mul | 2531 (math-div (math-mul |
2413 2 | 2532 2 |
2414 (math-mul | 2533 (math-mul |
2415 '(var pi var-pi) | 2534 '(var pi var-pi) |
2416 (math-solve-get-int | 2535 (math-solve-get-int |
2417 '(var i var-i) | 2536 '(var i var-i) |
2418 (and (integerp (nth 2 lhs)) | 2537 (and (integerp (nth 2 math-solve-lhs)) |
2419 (math-abs | 2538 (math-abs |
2420 (nth 2 lhs)))))) | 2539 (nth 2 math-solve-lhs)))))) |
2421 (nth 2 lhs))))) | 2540 (nth 2 math-solve-lhs))))) |
2422 (math-normalize | 2541 (math-normalize |
2423 (list 'calcFunc-nroot | 2542 (list 'calcFunc-nroot |
2424 rhs | 2543 math-solve-rhs |
2425 (nth 2 lhs)))) | 2544 (nth 2 math-solve-lhs)))) |
2426 (and sign | 2545 (and math-try-solve-sign |
2427 (math-oddp (nth 2 lhs)) | 2546 (math-oddp (nth 2 math-solve-lhs)) |
2428 (math-solve-sign sign (nth 2 lhs))))))))) | 2547 (math-solve-sign math-try-solve-sign |
2548 (nth 2 math-solve-lhs))))))))) | |
2429 (t nil))) | 2549 (t nil))) |
2430 | 2550 |
2431 (defun math-solve-prod (lsoln rsoln) | 2551 (defun math-solve-prod (lsoln rsoln) |
2432 (cond ((null lsoln) | 2552 (cond ((null lsoln) |
2433 rsoln) | 2553 rsoln) |
2434 ((null rsoln) | 2554 ((null rsoln) |
2435 lsoln) | 2555 lsoln) |
2436 ((eq solve-full 'all) | 2556 ((eq math-solve-full 'all) |
2437 (cons 'vec (append (cdr lsoln) (cdr rsoln)))) | 2557 (cons 'vec (append (cdr lsoln) (cdr rsoln)))) |
2438 (solve-full | 2558 (math-solve-full |
2439 (list 'calcFunc-if | 2559 (list 'calcFunc-if |
2440 (list 'calcFunc-gt (math-solve-get-sign 1) 0) | 2560 (list 'calcFunc-gt (math-solve-get-sign 1) 0) |
2441 lsoln | 2561 lsoln |
2442 rsoln)) | 2562 rsoln)) |
2443 (t lsoln))) | 2563 (t lsoln))) |
2444 | 2564 |
2445 ;;; This deals with negative, fractional, and symbolic powers of "x". | 2565 ;;; This deals with negative, fractional, and symbolic powers of "x". |
2566 ;; The variable math-solve-b is local to math-decompose-poly, | |
2567 ;; but is used by math-solve-poly-funny-powers. | |
2568 | |
2446 (defun math-solve-poly-funny-powers (sub-rhs) ; uses "t1", "t2" | 2569 (defun math-solve-poly-funny-powers (sub-rhs) ; uses "t1", "t2" |
2447 (setq t1 lhs) | 2570 (setq math-t1 math-solve-lhs) |
2448 (let ((pp math-poly-neg-powers) | 2571 (let ((pp math-poly-neg-powers) |
2449 fac) | 2572 fac) |
2450 (while pp | 2573 (while pp |
2451 (setq fac (math-pow (car pp) (or math-poly-mult-powers 1)) | 2574 (setq fac (math-pow (car pp) (or math-poly-mult-powers 1)) |
2452 t1 (math-mul t1 fac) | 2575 math-t1 (math-mul math-t1 fac) |
2453 rhs (math-mul rhs fac) | 2576 math-solve-rhs (math-mul math-solve-rhs fac) |
2454 pp (cdr pp)))) | 2577 pp (cdr pp)))) |
2455 (if sub-rhs (setq t1 (math-sub t1 rhs))) | 2578 (if sub-rhs (setq math-t1 (math-sub math-t1 math-solve-rhs))) |
2456 (let ((math-poly-neg-powers nil)) | 2579 (let ((math-poly-neg-powers nil)) |
2457 (setq t2 (math-mul (or math-poly-mult-powers 1) | 2580 (setq math-t2 (math-mul (or math-poly-mult-powers 1) |
2458 (let ((calc-prefer-frac t)) | 2581 (let ((calc-prefer-frac t)) |
2459 (math-div 1 math-poly-frac-powers))) | 2582 (math-div 1 math-poly-frac-powers))) |
2460 t1 (math-is-polynomial (math-simplify (calcFunc-expand t1)) b 50)))) | 2583 math-t1 (math-is-polynomial |
2584 (math-simplify (calcFunc-expand math-t1)) math-solve-b 50)))) | |
2461 | 2585 |
2462 ;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2". | 2586 ;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2". |
2463 (defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3" | 2587 (defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3" |
2464 (let ((count 0)) | 2588 (let ((count 0)) |
2465 (while (and t1 (Math-zerop (car t1))) | 2589 (while (and math-t1 (Math-zerop (car math-t1))) |
2466 (setq t1 (cdr t1) | 2590 (setq math-t1 (cdr math-t1) |
2467 count (1+ count))) | 2591 count (1+ count))) |
2468 (and t1 | 2592 (and math-t1 |
2469 (let* ((degree (1- (length t1))) | 2593 (let* ((degree (1- (length math-t1))) |
2470 (scale degree)) | 2594 (scale degree)) |
2471 (while (and (> scale 1) (= (car t3) 1)) | 2595 (while (and (> scale 1) (= (car math-t3) 1)) |
2472 (and (= (% degree scale) 0) | 2596 (and (= (% degree scale) 0) |
2473 (let ((p t1) | 2597 (let ((p math-t1) |
2474 (n 0) | 2598 (n 0) |
2475 (new-t1 nil) | 2599 (new-t1 nil) |
2476 (okay t)) | 2600 (okay t)) |
2477 (while (and p okay) | 2601 (while (and p okay) |
2478 (if (= (% n scale) 0) | 2602 (if (= (% n scale) 0) |
2480 (or (Math-zerop (car p)) | 2604 (or (Math-zerop (car p)) |
2481 (setq okay nil))) | 2605 (setq okay nil))) |
2482 (setq p (cdr p) | 2606 (setq p (cdr p) |
2483 n (1+ n))) | 2607 n (1+ n))) |
2484 (if okay | 2608 (if okay |
2485 (setq t3 (cons scale (cdr t3)) | 2609 (setq math-t3 (cons scale (cdr math-t3)) |
2486 t1 new-t1)))) | 2610 math-t1 new-t1)))) |
2487 (setq scale (1- scale))) | 2611 (setq scale (1- scale))) |
2488 (setq t3 (list (math-mul (car t3) t2) (math-mul count t2))) | 2612 (setq math-t3 (list (math-mul (car math-t3) math-t2) |
2489 (<= (1- (length t1)) max-degree))))) | 2613 (math-mul count math-t2))) |
2614 (<= (1- (length math-t1)) max-degree))))) | |
2490 | 2615 |
2491 (defun calcFunc-poly (expr var &optional degree) | 2616 (defun calcFunc-poly (expr var &optional degree) |
2492 (if degree | 2617 (if degree |
2493 (or (natnump degree) (math-reject-arg degree 'fixnatnump)) | 2618 (or (natnump degree) (math-reject-arg degree 'fixnatnump)) |
2494 (setq degree 50)) | 2619 (setq degree 50)) |
2507 (d (math-decompose-poly expr var degree nil))) | 2632 (d (math-decompose-poly expr var degree nil))) |
2508 (if d | 2633 (if d |
2509 (cons 'vec d) | 2634 (cons 'vec d) |
2510 (math-reject-arg expr "Expected a polynomial")))) | 2635 (math-reject-arg expr "Expected a polynomial")))) |
2511 | 2636 |
2512 (defun math-decompose-poly (lhs solve-var degree sub-rhs) | 2637 (defun math-decompose-poly (math-solve-lhs math-solve-var degree sub-rhs) |
2513 (let ((rhs (or sub-rhs 1)) | 2638 (let ((math-solve-rhs (or sub-rhs 1)) |
2514 t1 t2 t3) | 2639 math-t1 math-t2 math-t3) |
2515 (setq t2 (math-polynomial-base | 2640 (setq math-t2 (math-polynomial-base |
2516 lhs | 2641 math-solve-lhs |
2517 (function | 2642 (function |
2518 (lambda (b) | 2643 (lambda (math-solve-b) |
2519 (let ((math-poly-neg-powers '(1)) | 2644 (let ((math-poly-neg-powers '(1)) |
2520 (math-poly-mult-powers nil) | 2645 (math-poly-mult-powers nil) |
2521 (math-poly-frac-powers 1) | 2646 (math-poly-frac-powers 1) |
2522 (math-poly-exp-base t)) | 2647 (math-poly-exp-base t)) |
2523 (and (not (equal b lhs)) | 2648 (and (not (equal math-solve-b math-solve-lhs)) |
2524 (or (not (memq (car-safe b) '(+ -))) sub-rhs) | 2649 (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs) |
2525 (setq t3 '(1 0) t2 1 | 2650 (setq math-t3 '(1 0) math-t2 1 |
2526 t1 (math-is-polynomial lhs b 50)) | 2651 math-t1 (math-is-polynomial math-solve-lhs |
2652 math-solve-b 50)) | |
2527 (if (and (equal math-poly-neg-powers '(1)) | 2653 (if (and (equal math-poly-neg-powers '(1)) |
2528 (memq math-poly-mult-powers '(nil 1)) | 2654 (memq math-poly-mult-powers '(nil 1)) |
2529 (eq math-poly-frac-powers 1) | 2655 (eq math-poly-frac-powers 1) |
2530 sub-rhs) | 2656 sub-rhs) |
2531 (setq t1 (cons (math-sub (car t1) rhs) | 2657 (setq math-t1 (cons (math-sub (car math-t1) math-solve-rhs) |
2532 (cdr t1))) | 2658 (cdr math-t1))) |
2533 (math-solve-poly-funny-powers sub-rhs)) | 2659 (math-solve-poly-funny-powers sub-rhs)) |
2534 (math-solve-crunch-poly degree) | 2660 (math-solve-crunch-poly degree) |
2535 (or (math-expr-contains b solve-var) | 2661 (or (math-expr-contains math-solve-b math-solve-var) |
2536 (math-expr-contains (car t3) solve-var)))))))) | 2662 (math-expr-contains (car math-t3) math-solve-var)))))))) |
2537 (if t2 | 2663 (if math-t2 |
2538 (list (math-pow t2 (car t3)) | 2664 (list (math-pow math-t2 (car math-t3)) |
2539 (cons 'vec t1) | 2665 (cons 'vec math-t1) |
2540 (if sub-rhs | 2666 (if sub-rhs |
2541 (math-pow t2 (nth 1 t3)) | 2667 (math-pow math-t2 (nth 1 math-t3)) |
2542 (math-div (math-pow t2 (nth 1 t3)) rhs)))))) | 2668 (math-div (math-pow math-t2 (nth 1 math-t3)) math-solve-rhs)))))) |
2543 | 2669 |
2544 (defun math-solve-linear (var sign b a) | 2670 (defun math-solve-linear (var sign b a) |
2545 (math-try-solve-for var | 2671 (math-try-solve-for var |
2546 (math-div (math-neg b) a) | 2672 (math-div (math-neg b) a) |
2547 (math-solve-sign sign a) | 2673 (math-solve-sign sign a) |
2621 (setq d (math-div d aa)) | 2747 (setq d (math-div d aa)) |
2622 (math-try-solve-for | 2748 (math-try-solve-for |
2623 var | 2749 var |
2624 (let* ((asqr (math-sqr a)) | 2750 (let* ((asqr (math-sqr a)) |
2625 (asqr4 (math-div asqr 4)) | 2751 (asqr4 (math-div asqr 4)) |
2626 (y (let ((solve-full nil) | 2752 (y (let ((math-solve-full nil) |
2627 calc-next-why) | 2753 calc-next-why) |
2628 (math-solve-cubic solve-var | 2754 (math-solve-cubic math-solve-var |
2629 (math-sub (math-sub | 2755 (math-sub (math-sub |
2630 (math-mul 4 (math-mul b d)) | 2756 (math-mul 4 (math-mul b d)) |
2631 (math-mul asqr d)) | 2757 (math-mul asqr d)) |
2632 (math-sqr c)) | 2758 (math-sqr c)) |
2633 (math-sub (math-mul a c) | 2759 (math-sub (math-mul a c) |
2663 (math-div a 4)))) | 2789 (math-div a 4)))) |
2664 nil t)) | 2790 nil t)) |
2665 | 2791 |
2666 (defvar math-symbolic-solve nil) | 2792 (defvar math-symbolic-solve nil) |
2667 (defvar math-int-coefs nil) | 2793 (defvar math-int-coefs nil) |
2794 | |
2795 ;; The variable math-int-threshold is local to math-poly-all-roots, | |
2796 ;; but is used by math-poly-newton-root. | |
2797 (defvar math-int-threshold) | |
2798 ;; The variables math-int-scale, math-int-factors and math-double-roots | |
2799 ;; are local to math-poly-all-roots, but are used by math-poly-integer-root. | |
2800 (defvar math-int-scale) | |
2801 | |
2668 (defun math-poly-all-roots (var p &optional math-factoring) | 2802 (defun math-poly-all-roots (var p &optional math-factoring) |
2669 (catch 'ouch | 2803 (catch 'ouch |
2670 (let* ((math-symbolic-solve calc-symbolic-mode) | 2804 (let* ((math-symbolic-solve calc-symbolic-mode) |
2671 (roots nil) | 2805 (roots nil) |
2672 (deg (1- (length p))) | 2806 (deg (1- (length p))) |
2716 (setq b (math-add (math-mul x b) c))) | 2850 (setq b (math-add (math-mul x b) c))) |
2717 (setq def-p (cdr def-p) | 2851 (setq def-p (cdr def-p) |
2718 deg (1- deg)))) | 2852 deg (1- deg)))) |
2719 (setq p (reverse def-p)))) | 2853 (setq p (reverse def-p)))) |
2720 (if (> deg 1) | 2854 (if (> deg 1) |
2721 (let ((solve-var '(var DUMMY var-DUMMY)) | 2855 (let ((math-solve-var '(var DUMMY var-DUMMY)) |
2722 (math-solve-sign nil) | 2856 (math-solve-sign nil) |
2723 (math-solve-ranges nil) | 2857 (math-solve-ranges nil) |
2724 (solve-full 'all)) | 2858 (math-solve-full 'all)) |
2725 (if (= (length p) (length math-int-coefs)) | 2859 (if (= (length p) (length math-int-coefs)) |
2726 (setq p (reverse math-int-coefs))) | 2860 (setq p (reverse math-int-coefs))) |
2727 (setq roots (append (cdr (apply (cond ((= deg 2) | 2861 (setq roots (append (cdr (apply (cond ((= deg 2) |
2728 'math-solve-quadratic) | 2862 'math-solve-quadratic) |
2729 ((= deg 3) | 2863 ((= deg 3) |
2730 'math-solve-cubic) | 2864 'math-solve-cubic) |
2731 (t | 2865 (t |
2732 'math-solve-quartic)) | 2866 'math-solve-quartic)) |
2733 solve-var p)) | 2867 math-solve-var p)) |
2734 roots))) | 2868 roots))) |
2735 (if (> deg 0) | 2869 (if (> deg 0) |
2736 (setq roots (cons (math-div (math-neg (car p)) (nth 1 p)) | 2870 (setq roots (cons (math-div (math-neg (car p)) (nth 1 p)) |
2737 roots)))) | 2871 roots)))) |
2738 (if math-factoring | 2872 (if math-factoring |
2742 (setq roots (cdr roots))) | 2876 (setq roots (cdr roots))) |
2743 (list math-int-factors (nreverse math-int-coefs) math-int-scale)) | 2877 (list math-int-factors (nreverse math-int-coefs) math-int-scale)) |
2744 (let ((vec nil) res) | 2878 (let ((vec nil) res) |
2745 (while roots | 2879 (while roots |
2746 (let ((root (car roots)) | 2880 (let ((root (car roots)) |
2747 (solve-full (and solve-full 'all))) | 2881 (math-solve-full (and math-solve-full 'all))) |
2748 (if (math-floatp root) | 2882 (if (math-floatp root) |
2749 (setq root (math-poly-any-root orig-p root t))) | 2883 (setq root (math-poly-any-root orig-p root t))) |
2750 (setq vec (append vec | 2884 (setq vec (append vec |
2751 (cdr (or (math-try-solve-for var root nil t) | 2885 (cdr (or (math-try-solve-for var root nil t) |
2752 (throw 'ouch nil)))))) | 2886 (throw 'ouch nil)))))) |
2753 (setq roots (cdr roots))) | 2887 (setq roots (cdr roots))) |
2754 (setq vec (cons 'vec (nreverse vec))) | 2888 (setq vec (cons 'vec (nreverse vec))) |
2755 (if math-symbolic-solve | 2889 (if math-symbolic-solve |
2756 (setq vec (math-normalize vec))) | 2890 (setq vec (math-normalize vec))) |
2757 (if (eq solve-full t) | 2891 (if (eq math-solve-full t) |
2758 (list 'calcFunc-subscr | 2892 (list 'calcFunc-subscr |
2759 vec | 2893 vec |
2760 (math-solve-get-int 1 (1- (length orig-p)) 1)) | 2894 (math-solve-get-int 1 (1- (length orig-p)) 1)) |
2761 vec)))))) | 2895 vec)))))) |
2762 | 2896 |
2970 (not (setq res (math-solve-above-dummy (car x)))))) | 3104 (not (setq res (math-solve-above-dummy (car x)))))) |
2971 res)))) | 3105 res)))) |
2972 | 3106 |
2973 (defun math-solve-find-root-term (x neg) ; sets "t2", "t3" | 3107 (defun math-solve-find-root-term (x neg) ; sets "t2", "t3" |
2974 (if (math-solve-find-root-in-prod x) | 3108 (if (math-solve-find-root-in-prod x) |
2975 (setq t3 neg | 3109 (setq math-t3 neg |
2976 t1 x) | 3110 math-t1 x) |
2977 (and (memq (car-safe x) '(+ -)) | 3111 (and (memq (car-safe x) '(+ -)) |
2978 (or (math-solve-find-root-term (nth 1 x) neg) | 3112 (or (math-solve-find-root-term (nth 1 x) neg) |
2979 (math-solve-find-root-term (nth 2 x) | 3113 (math-solve-find-root-term (nth 2 x) |
2980 (if (eq (car x) '-) (not neg) neg)))))) | 3114 (if (eq (car x) '-) (not neg) neg)))))) |
2981 | 3115 |
2982 (defun math-solve-find-root-in-prod (x) | 3116 (defun math-solve-find-root-in-prod (x) |
2983 (and (consp x) | 3117 (and (consp x) |
2984 (math-expr-contains x solve-var) | 3118 (math-expr-contains x math-solve-var) |
2985 (or (and (eq (car x) 'calcFunc-sqrt) | 3119 (or (and (eq (car x) 'calcFunc-sqrt) |
2986 (setq t2 2)) | 3120 (setq math-t2 2)) |
2987 (and (eq (car x) '^) | 3121 (and (eq (car x) '^) |
2988 (or (and (memq (math-quarter-integer (nth 2 x)) '(1 2 3)) | 3122 (or (and (memq (math-quarter-integer (nth 2 x)) '(1 2 3)) |
2989 (setq t2 2)) | 3123 (setq math-t2 2)) |
2990 (and (eq (car-safe (nth 2 x)) 'frac) | 3124 (and (eq (car-safe (nth 2 x)) 'frac) |
2991 (eq (nth 2 (nth 2 x)) 3) | 3125 (eq (nth 2 (nth 2 x)) 3) |
2992 (setq t2 3)))) | 3126 (setq math-t2 3)))) |
2993 (and (memq (car x) '(* /)) | 3127 (and (memq (car x) '(* /)) |
2994 (or (and (not (math-expr-contains (nth 1 x) solve-var)) | 3128 (or (and (not (math-expr-contains (nth 1 x) math-solve-var)) |
2995 (math-solve-find-root-in-prod (nth 2 x))) | 3129 (math-solve-find-root-in-prod (nth 2 x))) |
2996 (and (not (math-expr-contains (nth 2 x) solve-var)) | 3130 (and (not (math-expr-contains (nth 2 x) math-solve-var)) |
2997 (math-solve-find-root-in-prod (nth 1 x)))))))) | 3131 (math-solve-find-root-in-prod (nth 1 x)))))))) |
2998 | 3132 |
2999 | 3133 ;; The variable math-solve-vars is local to math-solve-system, |
3000 (defun math-solve-system (exprs solve-vars solve-full) | 3134 ;; but is used by math-solve-system-rec. |
3135 (defvar math-solve-vars) | |
3136 | |
3137 ;; The variable math-solve-simplifying is local to math-solve-system | |
3138 ;; and math-solve-system-rec, but is used by math-solve-system-subst. | |
3139 | |
3140 (defun math-solve-system (exprs math-solve-vars math-solve-full) | |
3001 (setq exprs (mapcar 'list (if (Math-vectorp exprs) | 3141 (setq exprs (mapcar 'list (if (Math-vectorp exprs) |
3002 (cdr exprs) | 3142 (cdr exprs) |
3003 (list exprs))) | 3143 (list exprs))) |
3004 solve-vars (if (Math-vectorp solve-vars) | 3144 math-solve-vars (if (Math-vectorp math-solve-vars) |
3005 (cdr solve-vars) | 3145 (cdr math-solve-vars) |
3006 (list solve-vars))) | 3146 (list math-solve-vars))) |
3007 (or (let ((math-solve-simplifying nil)) | 3147 (or (let ((math-solve-simplifying nil)) |
3008 (math-solve-system-rec exprs solve-vars nil)) | 3148 (math-solve-system-rec exprs math-solve-vars nil)) |
3009 (let ((math-solve-simplifying t)) | 3149 (let ((math-solve-simplifying t)) |
3010 (math-solve-system-rec exprs solve-vars nil)))) | 3150 (math-solve-system-rec exprs math-solve-vars nil)))) |
3011 | 3151 |
3012 ;;; The following backtracking solver works by choosing a variable | 3152 ;;; The following backtracking solver works by choosing a variable |
3013 ;;; and equation, and trying to solve the equation for the variable. | 3153 ;;; and equation, and trying to solve the equation for the variable. |
3014 ;;; If it succeeds it calls itself recursively with that variable and | 3154 ;;; If it succeeds it calls itself recursively with that variable and |
3015 ;;; equation removed from their respective lists, and with the solution | 3155 ;;; equation removed from their respective lists, and with the solution |
3018 ;;; manages to remove all the variables from var-list. | 3158 ;;; manages to remove all the variables from var-list. |
3019 | 3159 |
3020 ;;; To support calcFunc-roots, entries in eqn-list and solns are | 3160 ;;; To support calcFunc-roots, entries in eqn-list and solns are |
3021 ;;; actually lists of equations. | 3161 ;;; actually lists of equations. |
3022 | 3162 |
3163 ;; The variables math-solve-system-res and math-solve-system-vv are | |
3164 ;; local to math-solve-system-rec, but are used by math-solve-system-subst. | |
3165 (defvar math-solve-system-vv) | |
3166 (defvar math-solve-system-res) | |
3167 | |
3168 | |
3023 (defun math-solve-system-rec (eqn-list var-list solns) | 3169 (defun math-solve-system-rec (eqn-list var-list solns) |
3024 (if var-list | 3170 (if var-list |
3025 (let ((v var-list) | 3171 (let ((v var-list) |
3026 (res nil)) | 3172 (math-solve-system-res nil)) |
3027 | 3173 |
3028 ;; Try each variable in turn. | 3174 ;; Try each variable in turn. |
3029 (while | 3175 (while |
3030 (and | 3176 (and |
3031 v | 3177 v |
3032 (let* ((vv (car v)) | 3178 (let* ((math-solve-system-vv (car v)) |
3033 (e eqn-list) | 3179 (e eqn-list) |
3034 (elim (eq (car-safe vv) 'calcFunc-elim))) | 3180 (elim (eq (car-safe math-solve-system-vv) 'calcFunc-elim))) |
3035 (if elim | 3181 (if elim |
3036 (setq vv (nth 1 vv))) | 3182 (setq math-solve-system-vv (nth 1 math-solve-system-vv))) |
3037 | 3183 |
3038 ;; Try each equation in turn. | 3184 ;; Try each equation in turn. |
3039 (while | 3185 (while |
3040 (and | 3186 (and |
3041 e | 3187 e |
3042 (let ((e2 (car e)) | 3188 (let ((e2 (car e)) |
3043 (eprev nil) | 3189 (eprev nil) |
3044 res2) | 3190 res2) |
3045 (setq res nil) | 3191 (setq math-solve-system-res nil) |
3046 | 3192 |
3047 ;; Try to solve for vv the list of equations e2. | 3193 ;; Try to solve for math-solve-system-vv the list of equations e2. |
3048 (while (and e2 | 3194 (while (and e2 |
3049 (setq res2 (or (and (eq (car e2) eprev) | 3195 (setq res2 (or (and (eq (car e2) eprev) |
3050 res2) | 3196 res2) |
3051 (math-solve-for (car e2) 0 vv | 3197 (math-solve-for (car e2) 0 |
3052 solve-full)))) | 3198 math-solve-system-vv |
3199 math-solve-full)))) | |
3053 (setq eprev (car e2) | 3200 (setq eprev (car e2) |
3054 res (cons (if (eq solve-full 'all) | 3201 math-solve-system-res (cons (if (eq math-solve-full 'all) |
3055 (cdr res2) | 3202 (cdr res2) |
3056 (list res2)) | 3203 (list res2)) |
3057 res) | 3204 math-solve-system-res) |
3058 e2 (cdr e2))) | 3205 e2 (cdr e2))) |
3059 (if e2 | 3206 (if e2 |
3060 (setq res nil) | 3207 (setq math-solve-system-res nil) |
3061 | 3208 |
3062 ;; Found a solution. Now try other variables. | 3209 ;; Found a solution. Now try other variables. |
3063 (setq res (nreverse res) | 3210 (setq math-solve-system-res (nreverse math-solve-system-res) |
3064 res (math-solve-system-rec | 3211 math-solve-system-res (math-solve-system-rec |
3065 (mapcar | 3212 (mapcar |
3066 'math-solve-system-subst | 3213 'math-solve-system-subst |
3067 (delq (car e) | 3214 (delq (car e) |
3068 (copy-sequence eqn-list))) | 3215 (copy-sequence eqn-list))) |
3069 (delq (car v) (copy-sequence var-list)) | 3216 (delq (car v) (copy-sequence var-list)) |
3076 (math-solve-system-subst | 3223 (math-solve-system-subst |
3077 (cdr x))))) | 3224 (cdr x))))) |
3078 solns))) | 3225 solns))) |
3079 (if elim | 3226 (if elim |
3080 s | 3227 s |
3081 (cons (cons vv (apply 'append res)) | 3228 (cons (cons |
3229 math-solve-system-vv | |
3230 (apply 'append math-solve-system-res)) | |
3082 s))))) | 3231 s))))) |
3083 (not res)))) | 3232 (not math-solve-system-res)))) |
3084 (setq e (cdr e))) | 3233 (setq e (cdr e))) |
3085 (not res))) | 3234 (not math-solve-system-res))) |
3086 (setq v (cdr v))) | 3235 (setq v (cdr v))) |
3087 res) | 3236 math-solve-system-res) |
3088 | 3237 |
3089 ;; Eliminated all variables, so now put solution into the proper format. | 3238 ;; Eliminated all variables, so now put solution into the proper format. |
3090 (setq solns (sort solns | 3239 (setq solns (sort solns |
3091 (function | 3240 (function |
3092 (lambda (x y) | 3241 (lambda (x y) |
3093 (not (memq (car x) (memq (car y) solve-vars))))))) | 3242 (not (memq (car x) (memq (car y) math-solve-vars))))))) |
3094 (if (eq solve-full 'all) | 3243 (if (eq math-solve-full 'all) |
3095 (math-transpose | 3244 (math-transpose |
3096 (math-normalize | 3245 (math-normalize |
3097 (cons 'vec | 3246 (cons 'vec |
3098 (if solns | 3247 (if solns |
3099 (mapcar (function (lambda (x) (cons 'vec (cdr x)))) solns) | 3248 (mapcar (function (lambda (x) (cons 'vec (cdr x)))) solns) |
3104 (mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns) | 3253 (mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns) |
3105 (mapcar 'car eqn-list))))))) | 3254 (mapcar 'car eqn-list))))))) |
3106 | 3255 |
3107 (defun math-solve-system-subst (x) ; uses "res" and "v" | 3256 (defun math-solve-system-subst (x) ; uses "res" and "v" |
3108 (let ((accum nil) | 3257 (let ((accum nil) |
3109 (res2 res)) | 3258 (res2 math-solve-system-res)) |
3110 (while x | 3259 (while x |
3111 (setq accum (nconc accum | 3260 (setq accum (nconc accum |
3112 (mapcar (function | 3261 (mapcar (function |
3113 (lambda (r) | 3262 (lambda (r) |
3114 (if math-solve-simplifying | 3263 (if math-solve-simplifying |
3115 (math-simplify | 3264 (math-simplify |
3116 (math-expr-subst (car x) vv r)) | 3265 (math-expr-subst |
3117 (math-expr-subst (car x) vv r)))) | 3266 (car x) math-solve-system-vv r)) |
3267 (math-expr-subst | |
3268 (car x) math-solve-system-vv r)))) | |
3118 (car res2))) | 3269 (car res2))) |
3119 x (cdr x) | 3270 x (cdr x) |
3120 res2 (cdr res2))) | 3271 res2 (cdr res2))) |
3121 accum)) | 3272 accum)) |
3122 | 3273 |
3274 | |
3275 ;; calc-command-flags is declared in calc.el | |
3276 (defvar calc-command-flags) | |
3123 | 3277 |
3124 (defun math-get-from-counter (name) | 3278 (defun math-get-from-counter (name) |
3125 (let ((ctr (assq name calc-command-flags))) | 3279 (let ((ctr (assq name calc-command-flags))) |
3126 (if ctr | 3280 (if ctr |
3127 (setcdr ctr (1+ (cdr ctr))) | 3281 (setcdr ctr (1+ (cdr ctr))) |
3128 (setq ctr (cons name 1) | 3282 (setq ctr (cons name 1) |
3129 calc-command-flags (cons ctr calc-command-flags))) | 3283 calc-command-flags (cons ctr calc-command-flags))) |
3130 (cdr ctr))) | 3284 (cdr ctr))) |
3285 | |
3286 (defvar var-GenCount) | |
3131 | 3287 |
3132 (defun math-solve-get-sign (val) | 3288 (defun math-solve-get-sign (val) |
3133 (setq val (math-simplify val)) | 3289 (setq val (math-simplify val)) |
3134 (if (and (eq (car-safe val) '*) | 3290 (if (and (eq (car-safe val) '*) |
3135 (Math-numberp (nth 1 val))) | 3291 (Math-numberp (nth 1 val))) |
3137 (and (eq (car-safe val) 'calcFunc-sqrt) | 3293 (and (eq (car-safe val) 'calcFunc-sqrt) |
3138 (eq (car-safe (nth 1 val)) '^) | 3294 (eq (car-safe (nth 1 val)) '^) |
3139 (setq val (math-normalize (list '^ | 3295 (setq val (math-normalize (list '^ |
3140 (nth 1 (nth 1 val)) | 3296 (nth 1 (nth 1 val)) |
3141 (math-div (nth 2 (nth 1 val)) 2))))) | 3297 (math-div (nth 2 (nth 1 val)) 2))))) |
3142 (if solve-full | 3298 (if math-solve-full |
3143 (if (and (calc-var-value 'var-GenCount) | 3299 (if (and (calc-var-value 'var-GenCount) |
3144 (Math-natnump var-GenCount) | 3300 (Math-natnump var-GenCount) |
3145 (not (eq solve-full 'all))) | 3301 (not (eq math-solve-full 'all))) |
3146 (prog1 | 3302 (prog1 |
3147 (math-mul (list 'calcFunc-as var-GenCount) val) | 3303 (math-mul (list 'calcFunc-as var-GenCount) val) |
3148 (setq var-GenCount (math-add var-GenCount 1)) | 3304 (setq var-GenCount (math-add var-GenCount 1)) |
3149 (calc-refresh-evaltos 'var-GenCount)) | 3305 (calc-refresh-evaltos 'var-GenCount)) |
3150 (let* ((var (concat "s" (int-to-string (math-get-from-counter 'solve-sign)))) | 3306 (let* ((var (concat "s" (int-to-string (math-get-from-counter 'solve-sign)))) |
3151 (var2 (list 'var (intern var) (intern (concat "var-" var))))) | 3307 (var2 (list 'var (intern var) (intern (concat "var-" var))))) |
3152 (if (eq solve-full 'all) | 3308 (if (eq math-solve-full 'all) |
3153 (setq math-solve-ranges (cons (list var2 1 -1) | 3309 (setq math-solve-ranges (cons (list var2 1 -1) |
3154 math-solve-ranges))) | 3310 math-solve-ranges))) |
3155 (math-mul var2 val))) | 3311 (math-mul var2 val))) |
3156 (calc-record-why "*Choosing positive solution") | 3312 (calc-record-why "*Choosing positive solution") |
3157 val))) | 3313 val))) |
3158 | 3314 |
3159 (defun math-solve-get-int (val &optional range first) | 3315 (defun math-solve-get-int (val &optional range first) |
3160 (if solve-full | 3316 (if math-solve-full |
3161 (if (and (calc-var-value 'var-GenCount) | 3317 (if (and (calc-var-value 'var-GenCount) |
3162 (Math-natnump var-GenCount) | 3318 (Math-natnump var-GenCount) |
3163 (not (eq solve-full 'all))) | 3319 (not (eq math-solve-full 'all))) |
3164 (prog1 | 3320 (prog1 |
3165 (math-mul val (list 'calcFunc-an var-GenCount)) | 3321 (math-mul val (list 'calcFunc-an var-GenCount)) |
3166 (setq var-GenCount (math-add var-GenCount 1)) | 3322 (setq var-GenCount (math-add var-GenCount 1)) |
3167 (calc-refresh-evaltos 'var-GenCount)) | 3323 (calc-refresh-evaltos 'var-GenCount)) |
3168 (let* ((var (concat "n" (int-to-string | 3324 (let* ((var (concat "n" (int-to-string |
3169 (math-get-from-counter 'solve-int)))) | 3325 (math-get-from-counter 'solve-int)))) |
3170 (var2 (list 'var (intern var) (intern (concat "var-" var))))) | 3326 (var2 (list 'var (intern var) (intern (concat "var-" var))))) |
3171 (if (and range (eq solve-full 'all)) | 3327 (if (and range (eq math-solve-full 'all)) |
3172 (setq math-solve-ranges (cons (cons var2 | 3328 (setq math-solve-ranges (cons (cons var2 |
3173 (cdr (calcFunc-index | 3329 (cdr (calcFunc-index |
3174 range (or first 0)))) | 3330 range (or first 0)))) |
3175 math-solve-ranges))) | 3331 math-solve-ranges))) |
3176 (math-mul val var2))) | 3332 (math-mul val var2))) |
3189 (if (Math-integerp expr) | 3345 (if (Math-integerp expr) |
3190 (math-evenp expr) | 3346 (math-evenp expr) |
3191 (if (memq (car expr) '(* /)) | 3347 (if (memq (car expr) '(* /)) |
3192 (math-looks-evenp (nth 1 expr))))) | 3348 (math-looks-evenp (nth 1 expr))))) |
3193 | 3349 |
3194 (defun math-solve-for (lhs rhs solve-var solve-full &optional sign) | 3350 (defun math-solve-for (lhs rhs math-solve-var math-solve-full &optional sign) |
3195 (if (math-expr-contains rhs solve-var) | 3351 (if (math-expr-contains rhs math-solve-var) |
3196 (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full) | 3352 (math-solve-for (math-sub lhs rhs) 0 math-solve-var math-solve-full) |
3197 (and (math-expr-contains lhs solve-var) | 3353 (and (math-expr-contains lhs math-solve-var) |
3198 (math-with-extra-prec 1 | 3354 (math-with-extra-prec 1 |
3199 (let* ((math-poly-base-variable solve-var) | 3355 (let* ((math-poly-base-variable math-solve-var) |
3200 (res (math-try-solve-for lhs rhs sign))) | 3356 (res (math-try-solve-for lhs rhs sign))) |
3201 (if (and (eq solve-full 'all) | 3357 (if (and (eq math-solve-full 'all) |
3202 (math-known-realp solve-var)) | 3358 (math-known-realp math-solve-var)) |
3203 (let ((old-len (length res)) | 3359 (let ((old-len (length res)) |
3204 new-len) | 3360 new-len) |
3205 (setq res (delq nil | 3361 (setq res (delq nil |
3206 (mapcar (function | 3362 (mapcar (function |
3207 (lambda (x) | 3363 (lambda (x) |