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. |
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) |
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) |
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) '*) |
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 |
|
|
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) |
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. |
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. |
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) |
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) '+) |
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) |
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) |
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) |
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. |
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) |
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) |
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) |
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))) |
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. |
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. |
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. |
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). |
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) ... ). |
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) |
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 |
|
|
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) |
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) |
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)) |
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) '*) |
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 |
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) |
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) |
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) |
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 |
|
|
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) |
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) |
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) |
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)) |
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 |
|
|
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) |
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 |