/[emacs]/emacs/lisp/calc/calc-poly.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-poly.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:06:36 2001 UTC
# Line 1  Line 1 
1  ;; Calculator for GNU Emacs, part II [calc-poly.el]  ;; Calculator for GNU Emacs, part II [calc-poly.el]
2  ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
3  ;; Written by Dave Gillespie, daveg@synaptics.com.  ;; Written by Dave Gillespie, daveg@synaptics.com.
4    
5  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 65  Line 65 
65                     (math-neg (math-poly-gcd cont c2))                     (math-neg (math-poly-gcd cont c2))
66                   (math-poly-gcd cont c2))))))                   (math-poly-gcd cont c2))))))
67          (var expr)          (var expr)
68          (t 1))          (t 1)))
 )  
69    
70  (defun calcFunc-pprim (expr &optional var)  (defun calcFunc-pprim (expr &optional var)
71    (let ((cont (calcFunc-pcont expr var)))    (let ((cont (calcFunc-pcont expr var)))
72      (if (math-equal-int cont 1)      (if (math-equal-int cont 1)
73          expr          expr
74        (math-poly-div-exact expr cont var)))        (math-poly-div-exact expr cont var))))
 )  
75    
76  (defun math-div-poly-const (expr c)  (defun math-div-poly-const (expr c)
77    (cond ((memq (car-safe expr) '(+ -))    (cond ((memq (car-safe expr) '(+ -))
78           (list (car expr)           (list (car expr)
79                 (math-div-poly-const (nth 1 expr) c)                 (math-div-poly-const (nth 1 expr) c)
80                 (math-div-poly-const (nth 2 expr) c)))                 (math-div-poly-const (nth 2 expr) c)))
81          (t (math-div expr c)))          (t (math-div expr c))))
 )  
82    
83  (defun calcFunc-pdeg (expr &optional var)  (defun calcFunc-pdeg (expr &optional var)
84    (if (Math-zerop expr)    (if (Math-zerop expr)
# Line 89  Line 86 
86      (if var      (if var
87          (or (math-polynomial-p expr var)          (or (math-polynomial-p expr var)
88              (math-reject-arg expr "Expected a polynomial"))              (math-reject-arg expr "Expected a polynomial"))
89        (math-poly-degree expr)))        (math-poly-degree expr))))
 )  
90    
91  (defun math-poly-degree (expr)  (defun math-poly-degree (expr)
92    (cond ((Math-primp expr)    (cond ((Math-primp expr)
# Line 108  Line 104 
104          ((memq (car expr) '(+ -))          ((memq (car expr) '(+ -))
105           (max (math-poly-degree (nth 1 expr))           (max (math-poly-degree (nth 1 expr))
106                (math-poly-degree (nth 2 expr))))                (math-poly-degree (nth 2 expr))))
107          (t 1))          (t 1)))
 )  
108    
109  (defun calcFunc-plead (expr var)  (defun calcFunc-plead (expr var)
110    (cond ((eq (car-safe expr) '*)    (cond ((eq (car-safe expr) '*)
# Line 128  Line 123 
123           (let ((p (math-is-polynomial expr var)))           (let ((p (math-is-polynomial expr var)))
124             (if (cdr p)             (if (cdr p)
125                 (nth (1- (length p)) p)                 (nth (1- (length p)) p)
126               1))))               1)))))
 )  
127    
128    
129    
# Line 149  Line 143 
143        (math-reject-arg pd "Coefficients must be rational"))        (math-reject-arg pd "Coefficients must be rational"))
144    (let ((calc-prefer-frac t)    (let ((calc-prefer-frac t)
145          (math-poly-modulus (math-poly-modulus pn pd)))          (math-poly-modulus (math-poly-modulus pn pd)))
146      (math-poly-gcd pn pd))      (math-poly-gcd pn pd)))
 )  
