diff options
| author | Jay Belanger | 2004-11-25 05:52:38 +0000 |
|---|---|---|
| committer | Jay Belanger | 2004-11-25 05:52:38 +0000 |
| commit | 4fd1fc35b1ca3df9722868fe56a4c86646b5109a (patch) | |
| tree | acbb05c32d92ac184cb255703e179256782b1561 | |
| parent | 885e6671fc6045c0723e9c65e1e8288142bbeb80 (diff) | |
| download | emacs-4fd1fc35b1ca3df9722868fe56a4c86646b5109a.tar.gz emacs-4fd1fc35b1ca3df9722868fe56a4c86646b5109a.zip | |
(math-poly-base-top-expr): New variable.
(math-polynomial-p1): Replace variable mpb-top-expr by declared
variable.
(math-poly-base-total-base): New variable.
(math-total-polynomial-base, math-polynomial-p1): Replace variable
mpb-total-base by declared variable.
(math-factored-vars, math-to-list): Declare it.
(math-fact-expr): New variable.
(calcFunc-factors, calcFunc-factor, math-factor-expr,
math-factor-expr-try, math-factor-expr-part): Replace variable expr by
declared variable.
(math-fet-x): New variable.
(math-factor-expr-try, math-factor-poly-coefs): Replace variable x by
declared variable.
(math-factor-poly-coefs): Make temp a local variable.
| -rw-r--r-- | lisp/calc/calc-poly.el | 119 |
1 files changed, 74 insertions, 45 deletions
diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el index 8a4b2571d20..28958efaab7 100644 --- a/lisp/calc/calc-poly.el +++ b/lisp/calc/calc-poly.el | |||
| @@ -516,48 +516,72 @@ | |||
| 516 | 516 | ||
| 517 | ;;; Given an expression find all variables that are polynomial bases. | 517 | ;;; Given an expression find all variables that are polynomial bases. |
| 518 | ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). | 518 | ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). |
| 519 | ;;; Note dynamic scope of mpb-total-base. | 519 | |
| 520 | ;; The variable math-poly-base-total-base is local to | ||
| 521 | ;; math-total-polynomial-base, but is used by math-polynomial-p1, | ||
| 522 | ;; which is called by math-total-polynomial-base. | ||
| 523 | (defvar math-poly-base-total-base) | ||
| 524 | |||
| 520 | (defun math-total-polynomial-base (expr) | 525 | (defun math-total-polynomial-base (expr) |
| 521 | (let ((mpb-total-base nil)) | 526 | (let ((math-poly-base-total-base nil)) |
| 522 | (math-polynomial-base expr 'math-polynomial-p1) | 527 | (math-polynomial-base expr 'math-polynomial-p1) |
| 523 | (math-sort-poly-base-list mpb-total-base))) | 528 | (math-sort-poly-base-list math-poly-base-total-base))) |
| 529 | |||
| 530 | ;; The variable math-poly-base-top-expr is local to math-polynomial-base | ||
| 531 | ;; in calc-alg.el, but is used by math-polynomial-p1 which is called | ||
| 532 | ;; by math-polynomial-base. | ||
| 533 | (defvar math-poly-base-top-expr) | ||
| 524 | 534 | ||
| 525 | (defun math-polynomial-p1 (subexpr) | 535 | (defun math-polynomial-p1 (subexpr) |
| 526 | (or (assoc subexpr mpb-total-base) | 536 | (or (assoc subexpr math-poly-base-total-base) |
| 527 | (memq (car subexpr) '(+ - * / neg)) | 537 | (memq (car subexpr) '(+ - * / neg)) |
| 528 | (and (eq (car subexpr) '^) (natnump (nth 2 subexpr))) | 538 | (and (eq (car subexpr) '^) (natnump (nth 2 subexpr))) |
| 529 | (let* ((math-poly-base-variable subexpr) | 539 | (let* ((math-poly-base-variable subexpr) |
| 530 | (exponent (math-polynomial-p mpb-top-expr subexpr))) | 540 | (exponent (math-polynomial-p math-poly-base-top-expr subexpr))) |
| 531 | (if exponent | 541 | (if exponent |
| 532 | (setq mpb-total-base (cons (list subexpr exponent) | 542 | (setq math-poly-base-total-base (cons (list subexpr exponent) |
| 533 | mpb-total-base))))) | 543 | math-poly-base-total-base))))) |
| 534 | nil) | 544 | nil) |
| 535 | 545 | ||
| 546 | ;; The variable math-factored-vars is local to calcFunc-factors and | ||
| 547 | ;; calcFunc-factor, but is used by math-factor-expr and | ||
| 548 | ;; math-factor-expr-part, which are called (directly and indirectly) by | ||
| 549 | ;; calcFunc-factor and calcFunc-factors. | ||
| 550 | (defvar math-factored-vars) | ||
| 536 | 551 | ||
| 552 | ;; The variable math-fact-expr is local to calcFunc-factors, | ||
| 553 | ;; calcFunc-factor and math-factor-expr, but is used by math-factor-expr-try | ||
| 554 | ;; and math-factor-expr-part, which are called (directly and indirectly) by | ||
| 555 | ;; calcFunc-factor, calcFunc-factors and math-factor-expr. | ||
| 556 | (defvar math-fact-expr) | ||
| 537 | 557 | ||
| 558 | ;; The variable math-to-list is local to calcFunc-factors and | ||
| 559 | ;; calcFunc-factor, but is used by math-accum-factors, which is | ||
| 560 | ;; called (indirectly) by calcFunc-factors and calcFunc-factor. | ||
| 561 | (defvar math-to-list) | ||
| 538 | 562 | ||
| 539 | (defun calcFunc-factors (expr &optional var) | 563 | (defun calcFunc-factors (math-fact-expr &optional var) |
| 540 | (let ((math-factored-vars (if var t nil)) | 564 | (let ((math-factored-vars (if var t nil)) |
| 541 | (math-to-list t) | 565 | (math-to-list t) |
| 542 | (calc-prefer-frac t)) | 566 | (calc-prefer-frac t)) |
| 543 | (or var | 567 | (or var |
| 544 | (setq var (math-polynomial-base expr))) | 568 | (setq var (math-polynomial-base math-fact-expr))) |
| 545 | (let ((res (math-factor-finish | 569 | (let ((res (math-factor-finish |
| 546 | (or (catch 'factor (math-factor-expr-try var)) | 570 | (or (catch 'factor (math-factor-expr-try var)) |
| 547 | expr)))) | 571 | math-fact-expr)))) |
| 548 | (math-simplify (if (math-vectorp res) | 572 | (math-simplify (if (math-vectorp res) |
| 549 | res | 573 | res |
| 550 | (list 'vec (list 'vec res 1))))))) | 574 | (list 'vec (list 'vec res 1))))))) |
| 551 | 575 | ||
| 552 | (defun calcFunc-factor (expr &optional var) | 576 | (defun calcFunc-factor (math-fact-expr &optional var) |
| 553 | (let ((math-factored-vars nil) | 577 | (let ((math-factored-vars nil) |
| 554 | (math-to-list nil) | 578 | (math-to-list nil) |
| 555 | (calc-prefer-frac t)) | 579 | (calc-prefer-frac t)) |
| 556 | (math-simplify (math-factor-finish | 580 | (math-simplify (math-factor-finish |
| 557 | (if var | 581 | (if var |
| 558 | (let ((math-factored-vars t)) | 582 | (let ((math-factored-vars t)) |
| 559 | (or (catch 'factor (math-factor-expr-try var)) expr)) | 583 | (or (catch 'factor (math-factor-expr-try var)) math-fact-expr)) |
| 560 | (math-factor-expr expr)))))) | 584 | (math-factor-expr math-fact-expr)))))) |
| 561 | 585 | ||
| 562 | (defun math-factor-finish (x) | 586 | (defun math-factor-finish (x) |
| 563 | (if (Math-primp x) | 587 | (if (Math-primp x) |
| @@ -571,18 +595,18 @@ | |||
| 571 | (list 'calcFunc-Fac-Prot x) | 595 | (list 'calcFunc-Fac-Prot x) |
| 572 | x)) | 596 | x)) |
| 573 | 597 | ||
| 574 | (defun math-factor-expr (expr) | 598 | (defun math-factor-expr (math-fact-expr) |
| 575 | (cond ((eq math-factored-vars t) expr) | 599 | (cond ((eq math-factored-vars t) math-fact-expr) |
| 576 | ((or (memq (car-safe expr) '(* / ^ neg)) | 600 | ((or (memq (car-safe math-fact-expr) '(* / ^ neg)) |
| 577 | (assq (car-safe expr) calc-tweak-eqn-table)) | 601 | (assq (car-safe math-fact-expr) calc-tweak-eqn-table)) |
| 578 | (cons (car expr) (mapcar 'math-factor-expr (cdr expr)))) | 602 | (cons (car math-fact-expr) (mapcar 'math-factor-expr (cdr math-fact-expr)))) |
| 579 | ((memq (car-safe expr) '(+ -)) | 603 | ((memq (car-safe math-fact-expr) '(+ -)) |
| 580 | (let* ((math-factored-vars math-factored-vars) | 604 | (let* ((math-factored-vars math-factored-vars) |
| 581 | (y (catch 'factor (math-factor-expr-part expr)))) | 605 | (y (catch 'factor (math-factor-expr-part math-fact-expr)))) |
| 582 | (if y | 606 | (if y |
| 583 | (math-factor-expr y) | 607 | (math-factor-expr y) |
| 584 | expr))) | 608 | math-fact-expr))) |
| 585 | (t expr))) | 609 | (t math-fact-expr))) |
| 586 | 610 | ||
| 587 | (defun math-factor-expr-part (x) ; uses "expr" | 611 | (defun math-factor-expr-part (x) ; uses "expr" |
| 588 | (if (memq (car-safe x) '(+ - * / ^ neg)) | 612 | (if (memq (car-safe x) '(+ - * / ^ neg)) |
| @@ -590,21 +614,25 @@ | |||
| 590 | (math-factor-expr-part (car x))) | 614 | (math-factor-expr-part (car x))) |
| 591 | (and (not (Math-objvecp x)) | 615 | (and (not (Math-objvecp x)) |
| 592 | (not (assoc x math-factored-vars)) | 616 | (not (assoc x math-factored-vars)) |
| 593 | (> (math-factor-contains expr x) 1) | 617 | (> (math-factor-contains math-fact-expr x) 1) |
| 594 | (setq math-factored-vars (cons (list x) math-factored-vars)) | 618 | (setq math-factored-vars (cons (list x) math-factored-vars)) |
| 595 | (math-factor-expr-try x)))) | 619 | (math-factor-expr-try x)))) |
| 596 | 620 | ||
| 597 | (defun math-factor-expr-try (x) | 621 | ;; The variable math-fet-x is local to math-factor-expr-try, but is |
| 598 | (if (eq (car-safe expr) '*) | 622 | ;; used by math-factor-poly-coefs, which is called by math-factor-expr-try. |
| 599 | (let ((res1 (catch 'factor (let ((expr (nth 1 expr))) | 623 | (defvar math-fet-x) |
| 600 | (math-factor-expr-try x)))) | 624 | |
| 601 | (res2 (catch 'factor (let ((expr (nth 2 expr))) | 625 | (defun math-factor-expr-try (math-fet-x) |
| 602 | (math-factor-expr-try x))))) | 626 | (if (eq (car-safe math-fact-expr) '*) |
| 627 | (let ((res1 (catch 'factor (let ((math-fact-expr (nth 1 math-fact-expr))) | ||
| 628 | (math-factor-expr-try math-fet-x)))) | ||
| 629 | (res2 (catch 'factor (let ((math-fact-expr (nth 2 math-fact-expr))) | ||
| 630 | (math-factor-expr-try math-fet-x))))) | ||
| 603 | (and (or res1 res2) | 631 | (and (or res1 res2) |
| 604 | (throw 'factor (math-accum-factors (or res1 (nth 1 expr)) 1 | 632 | (throw 'factor (math-accum-factors (or res1 (nth 1 math-fact-expr)) 1 |
| 605 | (or res2 (nth 2 expr)))))) | 633 | (or res2 (nth 2 math-fact-expr)))))) |
| 606 | (let* ((p (math-is-polynomial expr x 30 'gen)) | 634 | (let* ((p (math-is-polynomial math-fact-expr math-fet-x 30 'gen)) |
| 607 | (math-poly-modulus (math-poly-modulus expr)) | 635 | (math-poly-modulus (math-poly-modulus math-fact-expr)) |
| 608 | res) | 636 | res) |
| 609 | (and (cdr p) | 637 | (and (cdr p) |
| 610 | (setq res (math-factor-poly-coefs p)) | 638 | (setq res (math-factor-poly-coefs p)) |
| @@ -642,11 +670,11 @@ | |||
| 642 | (math-mul (math-pow fac pow) facs))) | 670 | (math-mul (math-pow fac pow) facs))) |
| 643 | 671 | ||
| 644 | (defun math-factor-poly-coefs (p &optional square-free) ; uses "x" | 672 | (defun math-factor-poly-coefs (p &optional square-free) ; uses "x" |
| 645 | (let (t1 t2) | 673 | (let (t1 t2 temp) |
| 646 | (cond ((not (cdr p)) | 674 | (cond ((not (cdr p)) |
| 647 | (or (car p) 0)) | 675 | (or (car p) 0)) |
| 648 | 676 | ||
| 649 | ;; Strip off multiples of x. | 677 | ;; Strip off multiples of math-fet-x. |
| 650 | ((Math-zerop (car p)) | 678 | ((Math-zerop (car p)) |
| 651 | (let ((z 0)) | 679 | (let ((z 0)) |
| 652 | (while (and p (Math-zerop (car p))) | 680 | (while (and p (Math-zerop (car p))) |
| @@ -654,7 +682,7 @@ | |||
| 654 | (if (cdr p) | 682 | (if (cdr p) |
| 655 | (setq p (math-factor-poly-coefs p square-free)) | 683 | (setq p (math-factor-poly-coefs p square-free)) |
| 656 | (setq p (math-sort-terms (math-factor-expr (car p))))) | 684 | (setq p (math-sort-terms (math-factor-expr (car p))))) |
| 657 | (math-accum-factors x z (math-factor-protect p)))) | 685 | (math-accum-factors math-fet-x z (math-factor-protect p)))) |
| 658 | 686 | ||
| 659 | ;; Factor out content. | 687 | ;; Factor out content. |
| 660 | ((and (not square-free) | 688 | ((and (not square-free) |
| @@ -665,12 +693,12 @@ | |||
| 665 | (math-accum-factors t1 1 (math-factor-poly-coefs | 693 | (math-accum-factors t1 1 (math-factor-poly-coefs |
| 666 | (math-poly-div-list p t1) 'cont))) | 694 | (math-poly-div-list p t1) 'cont))) |
| 667 | 695 | ||
| 668 | ;; Check if linear in x. | 696 | ;; Check if linear in math-fet-x. |
| 669 | ((not (cdr (cdr p))) | 697 | ((not (cdr (cdr p))) |
| 670 | (math-add (math-factor-protect | 698 | (math-add (math-factor-protect |
| 671 | (math-sort-terms | 699 | (math-sort-terms |
| 672 | (math-factor-expr (car p)))) | 700 | (math-factor-expr (car p)))) |
| 673 | (math-mul x (math-factor-protect | 701 | (math-mul math-fet-x (math-factor-protect |
| 674 | (math-sort-terms | 702 | (math-sort-terms |
| 675 | (math-factor-expr (nth 1 p))))))) | 703 | (math-factor-expr (nth 1 p))))))) |
| 676 | 704 | ||
| @@ -683,7 +711,7 @@ | |||
| 683 | (setq pp (cdr pp))) | 711 | (setq pp (cdr pp))) |
| 684 | pp) | 712 | pp) |
| 685 | (let ((res (math-rewrite | 713 | (let ((res (math-rewrite |
| 686 | (list 'calcFunc-thecoefs x (cons 'vec p)) | 714 | (list 'calcFunc-thecoefs math-fet-x (cons 'vec p)) |
| 687 | '(var FactorRules var-FactorRules)))) | 715 | '(var FactorRules var-FactorRules)))) |
| 688 | (or (and (eq (car-safe res) 'calcFunc-thefactors) | 716 | (or (and (eq (car-safe res) 'calcFunc-thefactors) |
| 689 | (= (length res) 3) | 717 | (= (length res) 3) |
| @@ -693,7 +721,7 @@ | |||
| 693 | (while (setq vec (cdr vec)) | 721 | (while (setq vec (cdr vec)) |
| 694 | (setq facs (math-accum-factors (car vec) 1 facs))) | 722 | (setq facs (math-accum-factors (car vec) 1 facs))) |
| 695 | facs)) | 723 | facs)) |
| 696 | (math-build-polynomial-expr p x)))) | 724 | (math-build-polynomial-expr p math-fet-x)))) |
| 697 | 725 | ||
| 698 | ;; Check if rational coefficients (i.e., not modulo a prime). | 726 | ;; Check if rational coefficients (i.e., not modulo a prime). |
| 699 | ((eq math-poly-modulus 1) | 727 | ((eq math-poly-modulus 1) |
| @@ -724,12 +752,13 @@ | |||
| 724 | (setq scale (math-div scale den)) | 752 | (setq scale (math-div scale den)) |
| 725 | (math-add | 753 | (math-add |
| 726 | (math-add | 754 | (math-add |
| 727 | (math-mul den (math-pow x 2)) | 755 | (math-mul den (math-pow math-fet-x 2)) |
| 728 | (math-mul (math-mul coef1 den) x)) | 756 | (math-mul (math-mul coef1 den) |
| 757 | math-fet-x)) | ||
| 729 | (math-mul coef0 den))) | 758 | (math-mul coef0 den))) |
| 730 | (let ((den (math-lcm-denoms coef0))) | 759 | (let ((den (math-lcm-denoms coef0))) |
| 731 | (setq scale (math-div scale den)) | 760 | (setq scale (math-div scale den)) |
| 732 | (math-add (math-mul den x) | 761 | (math-add (math-mul den math-fet-x) |
| 733 | (math-mul coef0 den)))) | 762 | (math-mul coef0 den)))) |
| 734 | 1 expr) | 763 | 1 expr) |
| 735 | roots (cdr roots)))) | 764 | roots (cdr roots)))) |
| @@ -738,8 +767,8 @@ | |||
| 738 | (math-mul csign | 767 | (math-mul csign |
| 739 | (math-build-polynomial-expr | 768 | (math-build-polynomial-expr |
| 740 | (math-mul-list (nth 1 t1) scale) | 769 | (math-mul-list (nth 1 t1) scale) |
| 741 | x))))) | 770 | math-fet-x))))) |
| 742 | (math-build-polynomial-expr p x)) ; can't factor it. | 771 | (math-build-polynomial-expr p math-fet-x)) ; can't factor it. |
| 743 | 772 | ||
| 744 | ;; Separate out the squared terms (Knuth exercise 4.6.2-34). | 773 | ;; Separate out the squared terms (Knuth exercise 4.6.2-34). |
| 745 | ;; This step also divides out the content of the polynomial. | 774 | ;; This step also divides out the content of the polynomial. |