1 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
|
---|
2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
3 | ;;;
|
---|
4 | ;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
|
---|
5 | ;;;
|
---|
6 | ;;; This program is free software; you can redistribute it and/or modify
|
---|
7 | ;;; it under the terms of the GNU General Public License as published by
|
---|
8 | ;;; the Free Software Foundation; either version 2 of the License, or
|
---|
9 | ;;; (at your option) any later version.
|
---|
10 | ;;;
|
---|
11 | ;;; This program is distributed in the hope that it will be useful,
|
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
---|
14 | ;;; GNU General Public License for more details.
|
---|
15 | ;;;
|
---|
16 | ;;; You should have received a copy of the GNU General Public License
|
---|
17 | ;;; along with this program; if not, write to the Free Software
|
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
---|
19 | ;;;
|
---|
20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
21 |
|
---|
22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
23 | ;;
|
---|
24 | ;; Load this file into Maxima to bootstrap the Grobner package.
|
---|
25 | ;; NOTE: This file does use symbols defined by Maxima, so it
|
---|
26 | ;; will not work when loaded in Common Lisp.
|
---|
27 | ;;
|
---|
28 | ;; DETAILS: This file implements an interface between the Grobner
|
---|
29 | ;; basis package NGROBNER, which is a pure Common Lisp package, and
|
---|
30 | ;; Maxima. NGROBNER for efficiency uses its own representation of
|
---|
31 | ;; polynomials. Thus, it is necessary to convert Maxima representation
|
---|
32 | ;; to the internal representation and back. The facilities to do so
|
---|
33 | ;; are implemented in this file.
|
---|
34 | ;;
|
---|
35 | ;; Also, since the NGROBNER package consists of many Lisp files, it is
|
---|
36 | ;; necessary to load the files. It is possible and preferrable to use
|
---|
37 | ;; ASDF for this purpose. The default is ASDF. It is also possible to
|
---|
38 | ;; simply used LOAD and COMPILE-FILE to accomplish this task.
|
---|
39 | ;;
|
---|
40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
41 |
|
---|
42 | (in-package :maxima)
|
---|
43 |
|
---|
44 | (macsyma-module cgb-maxima)
|
---|
45 |
|
---|
46 |
|
---|
47 | (eval-when
|
---|
48 | #+gcl (load eval)
|
---|
49 | #-gcl (:load-toplevel :execute)
|
---|
50 | (format t "~&Loading maxima-grobner ~a ~a~%"
|
---|
51 | "$Revision: 2.0 $" "$Date: 2015/06/02 0:34:17 $"))
|
---|
52 |
|
---|
53 | ;;FUNCTS is loaded because it contains the definition of LCM
|
---|
54 | ($load "functs")
|
---|
55 | #+sbcl(progn (require 'asdf) (load "ngrobner.asd")(asdf:load-system :ngrobner))
|
---|
56 |
|
---|
57 | (use-package :ngrobner)
|
---|
58 |
|
---|
59 |
|
---|
60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
61 | ;;
|
---|
62 | ;; Maxima expression ring
|
---|
63 | ;;
|
---|
64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
65 | ;;
|
---|
66 | ;; This is how we perform operations on coefficients
|
---|
67 | ;; using Maxima functions.
|
---|
68 | ;;
|
---|
69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
70 |
|
---|
71 | (defparameter *maxima-ring*
|
---|
72 | (make-ring
|
---|
73 | ;;(defun coeff-zerop (expr) (meval1 `(($is) (($equal) ,expr 0))))
|
---|
74 | :parse #'(lambda (expr)
|
---|
75 | (when modulus (setf expr ($rat expr)))
|
---|
76 | expr)
|
---|
77 | :unit #'(lambda () (if modulus ($rat 1) 1))
|
---|
78 | :zerop #'(lambda (expr)
|
---|
79 | ;;When is exactly a maxima expression equal to 0?
|
---|
80 | (cond ((numberp expr)
|
---|
81 | (= expr 0))
|
---|
82 | ((atom expr) nil)
|
---|
83 | (t
|
---|
84 | (case (caar expr)
|
---|
85 | (mrat (eql ($ratdisrep expr) 0))
|
---|
86 | (otherwise (eql ($totaldisrep expr) 0))))))
|
---|
87 | :add #'(lambda (x y) (m+ x y))
|
---|
88 | :sub #'(lambda (x y) (m- x y))
|
---|
89 | :uminus #'(lambda (x) (m- x))
|
---|
90 | :mul #'(lambda (x y) (m* x y))
|
---|
91 | ;;(defun coeff-div (x y) (cadr ($divide x y)))
|
---|
92 | :div #'(lambda (x y) (m// x y))
|
---|
93 | :lcm #'(lambda (x y) (meval1 `((|$LCM|) ,x ,y)))
|
---|
94 | :ezgcd #'(lambda (x y) (apply #'values (cdr ($ezgcd ($totaldisrep x) ($totaldisrep y)))))
|
---|
95 | ;; :gcd #'(lambda (x y) (second ($ezgcd x y)))))
|
---|
96 | :gcd #'(lambda (x y) ($gcd x y))))
|
---|
97 |
|
---|
98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
99 | ;;
|
---|
100 | ;; Maxima expression parsing
|
---|
101 | ;;
|
---|
102 | ;;
|
---|
103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
104 | ;;
|
---|
105 | ;; Functions and macros dealing with internal representation
|
---|
106 | ;; structure.
|
---|
107 | ;;
|
---|
108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
109 |
|
---|
110 | (defun equal-test-p (expr1 expr2)
|
---|
111 | (alike1 expr1 expr2))
|
---|
112 |
|
---|
113 | (defun coerce-maxima-list (expr)
|
---|
114 | "Convert a Maxima list to Lisp list."
|
---|
115 | (cond
|
---|
116 | ((and (consp (car expr)) (eql (caar expr) 'mlist)) (cdr expr))
|
---|
117 | (t expr)))
|
---|
118 |
|
---|
119 | (defun free-of-vars (expr vars) (apply #'$freeof `(,@vars ,expr)))
|
---|
120 |
|
---|
121 | (defun parse-poly (expr vars &aux (vars (coerce-maxima-list vars)))
|
---|
122 | "Convert a maxima polynomial expression EXPR in variables VARS to internal form."
|
---|
123 | (labels ((parse (arg) (parse-poly arg vars))
|
---|
124 | (parse-list (args) (mapcar #'parse args)))
|
---|
125 | (cond
|
---|
126 | ((eql expr 0) (make-poly-zero))
|
---|
127 | ((member expr vars :test #'equal-test-p)
|
---|
128 | (let ((pos (position expr vars :test #'equal-test-p)))
|
---|
129 | (make-variable *expression-ring* (length vars) pos)))
|
---|
130 | ((free-of-vars expr vars)
|
---|
131 | ;;This means that variable-free CRE and Poisson forms will be converted
|
---|
132 | ;;to coefficients intact
|
---|
133 | (coerce-coeff *expression-ring* expr vars))
|
---|
134 | (t
|
---|
135 | (case (caar expr)
|
---|
136 | (mplus (reduce #'(lambda (x y) (poly-add *expression-ring* x y)) (parse-list (cdr expr))))
|
---|
137 | (mminus (poly-uminus *expression-ring* (parse (cadr expr))))
|
---|
138 | (mtimes
|
---|
139 | (if (endp (cddr expr)) ;unary
|
---|
140 | (parse (cdr expr))
|
---|
141 | (reduce #'(lambda (p q) (poly-mul *expression-ring* p q)) (parse-list (cdr expr)))))
|
---|
142 | (mexpt
|
---|
143 | (cond
|
---|
144 | ((member (cadr expr) vars :test #'equal-test-p)
|
---|
145 | ;;Special handling of (expt var pow)
|
---|
146 | (let ((pos (position (cadr expr) vars :test #'equal-test-p)))
|
---|
147 | (make-variable *expression-ring* (length vars) pos (caddr expr))))
|
---|
148 | ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
|
---|
149 | ;; Negative power means division in coefficient ring
|
---|
150 | ;; Non-integer power means non-polynomial coefficient
|
---|
151 | (mtell "~%Warning: Expression ~%~M~%contains power which is not a positive integer. Parsing as coefficient.~%"
|
---|
152 | expr)
|
---|
153 | (coerce-coeff *expression-ring* expr vars))
|
---|
154 | (t (poly-expt *expression-ring* (parse (cadr expr)) (caddr expr)))))
|
---|
155 | (mrat (parse ($ratdisrep expr)))
|
---|
156 | (mpois (parse ($outofpois expr)))
|
---|
157 | (otherwise
|
---|
158 | (coerce-coeff *expression-ring* expr vars)))))))
|
---|
159 |
|
---|
160 | (defun parse-poly-list (expr vars)
|
---|
161 | "Parse a Maxima representation of a list of polynomials."
|
---|
162 | (case (caar expr)
|
---|
163 | (mlist (mapcar #'(lambda (p) (parse-poly p vars)) (cdr expr)))
|
---|
164 | (t (merror "Expression ~M is not a list of polynomials in variables ~M."
|
---|
165 | expr vars))))
|
---|
166 |
|
---|
167 | (defun parse-poly-list-list (poly-list-list vars)
|
---|
168 | "Parse a Maxima representation of a list of lists of polynomials."
|
---|
169 | (mapcar #'(lambda (g) (parse-poly-list g vars)) (coerce-maxima-list poly-list-list)))
|
---|
170 |
|
---|
171 |
|
---|
172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
173 | ;;
|
---|
174 | ;; Conversion from internal form to Maxima general form
|
---|
175 | ;;
|
---|
176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
177 |
|
---|
178 | (defun maxima-head ()
|
---|
179 | (if $poly_return_term_list
|
---|
180 | '(mlist)
|
---|
181 | '(mplus)))
|
---|
182 |
|
---|
183 | (defun coerce-to-maxima (poly-type object vars)
|
---|
184 | (case poly-type
|
---|
185 | (:polynomial
|
---|
186 | `(,(maxima-head) ,@(mapcar #'(lambda (term) (coerce-to-maxima :term term vars)) (poly-termlist object))))
|
---|
187 | (:poly-list
|
---|
188 | `((mlist) ,@(mapcar #'(lambda (p) (funcall *ratdisrep-fun* (coerce-to-maxima :polynomial p vars))) object)))
|
---|
189 | (:term
|
---|
190 | `((mtimes) ,(funcall *ratdisrep-fun* (term-coeff object))
|
---|
191 | ,@(mapcar #'(lambda (var power) `((mexpt) ,var ,power))
|
---|
192 | vars (coerce (term-monom object) 'list))))
|
---|
193 | ;; Assumes that Lisp and Maxima logicals coincide
|
---|
194 | (:logical object)
|
---|
195 | (otherwise
|
---|
196 | object)))
|
---|
197 |
|
---|
198 |
|
---|
199 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
200 | ;;
|
---|
201 | ;; Unary and binary operation definition facility
|
---|
202 | ;;
|
---|
203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
204 |
|
---|
205 | (defmacro define-unop (maxima-name fun-name
|
---|
206 | &optional (documentation nil documentation-supplied-p))
|
---|
207 | "Define a MAXIMA-level unary operator MAXIMA-NAME corresponding to unary function FUN-NAME."
|
---|
208 | `(defun ,maxima-name (p vars
|
---|
209 | &aux
|
---|
210 | (vars (coerce-maxima-list vars))
|
---|
211 | (p (parse-poly p vars)))
|
---|
212 | ,@(when documentation-supplied-p (list documentation))
|
---|
213 | (coerce-to-maxima :polynomial (,fun-name *expression-ring* p) vars)))
|
---|
214 |
|
---|
215 | (defmacro define-binop (maxima-name fun-name
|
---|
216 | &optional (documentation nil documentation-supplied-p))
|
---|
217 | "Define a MAXIMA-level binary operator MAXIMA-NAME corresponding to binary function FUN-NAME."
|
---|
218 | `(defmfun ,maxima-name (p q vars
|
---|
219 | &aux
|
---|
220 | (vars (coerce-maxima-list vars))
|
---|
221 | (p (parse-poly p vars))
|
---|
222 | (q (parse-poly q vars)))
|
---|
223 | ,@(when documentation-supplied-p (list documentation))
|
---|
224 | (coerce-to-maxima :polynomial (,fun-name *expression-ring* p q) vars)))
|
---|
225 |
|
---|
226 |
|
---|
227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
228 | ;;
|
---|
229 | ;; Order utilities
|
---|
230 | ;;
|
---|
231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
232 |
|
---|
233 | (defun find-order (order)
|
---|
234 | "This function returns the order function bases on its name."
|
---|
235 | (cond
|
---|
236 | ((null order) nil)
|
---|
237 | ((symbolp order)
|
---|
238 | (case order
|
---|
239 | ((lex :lex $lex) #'lex>)
|
---|
240 | ((grlex :grlex $grlex) #'grlex>)
|
---|
241 | ((grevlex :grevlex $grevlex) #'grevlex>)
|
---|
242 | ((invlex :invlex $invlex) #'invlex>)
|
---|
243 | ((elimination-order-1 :elimination-order-1 elimination_order_1) #'elimination-order-1)
|
---|
244 | (otherwise
|
---|
245 | (mtell "~%Warning: Order ~M not found. Using default.~%" order))))
|
---|
246 | (t
|
---|
247 | (mtell "~%Order specification ~M is not recognized. Using default.~%" order)
|
---|
248 | nil)))
|
---|
249 |
|
---|
250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
251 | ;;
|
---|
252 | ;; Ring utilities
|
---|
253 | ;;
|
---|
254 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
255 |
|
---|
256 | (defun find-ring (ring)
|
---|
257 | "This function returns the ring structure bases on input symbol."
|
---|
258 | (cond
|
---|
259 | ((null ring) nil)
|
---|
260 | ((symbolp ring)
|
---|
261 | (case ring
|
---|
262 | ((expression-ring :expression-ring $expression_ring) *expression-ring*)
|
---|
263 | ((ring-of-integers :ring-of-integers $ring_of_integers) *ring-of-integers*)
|
---|
264 | (otherwise
|
---|
265 | (mtell "~%Warning: Ring ~M not found. Using default.~%" ring))))
|
---|
266 | (t
|
---|
267 | (mtell "~%Ring specification ~M is not recognized. Using default.~%" ring)
|
---|
268 | nil)))
|
---|
269 |
|
---|
270 |
|
---|
271 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
272 | ;;
|
---|
273 | ;; Facilities for evaluating Grobner package expressions
|
---|
274 | ;; within a prepared environment
|
---|
275 | ;;
|
---|
276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
277 |
|
---|
278 | (defmacro with-monomial-order ((order) &body body)
|
---|
279 | "Evaluate BODY with monomial order set to ORDER."
|
---|
280 | `(let ((*monomial-order* (or (find-order ,order) *monomial-order*)))
|
---|
281 | . ,body))
|
---|
282 |
|
---|
283 | (defmacro with-coefficient-ring ((ring) &body body)
|
---|
284 | "Evaluate BODY with coefficient ring set to RING."
|
---|
285 | `(let ((*expression-ring* (or (find-ring ,ring) *expression-ring*)))
|
---|
286 | . ,body))
|
---|
287 |
|
---|
288 | (defmacro with-ring-and-order ((ring order) &body body)
|
---|
289 | "Evaluate BODY with monomial order set to ORDER and coefficient ring set to RING."
|
---|
290 | `(let ((*monomial-order* (or (find-order ,order) *monomial-order*))
|
---|
291 | (*expression-ring* (or (find-ring ,ring) *expression-ring*)))
|
---|
292 | . ,body))
|
---|
293 |
|
---|
294 | (defmacro with-elimination-orders ((primary secondary elimination-order)
|
---|
295 | &body body)
|
---|
296 | "Evaluate BODY with primary and secondary elimination orders set to PRIMARY and SECONDARY."
|
---|
297 | `(let ((*primary-elimination-order* (or (find-order ,primary) *primary-elimination-order*))
|
---|
298 | (*secondary-elimination-order* (or (find-order ,secondary) *secondary-elimination-order*))
|
---|
299 | (*elimination-order* (or (find-order ,elimination-order) *elimination-order*)))
|
---|
300 | . ,body))
|
---|
301 |
|
---|
302 |
|
---|
303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
304 | ;;
|
---|
305 | ;; Maxima-level interface functions
|
---|
306 | ;;
|
---|
307 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
308 |
|
---|
309 | ;; Auxillary function for removing zero polynomial
|
---|
310 | (defun remzero (plist) (remove #'poly-zerop plist))
|
---|
311 |
|
---|
312 | ;;Simple operators
|
---|
313 |
|
---|
314 | (define-binop $poly_add poly-add
|
---|
315 | "Adds two polynomials P and Q")
|
---|
316 |
|
---|
317 | (define-binop $poly_subtract poly-sub
|
---|
318 | "Subtracts a polynomial Q from P.")
|
---|
319 |
|
---|
320 | (define-binop $poly_multiply poly-mul
|
---|
321 | "Returns the product of polynomials P and Q.")
|
---|
322 |
|
---|
323 | (define-binop $poly_s_polynomial spoly
|
---|
324 | "Returns the syzygy polynomial (S-polynomial) of two polynomials P and Q.")
|
---|
325 |
|
---|
326 | (define-unop $poly_primitive_part poly-primitive-part
|
---|
327 | "Returns the polynomial P divided by GCD of its coefficients.")
|
---|
328 |
|
---|
329 | (define-unop $poly_normalize poly-normalize
|
---|
330 | "Returns the polynomial P divided by the leading coefficient.")
|
---|
331 |
|
---|
332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
333 | ;;
|
---|
334 | ;; Macro facility for writing Maxima-level wrappers for
|
---|
335 | ;; functions operating on internal representation
|
---|
336 | ;;
|
---|
337 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
338 |
|
---|
339 | (defmacro with-parsed-polynomials (((maxima-vars &optional (maxima-new-vars nil new-vars-supplied-p))
|
---|
340 | &key (polynomials nil)
|
---|
341 | (poly-lists nil)
|
---|
342 | (poly-list-lists nil)
|
---|
343 | (value-type nil))
|
---|
344 | &body body
|
---|
345 | &aux (vars (gensym))
|
---|
346 | (new-vars (gensym)))
|
---|
347 | `(let ((,vars (coerce-maxima-list ,maxima-vars))
|
---|
348 | ,@(when new-vars-supplied-p
|
---|
349 | (list `(,new-vars (coerce-maxima-list ,maxima-new-vars)))))
|
---|
350 | (coerce-to-maxima
|
---|
351 | ,value-type
|
---|
352 | (with-coefficient-ring ($poly_coefficient_ring)
|
---|
353 | (with-monomial-order ($poly_monomial_order)
|
---|
354 | (with-elimination-orders ($poly_primary_elimination_order
|
---|
355 | $poly_secondary_elimination_order
|
---|
356 | $poly_elimination_order)
|
---|
357 | (let ,(let ((args nil))
|
---|
358 | (dolist (p polynomials args)
|
---|
359 | (setf args (cons `(,p (parse-poly ,p ,vars)) args)))
|
---|
360 | (dolist (p poly-lists args)
|
---|
361 | (setf args (cons `(,p (parse-poly-list ,p ,vars)) args)))
|
---|
362 | (dolist (p poly-list-lists args)
|
---|
363 | (setf args (cons `(,p (parse-poly-list-list ,p ,vars)) args))))
|
---|
364 | . ,body))))
|
---|
365 | ,(if new-vars-supplied-p
|
---|
366 | `(append ,vars ,new-vars)
|
---|
367 | vars))))
|
---|
368 |
|
---|
369 |
|
---|
370 | ;;Functions
|
---|
371 |
|
---|
372 | (defmfun $poly_expand (p vars)
|
---|
373 | "This function is equivalent to EXPAND(P) if P parses correctly to a polynomial.
|
---|
374 | If the representation is not compatible with a polynomial in variables VARS,
|
---|
375 | the result is an error."
|
---|
376 | (with-parsed-polynomials ((vars) :polynomials (p)
|
---|
377 | :value-type :polynomial)
|
---|
378 | p))
|
---|
379 |
|
---|
380 | (defmfun $poly_expt (p n vars)
|
---|
381 | (with-parsed-polynomials ((vars) :polynomials (p) :value-type :polynomial)
|
---|
382 | (poly-expt *expression-ring* p n)))
|
---|
383 |
|
---|
384 | (defmfun $poly_content (p vars)
|
---|
385 | (with-parsed-polynomials ((vars) :polynomials (p))
|
---|
386 | (poly-content *expression-ring* p)))
|
---|
387 |
|
---|
388 | (defmfun $poly_pseudo_divide (f fl vars
|
---|
389 | &aux (vars (coerce-maxima-list vars))
|
---|
390 | (f (parse-poly f vars))
|
---|
391 | (fl (parse-poly-list fl vars)))
|
---|
392 | (multiple-value-bind (quot rem c division-count)
|
---|
393 | (poly-pseudo-divide *expression-ring* f fl)
|
---|
394 | `((mlist)
|
---|
395 | ,(coerce-to-maxima :poly-list quot vars)
|
---|
396 | ,(coerce-to-maxima :polynomial rem vars)
|
---|
397 | ,c
|
---|
398 | ,division-count)))
|
---|
399 |
|
---|
400 | (defmfun $poly_exact_divide (f g vars)
|
---|
401 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
402 | (poly-exact-divide *expression-ring* f g)))
|
---|
403 |
|
---|
404 | (defmfun $poly_normal_form (f fl vars)
|
---|
405 | (with-parsed-polynomials ((vars) :polynomials (f)
|
---|
406 | :poly-lists (fl)
|
---|
407 | :value-type :polynomial)
|
---|
408 | (normal-form *expression-ring* f (remzero fl) nil)))
|
---|
409 |
|
---|
410 | (defmfun $poly_buchberger_criterion (g vars)
|
---|
411 | (with-parsed-polynomials ((vars) :poly-lists (g) :value-type :logical)
|
---|
412 | (buchberger-criterion *expression-ring* g)))
|
---|
413 |
|
---|
414 | (defmfun $poly_buchberger (fl vars)
|
---|
415 | (with-parsed-polynomials ((vars) :poly-lists (fl) :value-type :poly-list)
|
---|
416 | (buchberger *expression-ring* (remzero fl) 0 nil)))
|
---|
417 |
|
---|
418 | (defmfun $poly_reduction (plist vars)
|
---|
419 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
420 | :value-type :poly-list)
|
---|
421 | (reduction *expression-ring* plist)))
|
---|
422 |
|
---|
423 | (defmfun $poly_minimization (plist vars)
|
---|
424 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
425 | :value-type :poly-list)
|
---|
426 | (minimization plist)))
|
---|
427 |
|
---|
428 | (defmfun $poly_normalize_list (plist vars)
|
---|
429 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
430 | :value-type :poly-list)
|
---|
431 | (poly-normalize-list *expression-ring* plist)))
|
---|
432 |
|
---|
433 | (defmfun $poly_grobner (f vars)
|
---|
434 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
435 | :value-type :poly-list)
|
---|
436 | (grobner *expression-ring* (remzero f))))
|
---|
437 |
|
---|
438 | (defmfun $poly_reduced_grobner (f vars)
|
---|
439 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
440 | :value-type :poly-list)
|
---|
441 | (reduced-grobner *expression-ring* (remzero f))))
|
---|
442 |
|
---|
443 | (defmfun $poly_depends_p (p var mvars
|
---|
444 | &aux (vars (coerce-maxima-list mvars))
|
---|
445 | (pos (position var vars)))
|
---|
446 | (if (null pos)
|
---|
447 | (merror "~%Variable ~M not in the list of variables ~M." var mvars)
|
---|
448 | (poly-depends-p (parse-poly p vars) pos)))
|
---|
449 |
|
---|
450 | (defmfun $poly_elimination_ideal (flist k vars)
|
---|
451 | (with-parsed-polynomials ((vars) :poly-lists (flist)
|
---|
452 | :value-type :poly-list)
|
---|
453 | (elimination-ideal *expression-ring* flist k nil 0)))
|
---|
454 |
|
---|
455 | (defmfun $poly_colon_ideal (f g vars)
|
---|
456 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
457 | (colon-ideal *expression-ring* f g nil)))
|
---|
458 |
|
---|
459 | (defmfun $poly_ideal_intersection (f g vars)
|
---|
460 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
461 | (ideal-intersection *expression-ring* f g nil)))
|
---|
462 |
|
---|
463 | (defmfun $poly_lcm (f g vars)
|
---|
464 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
465 | (poly-lcm *expression-ring* f g)))
|
---|
466 |
|
---|
467 | (defmfun $poly_gcd (f g vars)
|
---|
468 | ($first ($divide (m* f g) ($poly_lcm f g vars))))
|
---|
469 |
|
---|
470 | (defmfun $poly_grobner_equal (g1 g2 vars)
|
---|
471 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
472 | (grobner-equal *expression-ring* g1 g2)))
|
---|
473 |
|
---|
474 | (defmfun $poly_grobner_subsetp (g1 g2 vars)
|
---|
475 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
476 | (grobner-subsetp *expression-ring* g1 g2)))
|
---|
477 |
|
---|
478 | (defmfun $poly_grobner_member (p g vars)
|
---|
479 | (with-parsed-polynomials ((vars) :polynomials (p) :poly-lists (g))
|
---|
480 | (grobner-member *expression-ring* p g)))
|
---|
481 |
|
---|
482 | (defmfun $poly_ideal_saturation1 (f p vars)
|
---|
483 | (with-parsed-polynomials ((vars) :poly-lists (f) :polynomials (p)
|
---|
484 | :value-type :poly-list)
|
---|
485 | (ideal-saturation-1 *expression-ring* f p 0)))
|
---|
486 |
|
---|
487 | (defmfun $poly_saturation_extension (f plist vars new-vars)
|
---|
488 | (with-parsed-polynomials ((vars new-vars)
|
---|
489 | :poly-lists (f plist)
|
---|
490 | :value-type :poly-list)
|
---|
491 | (saturation-extension *expression-ring* f plist)))
|
---|
492 |
|
---|
493 | (defmfun $poly_polysaturation_extension (f plist vars new-vars)
|
---|
494 | (with-parsed-polynomials ((vars new-vars)
|
---|
495 | :poly-lists (f plist)
|
---|
496 | :value-type :poly-list)
|
---|
497 | (polysaturation-extension *expression-ring* f plist)))
|
---|
498 |
|
---|
499 | (defmfun $poly_ideal_polysaturation1 (f plist vars)
|
---|
500 | (with-parsed-polynomials ((vars) :poly-lists (f plist)
|
---|
501 | :value-type :poly-list)
|
---|
502 | (ideal-polysaturation-1 *expression-ring* f plist 0 nil)))
|
---|
503 |
|
---|
504 | (defmfun $poly_ideal_saturation (f g vars)
|
---|
505 | (with-parsed-polynomials ((vars) :poly-lists (f g)
|
---|
506 | :value-type :poly-list)
|
---|
507 | (ideal-saturation *expression-ring* f g 0 nil)))
|
---|
508 |
|
---|
509 | (defmfun $poly_ideal_polysaturation (f ideal-list vars)
|
---|
510 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
511 | :poly-list-lists (ideal-list)
|
---|
512 | :value-type :poly-list)
|
---|
513 | (ideal-polysaturation *expression-ring* f ideal-list 0 nil)))
|
---|
514 |
|
---|
515 | (defmfun $poly_lt (f vars)
|
---|
516 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
517 | (make-poly-from-termlist (list (poly-lt f)))))
|
---|
518 |
|
---|
519 | (defmfun $poly_lm (f vars)
|
---|
520 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
521 | (make-poly-from-termlist (list (make-term (poly-lm f) (funcall (ring-unit *expression-ring*)))))))
|
---|
522 |
|
---|