147    
148  ;;; Return only quotient to top of stack (nil if zero)  ;;; Return only quotient to top of stack (nil if zero)
149  (defun calcFunc-pdiv (pn pd &optional base)  (defun calcFunc-pdiv (pn pd &optional base)
# Line 158  Line 151 
151           (math-poly-modulus (math-poly-modulus pn pd))           (math-poly-modulus (math-poly-modulus pn pd))
152           (res (math-poly-div pn pd base)))           (res (math-poly-div pn pd base)))
153      (setq calc-poly-div-remainder (cdr res))      (setq calc-poly-div-remainder (cdr res))
154      (car res))      (car res)))
 )  
155    
156  ;;; Return only remainder to top of stack  ;;; Return only remainder to top of stack
157  (defun calcFunc-prem (pn pd &optional base)  (defun calcFunc-prem (pn pd &optional base)
158    (let ((calc-prefer-frac t)    (let ((calc-prefer-frac t)
159          (math-poly-modulus (math-poly-modulus pn pd)))          (math-poly-modulus (math-poly-modulus pn pd)))
160      (cdr (math-poly-div pn pd base)))      (cdr (math-poly-div pn pd base))))
 )  
161    
162  (defun calcFunc-pdivrem (pn pd &optional base)  (defun calcFunc-pdivrem (pn pd &optional base)
163    (let* ((calc-prefer-frac t)    (let* ((calc-prefer-frac t)
164           (math-poly-modulus (math-poly-modulus pn pd))           (math-poly-modulus (math-poly-modulus pn pd))
165           (res (math-poly-div pn pd base)))           (res (math-poly-div pn pd base)))
166      (list 'vec (car res) (cdr res)))      (list 'vec (car res) (cdr res))))
 )  
167    
168  (defun calcFunc-pdivide (pn pd &optional base)  (defun calcFunc-pdivide (pn pd &optional base)
169    (let* ((calc-prefer-frac t)    (let* ((calc-prefer-frac t)
170           (math-poly-modulus (math-poly-modulus pn pd))           (math-poly-modulus (math-poly-modulus pn pd))
171           (res (math-poly-div pn pd base)))           (res (math-poly-div pn pd base)))
172      (math-add (car res) (math-div (cdr res) pd)))      (math-add (car res) (math-div (cdr res) pd))))
 )  
173    
174    
175  ;;; Multiply two terms, expanding out products of sums.  ;;; Multiply two terms, expanding out products of sums.
# Line 193  Line 182 
182          (list (car rhs)          (list (car rhs)
183                (math-mul-thru lhs (nth 1 rhs))                (math-mul-thru lhs (nth 1 rhs))
184                (math-mul-thru lhs (nth 2 rhs)))                (math-mul-thru lhs (nth 2 rhs)))
185        (math-mul lhs rhs)))        (math-mul lhs rhs))))
 )  
186    
187  (defun math-div-thru (num den)  (defun math-div-thru (num den)
188    (if (memq (car-safe num) '(+ -))    (if (memq (car-safe num) '(+ -))
189        (list (car num)        (list (car num)
190              (math-div-thru (nth 1 num) den)              (math-div-thru (nth 1 num) den)
191              (math-div-thru (nth 2 num) den))              (math-div-thru (nth 2 num) den))
192      (math-div num den))      (math-div num den)))
 )  
193    
194    
195  ;;; Sort the terms of a sum into canonical order.  ;;; Sort the terms of a sum into canonical order.
# Line 211  Line 198 
198        (math-list-to-sum        (math-list-to-sum
199         (sort (math-sum-to-list expr)         (sort (math-sum-to-list expr)
200               (function (lambda (a b) (math-beforep (car a) (car b))))))               (function (lambda (a b) (math-beforep (car a) (car b))))))
201      expr)      expr))
 )  
