Mercurial > emacs
comparison lisp/calc/calc-poly.el @ 90054:f2ebccfa87d4
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-74
Merge from emacs--cvs-trunk--0
Patches applied:
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-709
Update from CVS: src/indent.c (Fvertical_motion): Fix last change.
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-710
- miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-715
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-716
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-74
Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Wed, 08 Dec 2004 05:02:30 +0000 |
parents | b637c617432f 88f98983accf |
children | 62afea0771d8 |
comparison
equal
deleted
inserted
replaced
90053:fff5f1a61d92 | 90054:f2ebccfa87d4 |
---|---|
25 ;;; Commentary: | 25 ;;; Commentary: |
26 | 26 |
27 ;;; Code: | 27 ;;; Code: |
28 | 28 |
29 ;; This file is autoloaded from calc-ext.el. | 29 ;; This file is autoloaded from calc-ext.el. |
30 | |
30 (require 'calc-ext) | 31 (require 'calc-ext) |
31 | |
32 (require 'calc-macs) | 32 (require 'calc-macs) |
33 | |
34 (defun calc-Need-calc-poly () nil) | |
35 | |
36 | 33 |
37 (defun calcFunc-pcont (expr &optional var) | 34 (defun calcFunc-pcont (expr &optional var) |
38 (cond ((Math-primp expr) | 35 (cond ((Math-primp expr) |
39 (cond ((Math-zerop expr) 1) | 36 (cond ((Math-zerop expr) 1) |
40 ((Math-messy-integerp expr) (math-trunc expr)) | 37 ((Math-messy-integerp expr) (math-trunc expr)) |
514 (and (= (nth 1 a) (nth 1 b)) | 511 (and (= (nth 1 a) (nth 1 b)) |
515 (math-beforep (car a) (car b)))))))) | 512 (math-beforep (car a) (car b)))))))) |
516 | 513 |
517 ;;; Given an expression find all variables that are polynomial bases. | 514 ;;; Given an expression find all variables that are polynomial bases. |
518 ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). | 515 ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). |
519 ;;; Note dynamic scope of mpb-total-base. | 516 |
517 ;; The variable math-poly-base-total-base is local to | |
518 ;; math-total-polynomial-base, but is used by math-polynomial-p1, | |
519 ;; which is called by math-total-polynomial-base. | |
520 (defvar math-poly-base-total-base) | |
521 | |
520 (defun math-total-polynomial-base (expr) | 522 (defun math-total-polynomial-base (expr) |
521 (let ((mpb-total-base nil)) | 523 (let ((math-poly-base-total-base nil)) |
522 (math-polynomial-base expr 'math-polynomial-p1) | 524 (math-polynomial-base expr 'math-polynomial-p1) |
523 (math-sort-poly-base-list mpb-total-base))) | 525 (math-sort-poly-base-list math-poly-base-total-base))) |
526 | |
527 ;; The variable math-poly-base-top-expr is local to math-polynomial-base | |
528 ;; in calc-alg.el, but is used by math-polynomial-p1 which is called | |
529 ;; by math-polynomial-base. | |
530 (defvar math-poly-base-top-expr) | |
524 | 531 |
525 (defun math-polynomial-p1 (subexpr) | 532 (defun math-polynomial-p1 (subexpr) |
526 (or (assoc subexpr mpb-total-base) | 533 (or (assoc subexpr math-poly-base-total-base) |
527 (memq (car subexpr) '(+ - * / neg)) | 534 (memq (car subexpr) '(+ - * / neg)) |
528 (and (eq (car subexpr) '^) (natnump (nth 2 subexpr))) | 535 (and (eq (car subexpr) '^) (natnump (nth 2 subexpr))) |
529 (let* ((math-poly-base-variable subexpr) | 536 (let* ((math-poly-base-variable subexpr) |
530 (exponent (math-polynomial-p mpb-top-expr subexpr))) | 537 (exponent (math-polynomial-p math-poly-base-top-expr subexpr))) |
531 (if exponent | 538 (if exponent |
532 (setq mpb-total-base (cons (list subexpr exponent) | 539 (setq math-poly-base-total-base (cons (list subexpr exponent) |
533 mpb-total-base))))) | 540 math-poly-base-total-base))))) |
534 nil) | 541 nil) |
535 | 542 |
536 | 543 ;; The variable math-factored-vars is local to calcFunc-factors and |
537 | 544 ;; calcFunc-factor, but is used by math-factor-expr and |
538 | 545 ;; math-factor-expr-part, which are called (directly and indirectly) by |
539 (defun calcFunc-factors (expr &optional var) | 546 ;; calcFunc-factor and calcFunc-factors. |
547 (defvar math-factored-vars) | |
548 | |
549 ;; The variable math-fact-expr is local to calcFunc-factors, | |
550 ;; calcFunc-factor and math-factor-expr, but is used by math-factor-expr-try | |
551 ;; and math-factor-expr-part, which are called (directly and indirectly) by | |
552 ;; calcFunc-factor, calcFunc-factors and math-factor-expr. | |
553 (defvar math-fact-expr) | |
554 | |
555 ;; The variable math-to-list is local to calcFunc-factors and | |
556 ;; calcFunc-factor, but is used by math-accum-factors, which is | |
557 ;; called (indirectly) by calcFunc-factors and calcFunc-factor. | |
558 (defvar math-to-list) | |
559 | |
560 (defun calcFunc-factors (math-fact-expr &optional var) | |
540 (let ((math-factored-vars (if var t nil)) | 561 (let ((math-factored-vars (if var t nil)) |
541 (math-to-list t) | 562 (math-to-list t) |
542 (calc-prefer-frac t)) | 563 (calc-prefer-frac t)) |
543 (or var | 564 (or var |
544 (setq var (math-polynomial-base expr))) | 565 (setq var (math-polynomial-base math-fact-expr))) |
545 (let ((res (math-factor-finish | 566 (let ((res (math-factor-finish |
546 (or (catch 'factor (math-factor-expr-try var)) | 567 (or (catch 'factor (math-factor-expr-try var)) |
547 expr)))) | 568 math-fact-expr)))) |
548 (math-simplify (if (math-vectorp res) | 569 (math-simplify (if (math-vectorp res) |
549 res | 570 res |
550 (list 'vec (list 'vec res 1))))))) | 571 (list 'vec (list 'vec res 1))))))) |
551 | 572 |
552 (defun calcFunc-factor (expr &optional var) | 573 (defun calcFunc-factor (math-fact-expr &optional var) |
553 (let ((math-factored-vars nil) | 574 (let ((math-factored-vars nil) |
554 (math-to-list nil) | 575 (math-to-list nil) |
555 (calc-prefer-frac t)) | 576 (calc-prefer-frac t)) |
556 (math-simplify (math-factor-finish | 577 (math-simplify (math-factor-finish |
557 (if var | 578 (if var |
558 (let ((math-factored-vars t)) | 579 (let ((math-factored-vars t)) |
559 (or (catch 'factor (math-factor-expr-try var)) expr)) | 580 (or (catch 'factor (math-factor-expr-try var)) math-fact-expr)) |
560 (math-factor-expr expr)))))) | 581 (math-factor-expr math-fact-expr)))))) |
561 | 582 |
562 (defun math-factor-finish (x) | 583 (defun math-factor-finish (x) |
563 (if (Math-primp x) | 584 (if (Math-primp x) |
564 x | 585 x |
565 (if (eq (car x) 'calcFunc-Fac-Prot) | 586 (if (eq (car x) 'calcFunc-Fac-Prot) |
569 (defun math-factor-protect (x) | 590 (defun math-factor-protect (x) |
570 (if (memq (car-safe x) '(+ -)) | 591 (if (memq (car-safe x) '(+ -)) |
571 (list 'calcFunc-Fac-Prot x) | 592 (list 'calcFunc-Fac-Prot x) |
572 x)) | 593 x)) |
573 | 594 |
574 (defun math-factor-expr (expr) | 595 (defun math-factor-expr (math-fact-expr) |
575 (cond ((eq math-factored-vars t) expr) | 596 (cond ((eq math-factored-vars t) math-fact-expr) |
576 ((or (memq (car-safe expr) '(* / ^ neg)) | 597 ((or (memq (car-safe math-fact-expr) '(* / ^ neg)) |
577 (assq (car-safe expr) calc-tweak-eqn-table)) | 598 (assq (car-safe math-fact-expr) calc-tweak-eqn-table)) |
578 (cons (car expr) (mapcar 'math-factor-expr (cdr expr)))) | 599 (cons (car math-fact-expr) (mapcar 'math-factor-expr (cdr math-fact-expr)))) |
579 ((memq (car-safe expr) '(+ -)) | 600 ((memq (car-safe math-fact-expr) '(+ -)) |
580 (let* ((math-factored-vars math-factored-vars) | 601 (let* ((math-factored-vars math-factored-vars) |
581 (y (catch 'factor (math-factor-expr-part expr)))) | 602 (y (catch 'factor (math-factor-expr-part math-fact-expr)))) |
582 (if y | 603 (if y |
583 (math-factor-expr y) | 604 (math-factor-expr y) |
584 expr))) | 605 math-fact-expr))) |
585 (t expr))) | 606 (t math-fact-expr))) |
586 | 607 |
587 (defun math-factor-expr-part (x) ; uses "expr" | 608 (defun math-factor-expr-part (x) ; uses "expr" |
588 (if (memq (car-safe x) '(+ - * / ^ neg)) | 609 (if (memq (car-safe x) '(+ - * / ^ neg)) |
589 (while (setq x (cdr x)) | 610 (while (setq x (cdr x)) |
590 (math-factor-expr-part (car x))) | 611 (math-factor-expr-part (car x))) |
591 (and (not (Math-objvecp x)) | 612 (and (not (Math-objvecp x)) |
592 (not (assoc x math-factored-vars)) | 613 (not (assoc x math-factored-vars)) |
593 (> (math-factor-contains expr x) 1) | 614 (> (math-factor-contains math-fact-expr x) 1) |
594 (setq math-factored-vars (cons (list x) math-factored-vars)) | 615 (setq math-factored-vars (cons (list x) math-factored-vars)) |
595 (math-factor-expr-try x)))) | 616 (math-factor-expr-try x)))) |
596 | 617 |
597 (defun math-factor-expr-try (x) | 618 ;; The variable math-fet-x is local to math-factor-expr-try, but is |
598 (if (eq (car-safe expr) '*) | 619 ;; used by math-factor-poly-coefs, which is called by math-factor-expr-try. |
599 (let ((res1 (catch 'factor (let ((expr (nth 1 expr))) | 620 (defvar math-fet-x) |
600 (math-factor-expr-try x)))) | 621 |
601 (res2 (catch 'factor (let ((expr (nth 2 expr))) | 622 (defun math-factor-expr-try (math-fet-x) |
602 (math-factor-expr-try x))))) | 623 (if (eq (car-safe math-fact-expr) '*) |
624 (let ((res1 (catch 'factor (let ((math-fact-expr (nth 1 math-fact-expr))) | |
625 (math-factor-expr-try math-fet-x)))) | |
626 (res2 (catch 'factor (let ((math-fact-expr (nth 2 math-fact-expr))) | |
627 (math-factor-expr-try math-fet-x))))) | |
603 (and (or res1 res2) | 628 (and (or res1 res2) |
604 (throw 'factor (math-accum-factors (or res1 (nth 1 expr)) 1 | 629 (throw 'factor (math-accum-factors (or res1 (nth 1 math-fact-expr)) 1 |
605 (or res2 (nth 2 expr)))))) | 630 (or res2 (nth 2 math-fact-expr)))))) |
606 (let* ((p (math-is-polynomial expr x 30 'gen)) | 631 (let* ((p (math-is-polynomial math-fact-expr math-fet-x 30 'gen)) |
607 (math-poly-modulus (math-poly-modulus expr)) | 632 (math-poly-modulus (math-poly-modulus math-fact-expr)) |
608 res) | 633 res) |
609 (and (cdr p) | 634 (and (cdr p) |
610 (setq res (math-factor-poly-coefs p)) | 635 (setq res (math-factor-poly-coefs p)) |
611 (throw 'factor res))))) | 636 (throw 'factor res))))) |
612 | 637 |
640 (cdr (cdr facs))))) | 665 (cdr (cdr facs))))) |
641 (cons 'vec (cons (list 'vec fac pow) (cdr facs)))))))) | 666 (cons 'vec (cons (list 'vec fac pow) (cdr facs)))))))) |
642 (math-mul (math-pow fac pow) facs))) | 667 (math-mul (math-pow fac pow) facs))) |
643 | 668 |
644 (defun math-factor-poly-coefs (p &optional square-free) ; uses "x" | 669 (defun math-factor-poly-coefs (p &optional square-free) ; uses "x" |
645 (let (t1 t2) | 670 (let (t1 t2 temp) |
646 (cond ((not (cdr p)) | 671 (cond ((not (cdr p)) |
647 (or (car p) 0)) | 672 (or (car p) 0)) |
648 | 673 |
649 ;; Strip off multiples of x. | 674 ;; Strip off multiples of math-fet-x. |
650 ((Math-zerop (car p)) | 675 ((Math-zerop (car p)) |
651 (let ((z 0)) | 676 (let ((z 0)) |
652 (while (and p (Math-zerop (car p))) | 677 (while (and p (Math-zerop (car p))) |
653 (setq z (1+ z) p (cdr p))) | 678 (setq z (1+ z) p (cdr p))) |
654 (if (cdr p) | 679 (if (cdr p) |
655 (setq p (math-factor-poly-coefs p square-free)) | 680 (setq p (math-factor-poly-coefs p square-free)) |
656 (setq p (math-sort-terms (math-factor-expr (car p))))) | 681 (setq p (math-sort-terms (math-factor-expr (car p))))) |
657 (math-accum-factors x z (math-factor-protect p)))) | 682 (math-accum-factors math-fet-x z (math-factor-protect p)))) |
658 | 683 |
659 ;; Factor out content. | 684 ;; Factor out content. |
660 ((and (not square-free) | 685 ((and (not square-free) |
661 (not (eq 1 (setq t1 (math-mul (math-poly-gcd-list p) | 686 (not (eq 1 (setq t1 (math-mul (math-poly-gcd-list p) |
662 (if (math-guess-if-neg | 687 (if (math-guess-if-neg |
663 (nth (1- (length p)) p)) | 688 (nth (1- (length p)) p)) |
664 -1 1)))))) | 689 -1 1)))))) |
665 (math-accum-factors t1 1 (math-factor-poly-coefs | 690 (math-accum-factors t1 1 (math-factor-poly-coefs |
666 (math-poly-div-list p t1) 'cont))) | 691 (math-poly-div-list p t1) 'cont))) |
667 | 692 |
668 ;; Check if linear in x. | 693 ;; Check if linear in math-fet-x. |
669 ((not (cdr (cdr p))) | 694 ((not (cdr (cdr p))) |
670 (math-add (math-factor-protect | 695 (math-add (math-factor-protect |
671 (math-sort-terms | 696 (math-sort-terms |
672 (math-factor-expr (car p)))) | 697 (math-factor-expr (car p)))) |
673 (math-mul x (math-factor-protect | 698 (math-mul math-fet-x (math-factor-protect |
674 (math-sort-terms | 699 (math-sort-terms |
675 (math-factor-expr (nth 1 p))))))) | 700 (math-factor-expr (nth 1 p))))))) |
676 | 701 |
677 ;; If symbolic coefficients, use FactorRules. | 702 ;; If symbolic coefficients, use FactorRules. |
678 ((let ((pp p)) | 703 ((let ((pp p)) |
681 (Math-integerp (nth 1 (car pp))) | 706 (Math-integerp (nth 1 (car pp))) |
682 (Math-integerp (nth 2 (car pp)))))) | 707 (Math-integerp (nth 2 (car pp)))))) |
683 (setq pp (cdr pp))) | 708 (setq pp (cdr pp))) |
684 pp) | 709 pp) |
685 (let ((res (math-rewrite | 710 (let ((res (math-rewrite |
686 (list 'calcFunc-thecoefs x (cons 'vec p)) | 711 (list 'calcFunc-thecoefs math-fet-x (cons 'vec p)) |
687 '(var FactorRules var-FactorRules)))) | 712 '(var FactorRules var-FactorRules)))) |
688 (or (and (eq (car-safe res) 'calcFunc-thefactors) | 713 (or (and (eq (car-safe res) 'calcFunc-thefactors) |
689 (= (length res) 3) | 714 (= (length res) 3) |
690 (math-vectorp (nth 2 res)) | 715 (math-vectorp (nth 2 res)) |
691 (let ((facs 1) | 716 (let ((facs 1) |
692 (vec (nth 2 res))) | 717 (vec (nth 2 res))) |
693 (while (setq vec (cdr vec)) | 718 (while (setq vec (cdr vec)) |
694 (setq facs (math-accum-factors (car vec) 1 facs))) | 719 (setq facs (math-accum-factors (car vec) 1 facs))) |
695 facs)) | 720 facs)) |
696 (math-build-polynomial-expr p x)))) | 721 (math-build-polynomial-expr p math-fet-x)))) |
697 | 722 |
698 ;; Check if rational coefficients (i.e., not modulo a prime). | 723 ;; Check if rational coefficients (i.e., not modulo a prime). |
699 ((eq math-poly-modulus 1) | 724 ((eq math-poly-modulus 1) |
700 | 725 |
701 ;; Check if there are any squared terms, or a content not = 1. | 726 ;; Check if there are any squared terms, or a content not = 1. |
722 (let ((den (math-lcm-denoms | 747 (let ((den (math-lcm-denoms |
723 coef0 coef1))) | 748 coef0 coef1))) |
724 (setq scale (math-div scale den)) | 749 (setq scale (math-div scale den)) |
725 (math-add | 750 (math-add |
726 (math-add | 751 (math-add |
727 (math-mul den (math-pow x 2)) | 752 (math-mul den (math-pow math-fet-x 2)) |
728 (math-mul (math-mul coef1 den) x)) | 753 (math-mul (math-mul coef1 den) |
754 math-fet-x)) | |
729 (math-mul coef0 den))) | 755 (math-mul coef0 den))) |
730 (let ((den (math-lcm-denoms coef0))) | 756 (let ((den (math-lcm-denoms coef0))) |
731 (setq scale (math-div scale den)) | 757 (setq scale (math-div scale den)) |
732 (math-add (math-mul den x) | 758 (math-add (math-mul den math-fet-x) |
733 (math-mul coef0 den)))) | 759 (math-mul coef0 den)))) |
734 1 expr) | 760 1 expr) |
735 roots (cdr roots)))) | 761 roots (cdr roots)))) |
736 (setq expr (math-accum-factors | 762 (setq expr (math-accum-factors |
737 expr 1 | 763 expr 1 |
738 (math-mul csign | 764 (math-mul csign |
739 (math-build-polynomial-expr | 765 (math-build-polynomial-expr |
740 (math-mul-list (nth 1 t1) scale) | 766 (math-mul-list (nth 1 t1) scale) |
741 x))))) | 767 math-fet-x))))) |
742 (math-build-polynomial-expr p x)) ; can't factor it. | 768 (math-build-polynomial-expr p math-fet-x)) ; can't factor it. |
743 | 769 |
744 ;; Separate out the squared terms (Knuth exercise 4.6.2-34). | 770 ;; Separate out the squared terms (Knuth exercise 4.6.2-34). |
745 ;; This step also divides out the content of the polynomial. | 771 ;; This step also divides out the content of the polynomial. |
746 (let* ((cabs (math-poly-gcd-list p)) | 772 (let* ((cabs (math-poly-gcd-list p)) |
747 (csign (if (math-negp (nth (1- (length p)) p)) -1 1)) | 773 (csign (if (math-negp (nth (1- (length p)) p)) -1 1)) |
1142 (list '^ x n)))) | 1168 (list '^ x n)))) |
1143 | 1169 |
1144 (defun calcFunc-expandpow (x n) | 1170 (defun calcFunc-expandpow (x n) |
1145 (math-normalize (math-expand-power x n))) | 1171 (math-normalize (math-expand-power x n))) |
1146 | 1172 |
1173 (provide 'calc-poly) | |
1174 | |
1147 ;;; arch-tag: d2566c51-2ccc-45f1-8c50-f3462c2953ff | 1175 ;;; arch-tag: d2566c51-2ccc-45f1-8c50-f3462c2953ff |
1148 ;;; calc-poly.el ends here | 1176 ;;; calc-poly.el ends here |