aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJay Belanger2004-11-25 05:52:38 +0000
committerJay Belanger2004-11-25 05:52:38 +0000
commit4fd1fc35b1ca3df9722868fe56a4c86646b5109a (patch)
treeacbb05c32d92ac184cb255703e179256782b1561
parent885e6671fc6045c0723e9c65e1e8288142bbeb80 (diff)
downloademacs-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.el119
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.