202    
203  (defun math-list-to-sum (lst)  (defun math-list-to-sum (lst)
204    (if (cdr lst)    (if (cdr lst)
# Line 221  Line 207 
207              (car (car lst)))              (car (car lst)))
208      (if (cdr (car lst))      (if (cdr (car lst))
209          (math-neg (car (car lst)))          (math-neg (car (car lst)))
210        (car (car lst))))        (car (car lst)))))
 )  
211    
212  (defun math-sum-to-list (tree &optional neg)  (defun math-sum-to-list (tree &optional neg)
213    (cond ((eq (car-safe tree) '+)    (cond ((eq (car-safe tree) '+)
# Line 231  Line 216 
216          ((eq (car-safe tree) '-)          ((eq (car-safe tree) '-)
217           (nconc (math-sum-to-list (nth 1 tree) neg)           (nconc (math-sum-to-list (nth 1 tree) neg)
218                  (math-sum-to-list (nth 2 tree) (not neg))))                  (math-sum-to-list (nth 2 tree) (not neg))))
219          (t (list (cons tree neg))))          (t (list (cons tree neg)))))
 )  
220    
221  ;;; Check if the polynomial coefficients are modulo forms.  ;;; Check if the polynomial coefficients are modulo forms.
222  (defun math-poly-modulus (expr &optional expr2)  (defun math-poly-modulus (expr &optional expr2)
223    (or (math-poly-modulus-rec expr)    (or (math-poly-modulus-rec expr)
224        (and expr2 (math-poly-modulus-rec expr2))        (and expr2 (math-poly-modulus-rec expr2))
225        1)        1))
 )  
226    
227  (defun math-poly-modulus-rec (expr)  (defun math-poly-modulus-rec (expr)
228    (if (and (eq (car-safe expr) 'mod) (Math-natnump (nth 2 expr)))    (if (and (eq (car-safe expr) 'mod) (Math-natnump (nth 2 expr)))
229        (list 'mod 1 (nth 2 expr))        (list 'mod 1 (nth 2 expr))
230      (and (memq (car-safe expr) '(+ - * /))      (and (memq (car-safe expr) '(+ - * /))
231           (or (math-poly-modulus-rec (nth 1 expr))           (or (math-poly-modulus-rec (nth 1 expr))
232               (math-poly-modulus-rec (nth 2 expr)))))               (math-poly-modulus-rec (nth 2 expr))))))
 )  
233    
234    
235  ;;; Divide two polynomials.  Return (quotient . remainder).  ;;; Divide two polynomials.  Return (quotient . remainder).
236  (defun math-poly-div (u v &optional math-poly-div-base)  (defun math-poly-div (u v &optional math-poly-div-base)
237    (if math-poly-div-base    (if math-poly-div-base
238        (math-do-poly-div u v)        (math-do-poly-div u v)
239      (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v)))      (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v))))
 )  
240  (setq math-poly-div-base nil)  (setq math-poly-div-base nil)
241    
242  (defun math-poly-div-exact (u v &optional base)  (defun math-poly-div-exact (u v &optional base)
243    (let ((res (math-poly-div u v base)))    (let ((res (math-poly-div u v base)))
244      (if (eq (cdr res) 0)      (if (eq (cdr res) 0)
245          (car res)          (car res)
246        (math-reject-arg (list 'vec u v) "Argument is not a polynomial")))        (math-reject-arg (list 'vec u v) "Argument is not a polynomial"))))
 )  
247    
248  (defun math-do-poly-div (u v)  (defun math-do-poly-div (u v)
249    (cond ((math-constp u)    (cond ((math-constp u)
# Line 293  Line 273 
273               (setq up (math-is-polynomial u base nil 'gen)               (setq up (math-is-polynomial u base nil 'gen)
274                     res (math-poly-div-coefs up vp))                     res (math-poly-div-coefs up vp))
275               (cons (math-build-polynomial-expr (car res) base)               (cons (math-build-polynomial-expr (car res) base)
276                     (math-build-polynomial-expr (cdr res) base))))))                     (math-build-polynomial-expr (cdr res) base)))))))
 )  
277    
278  (defun math-poly-div-rec (u v)  (defun math-poly-div-rec (u v)
279    (cond ((math-constp u)    (cond ((math-constp u)
# Line 322  Line 301 
301                     res (math-poly-div-coefs up vp))                     res (math-poly-div-coefs up vp))
302               (math-add (math-build-polynomial-expr (car res) base)               (math-add (math-build-polynomial-expr (car res) base)
303                         (math-div (math-build-polynomial-expr (cdr res) base)                         (math-div (math-build-polynomial-expr (cdr res) base)
304                                   v))))))                                   v)))))))
 )  
305    
306  ;;; Divide two polynomials in coefficient-list form.  Return (quot . rem).  ;;; Divide two polynomials in coefficient-list form.  Return (quot . rem).
307  (defun math-poly-div-coefs (u v)  (defun math-poly-div-coefs (u v)
# Line 349  Line 327 
327             (cons q (nreverse (mapcar 'math-simplify urev)))))             (cons q (nreverse (mapcar 'math-simplify urev)))))
328          (t          (t
329           (cons (list (math-poly-div-rec (car u) (car v)))           (cons (list (math-poly-div-rec (car u) (car v)))
330                 nil)))                 nil))))
 )  
331    
332  ;;; Perform a pseudo-division of polynomials.  (See Knuth section 4.6.1.)  ;;; Perform a pseudo-division of polynomials.  (See Knuth section 4.6.1.)
333  ;;; This returns only the remainder from the pseudo-division.  ;;; This returns only the remainder from the pseudo-division.
# Line 375  Line 352 
352             (while (and urev (Math-zerop (car urev)))             (while (and urev (Math-zerop (car urev)))
353               (setq urev (cdr urev)))               (setq urev (cdr urev)))
354             (nreverse (mapcar 'math-simplify urev))))             (nreverse (mapcar 'math-simplify urev))))
355          (t nil))          (t nil)))
 )  
356    
357  ;;; Compute the GCD of two multivariate polynomials.  ;;; Compute the GCD of two multivariate polynomials.
358  (defun math-poly-gcd (u v)  (defun math-poly-gcd (u v)
# Line 398  Line 374 
374                    (math-poly-gcd-coefs (math-is-polynomial u base nil 'gen)                    (math-poly-gcd-coefs (math-is-polynomial u base nil 'gen)
375                                         (math-is-polynomial v base nil 'gen))                                         (math-is-polynomial v base nil 'gen))
376                    base)))                    base)))
377               (calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u))))))               (calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u)))))))
 )  
378    
379  (defun math-poly-div-list (lst a)  (defun math-poly-div-list (lst a)
380    (if (eq a 1)    (if (eq a 1)
381        lst        lst
382      (if (eq a -1)      (if (eq a -1)
383          (math-mul-list lst a)          (math-mul-list lst a)
384        (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst)))        (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst))))
 )  
385    
386  (defun math-mul-list (lst a)  (defun math-mul-list (lst a)
387    (if (eq a 1)    (if (eq a 1)
# Line 415  Line 389 
389      (if (eq a -1)      (if (eq a -1)
390          (mapcar 'math-neg lst)          (mapcar 'math-neg lst)
391        (and (not (eq a 0))        (and (not (eq a 0))
392             (mapcar (function (lambda (x) (math-mul x a))) lst))))             (mapcar (function (lambda (x) (math-mul x a))) lst)))))
 )  
393    
394  ;;; Run GCD on all elements in a list.  ;;; Run GCD on all elements in a list.
395  (defun math-poly-gcd-list (lst)  (defun math-poly-gcd-list (lst)
# Line 427  Line 400 
400          (or (eq (car lst) 0)          (or (eq (car lst) 0)
401              (setq gcd (math-poly-gcd gcd (car lst)))))              (setq gcd (math-poly-gcd gcd (car lst)))))
402        (if lst (setq lst (math-poly-gcd-frac-list lst)))        (if lst (setq lst (math-poly-gcd-frac-list lst)))
403        gcd))        gcd)))
 )  
404    
405  (defun math-poly-gcd-frac-list (lst)  (defun math-poly-gcd-frac-list (lst)
406    (while (and lst (not (eq (car-safe (car lst)) 'frac)))    (while (and lst (not (eq (car-safe (car lst)) 'frac)))
# Line 439  Line 411 
411            (if (eq (car-safe (car lst)) 'frac)            (if (eq (car-safe (car lst)) 'frac)
412                (setq denom (calcFunc-lcm denom (nth 2 (car lst))))))                (setq denom (calcFunc-lcm denom (nth 2 (car lst))))))
413          (list 'frac 1 denom))          (list 'frac 1 denom))
414      1)      1))
 )  
415    
416  ;;; Compute the GCD of two monovariate polynomial lists.  ;;; Compute the GCD of two monovariate polynomial lists.
417  ;;; Knuth section 4.6.1, algorithm C.  ;;; Knuth section 4.6.1, algorithm C.
# Line 473  Line 444 
444          (setq v (math-mul-list v -1)))          (setq v (math-mul-list v -1)))
445      (while (>= (setq z (1- z)) 0)      (while (>= (setq z (1- z)) 0)
446        (setq v (cons 0 v)))        (setq v (cons 0 v)))
447      v)      v))
 )  
448    
449    
450  ;;; Return true if is a factor containing no sums or quotients.  ;;; Return true if is a factor containing no sums or quotients.
# Line 486  Line 456 
456           nil)           nil)
457          ((memq (car-safe expr) '(^ neg))          ((memq (car-safe expr) '(^ neg))
458           (math-atomic-factorp (nth 1 expr)))           (math-atomic-factorp (nth 1 expr)))
459          (t t))          (t t)))
 )  
460    
461  ;;; Find a suitable base for dividing a by b.  ;;; Find a suitable base for dividing a by b.
462  ;;; The base must exist in both expressions.  ;;; The base must exist in both expressions.
# Line 506  Line 475 
475                 (if maybe                 (if maybe
476                     (if (>= (nth 1 (car a-base)) (nth 1 maybe))                     (if (>= (nth 1 (car a-base)) (nth 1 maybe))
477                         (throw 'return (car (car a-base))))))                         (throw 'return (car (car a-base))))))
478               (setq a-base (cdr a-base))))))               (setq a-base (cdr a-base)))))))
 )  
479    
480  ;;; Same as above but for gcd algorithm.  ;;; Same as above but for gcd algorithm.
481  ;;; Here there is no requirement that degree(a) > degree(b).  ;;; Here there is no requirement that degree(a) > degree(b).
# Line 526  Line 494 
494                     (setq a-base (cdr a-base)))                     (setq a-base (cdr a-base)))
495                 (if (assoc (car (car b-base)) a-base)                 (if (assoc (car (car b-base)) a-base)
496                     (throw 'return (car (car b-base)))                     (throw 'return (car (car b-base)))
497                   (setq b-base (cdr b-base))))))))                   (setq b-base (cdr b-base)))))))))
 )  
498    
499  ;;; Sort a list of polynomial bases.  ;;; Sort a list of polynomial bases.
500  (defun math-sort-poly-base-list (lst)  (defun math-sort-poly-base-list (lst)
501    (sort lst (function (lambda (a b)    (sort lst (function (lambda (a b)
502                          (or (> (nth 1 a) (nth 1 b))                          (or (> (nth 1 a) (nth 1 b))
503                              (and (= (nth 1 a) (nth 1 b))                              (and (= (nth 1 a) (nth 1 b))
504                                   (math-beforep (car a) (car b)))))))                                   (math-beforep (car a) (car b))))))))
 )  
505    
506  ;;; Given an expression find all variables that are polynomial bases.  ;;; Given an expression find all variables that are polynomial bases.
507  ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).  ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).
# Line 543  Line 509 
509  (defun math-total-polynomial-base (expr)  (defun math-total-polynomial-base (expr)
510    (let ((mpb-total-base nil))    (let ((mpb-total-base nil))
511      (math-polynomial-base expr 'math-polynomial-p1)      (math-polynomial-base expr 'math-polynomial-p1)
512      (math-sort-poly-base-list mpb-total-base))      (math-sort-poly-base-list mpb-total-base)))
 )  
513    
514  (defun math-polynomial-p1 (subexpr)  (defun math-polynomial-p1 (subexpr)
515    (or (assoc subexpr mpb-total-base)    (or (assoc subexpr mpb-total-base)
# Line 555  Line 520 
520          (if exponent          (if exponent
521              (setq mpb-total-base (cons (list subexpr exponent)              (setq mpb-total-base (cons (list subexpr exponent)
522                                         mpb-total-base)))))                                         mpb-total-base)))))
523    nil    nil)
 )  
524    
525    
526    
# Line 572  Line 536 
536                      expr))))                      expr))))
537        (math-simplify (if (math-vectorp res)        (math-simplify (if (math-vectorp res)
538                           res                           res
539                         (list 'vec (list 'vec res 1))))))                         (list 'vec (list 'vec res 1)))))))
 )  
540    
541  (defun calcFunc-factor (expr &optional var)  (defun calcFunc-factor (expr &optional var)
542    (let ((math-factored-vars nil)    (let ((math-factored-vars nil)
# Line 583  Line 546 
546                      (if var                      (if var
547                          (let ((math-factored-vars t))                          (let ((math-factored-vars t))
548                            (or (catch 'factor (math-factor-expr-try var)) expr))                            (or (catch 'factor (math-factor-expr-try var)) expr))
549                        (math-factor-expr expr)))))                        (math-factor-expr expr))))))
 )  
550    
551  (defun math-factor-finish (x)  (defun math-factor-finish (x)
552    (if (Math-primp x)    (if (Math-primp x)
553        x        x
554      (if (eq (car x) 'calcFunc-Fac-Prot)      (if (eq (car x) 'calcFunc-Fac-Prot)
555          (math-factor-finish (nth 1 x))          (math-factor-finish (nth 1 x))
556        (cons (car x) (mapcar 'math-factor-finish (cdr x)))))        (cons (car x) (mapcar 'math-factor-finish (cdr x))))))
 )  
557    
558  (defun math-factor-protect (x)  (defun math-factor-protect (x)
559    (if (memq (car-safe x) '(+ -))    (if (memq (car-safe x) '(+ -))
560        (list 'calcFunc-Fac-Prot x)        (list 'calcFunc-Fac-Prot x)
561      x)      x))
 )  
562    
563  (defun math-factor-expr (expr)  (defun math-factor-expr (expr)
564    (cond ((eq math-factored-vars t) expr)    (cond ((eq math-factored-vars t) expr)
# Line 611  Line 571 
571             (if y             (if y
572                 (math-factor-expr y)                 (math-factor-expr y)
573               expr)))               expr)))
574          (t expr))          (t expr)))
 )  
575    
576  (defun math-factor-expr-part (x)    ; uses "expr"  (defun math-factor-expr-part (x)    ; uses "expr"
577    (if (memq (car-safe x) '(+ - * / ^ neg))    (if (memq (car-safe x) '(+ - * / ^ neg))
# Line 622  Line 581 
581           (not (assoc x math-factored-vars))           (not (assoc x math-factored-vars))
582           (> (math-factor-contains expr x) 1)           (> (math-factor-contains expr x) 1)
583           (setq math-factored-vars (cons (list x) math-factored-vars))           (setq math-factored-vars (cons (list x) math-factored-vars))
584           (math-factor-expr-try x)))           (math-factor-expr-try x))))
 )  
585    
586  (defun math-factor-expr-try (x)  (defun math-factor-expr-try (x)
587    (if (eq (car-safe expr) '*)    (if (eq (car-safe expr) '*)
# Line 639  Line 597 
597             res)             res)
598        (and (cdr p)        (and (cdr p)
599             (setq res (math-factor-poly-coefs p))             (setq res (math-factor-poly-coefs p))
600             (throw 'factor res))))             (throw 'factor res)))))
 )  
601    
602  (defun math-accum-factors (fac pow facs)  (defun math-accum-factors (fac pow facs)
603    (if math-to-list    (if math-to-list
# Line 671  Line 628 
628                    (cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow)                    (cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow)
629                                                        (cdr (cdr facs)))))                                                        (cdr (cdr facs)))))
630                  (cons 'vec (cons (list 'vec fac pow) (cdr facs))))))))                  (cons 'vec (cons (list 'vec fac pow) (cdr facs))))))))
631      (math-mul (math-pow fac pow) facs))      (math-mul (math-pow fac pow) facs)))
 )  
632    
633  (defun math-factor-poly-coefs (p &optional square-free)    ; uses "x"  (defun math-factor-poly-coefs (p &optional square-free)    ; uses "x"
634    (let (t1 t2)    (let (t1 t2)
# Line 813  Line 769 
769             (and (setq temp (math-factor-poly-coefs p))             (and (setq temp (math-factor-poly-coefs p))
770                  (math-pow temp (nth 2 math-poly-modulus))))                  (math-pow temp (nth 2 math-poly-modulus))))
771            (t            (t
772             (math-reject-arg nil "*Modulo factorization not yet implemented"))))             (math-reject-arg nil "*Modulo factorization not yet implemented")))))
 )  
773    
774  (defun math-poly-deriv-coefs (p)  (defun math-poly-deriv-coefs (p)
775    (let ((n 1)    (let ((n 1)
# Line 822  Line 777 
777      (while (setq p (cdr p))      (while (setq p (cdr p))
778        (setq dp (cons (math-mul (car p) n) dp)        (setq dp (cons (math-mul (car p) n) dp)
779              n (1+ n)))              n (1+ n)))
780      (nreverse dp))      (nreverse dp)))
 )  
781    
782  (defun math-factor-contains (x a)  (defun math-factor-contains (x a)
783    (if (equal x a)    (if (equal x a)
# Line 836  Line 790 
790        (if (and (eq (car-safe x) '^)        (if (and (eq (car-safe x) '^)
791                 (natnump (nth 2 x)))                 (natnump (nth 2 x)))
792            (* (math-factor-contains (nth 1 x) a) (nth 2 x))            (* (math-factor-contains (nth 1 x) a) (nth 2 x))
793          0)))          0))))
 )  
794    
795    
796    
# Line 860  Line 813 
813                  (den2 (math-poly-div den g)))                  (den2 (math-poly-div den g)))
814              (and (eq (cdr num2) 0) (eq (cdr den2) 0)              (and (eq (cdr num2) 0) (eq (cdr den2) 0)
815                   (setq num (car num2) den (car den2)))))                   (setq num (car num2) den (car den2)))))
816        (math-simplify (math-div num den))))        (math-simplify (math-div num den)))))
 )  
817    
818  ;;; Returns expressions (num . denom).  ;;; Returns expressions (num . denom).
819  (defun math-to-ratpoly (expr)  (defun math-to-ratpoly (expr)
820    (let ((res (math-to-ratpoly-rec expr)))    (let ((res (math-to-ratpoly-rec expr)))
821      (cons (math-simplify (car res)) (math-simplify (cdr res))))      (cons (math-simplify (car res)) (math-simplify (cdr res)))))
 )  
822    
823  (defun math-to-ratpoly-rec (expr)  (defun math-to-ratpoly-rec (expr)
824    (cond ((Math-primp expr)    (cond ((Math-primp expr)
# Line 933  Line 884 
884          ((eq (car expr) 'neg)          ((eq (car expr) 'neg)
885           (let ((r1 (math-to-ratpoly-rec (nth 1 expr))))           (let ((r1 (math-to-ratpoly-rec (nth 1 expr))))
886             (cons (math-neg (car r1)) (cdr r1))))             (cons (math-neg (car r1)) (cdr r1))))
887          (t (cons expr 1)))          (t (cons expr 1))))
 )  
888    
889    
890  (defun math-ratpoly-p (expr &optional var)  (defun math-ratpoly-p (expr &optional var)
# Line 963  Line 913 
913             (and p1 (* p1 (nth 2 expr)))))             (and p1 (* p1 (nth 2 expr)))))
914          ((not var) 1)          ((not var) 1)
915          ((math-poly-depends expr var) nil)          ((math-poly-depends expr var) nil)
916          (t 0))          (t 0)))
 )  
917    
918    
919  (defun calcFunc-apart (expr &optional var)  (defun calcFunc-apart (expr &optional var)
# Line 990  Line 939 
939             (math-add q (or (and var             (math-add q (or (and var
940                                  (math-expr-contains den var)                                  (math-expr-contains den var)
941                                  (math-partial-fractions r den var))                                  (math-partial-fractions r den var))
942                             (math-div r den))))))                             (math-div r den)))))))
 )  
943    
944    
945  (defun math-padded-polynomial (expr var deg)  (defun math-padded-polynomial (expr var deg)
946    (let ((p (math-is-polynomial expr var deg)))    (let ((p (math-is-polynomial expr var deg)))
947      (append p (make-list (- deg (length p)) 0)))      (append p (make-list (- deg (length p)) 0))))
 )  
948    
949  (defun math-partial-fractions (r den var)  (defun math-partial-fractions (r den var)
950    (let* ((fden (calcFunc-factors den var))    (let* ((fden (calcFunc-factors den var))
# Line 1063  Line 1010 
1010                                res (math-add res (math-div num (car dlist)))                                res (math-add res (math-div num (car dlist)))
1011                                num nil))                                num nil))
1012                      (setq dlist (cdr dlist)))                      (setq dlist (cdr dlist)))
1013                    (math-normalize res))))))                    (math-normalize res)))))))
 )  
1014    
1015    
1016    
# Line 1096  Line 1042 
1042                              (list '^ (nth 1 expr) (1- (nth 2 expr)))))                              (list '^ (nth 1 expr) (1- (nth 2 expr)))))
1043                  (if (< (nth 2 expr) 0)                  (if (< (nth 2 expr) 0)
1044                      (list '/ 1 (list '^ (nth 1 expr) (- (nth 2 expr))))))))                      (list '/ 1 (list '^ (nth 1 expr) (- (nth 2 expr))))))))
1045          (t expr))          (t expr)))
 )  
1046    
1047  (defun calcFunc-expand (expr &optional many)  (defun calcFunc-expand (expr &optional many)
1048    (math-normalize (math-map-tree 'math-expand-term expr many))    (math-normalize (math-map-tree 'math-expand-term expr many)))
 )  
1049    
1050  (defun math-expand-power (x n &optional var else-nil)  (defun math-expand-power (x n &optional var else-nil)
1051    (or (and (natnump n)    (or (and (natnump n)
# Line 1184  Line 1128 
1128                           (setq p1 (cdr p1)))                           (setq p1 (cdr p1)))
1129                         accum))))))                         accum))))))
1130        (and (not else-nil)        (and (not else-nil)
1131             (list '^ x n)))             (list '^ x n))))
 )  
1132    
1133  (defun calcFunc-expandpow (x n)  (defun calcFunc-expandpow (x n)
1134    (math-normalize (math-expand-power x n))    (math-normalize (math-expand-power x n)))
 )  
   
   
1135    
1136    ;;; calc-poly.el ends here

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26