1 | ;;; -*- Mode: Lisp -*-
|
---|
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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
122 | ;;
|
---|
123 | ;; Order utilities
|
---|
124 | ;;
|
---|
125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
126 |
|
---|
127 | (defun find-ring-by-name (ring)
|
---|
128 | "This function returns the ring structure bases on input symbol."
|
---|
129 | (cond
|
---|
130 | ((null ring) nil)
|
---|
131 | ((symbolp ring)
|
---|
132 | (case ring
|
---|
133 | ((maxima-ring :maxima-ring #:maxima-ring $expression_ring #:expression_ring)
|
---|
134 | +maxima-ring+)
|
---|
135 | ((ring-of-integers :ring-of-integers #:ring-of-integers $ring_of_integers) +ring-of-integers+)
|
---|
136 | (otherwise
|
---|
137 | (mtell "~%Warning: Ring ~M not found. Using default.~%" ring))))
|
---|
138 | (t
|
---|
139 | (mtell "~%Ring specification ~M is not recognized. Using default.~%" ring)
|
---|
140 | nil)))
|
---|
141 |
|
---|
142 | (defun find-order-by-name (order)
|
---|
143 | "This function returns the order function bases on its name."
|
---|
144 | (cond
|
---|
145 | ((null order) nil)
|
---|
146 | ((symbolp order)
|
---|
147 | (case order
|
---|
148 | ((lex :lex $lex #:lex)
|
---|
149 | #'lex>)
|
---|
150 | ((grlex :grlex $grlex #:grlex)
|
---|
151 | #'grlex>)
|
---|
152 | ((grevlex :grevlex $grevlex #:grevlex)
|
---|
153 | #'grevlex>)
|
---|
154 | ((invlex :invlex $invlex #:invlex)
|
---|
155 | #'invlex>)
|
---|
156 | (otherwise
|
---|
157 | (mtell "~%Warning: Order ~M not found. Using default.~%" order))))
|
---|
158 | (t
|
---|
159 | (mtell "~%Order specification ~M is not recognized. Using default.~%" order)
|
---|
160 | nil)))
|
---|
161 |
|
---|
162 | (defun find-ring-and-order-by-name (&optional
|
---|
163 | (ring (find-ring-by-name $poly_coefficient_ring))
|
---|
164 | (order (find-order-by-name $poly_monomial_order))
|
---|
165 | (primary-elimination-order (find-order-by-name $poly_primary_elimination_order))
|
---|
166 | (secondary-elimination-order (find-order-by-name $poly_secondary_elimination_order))
|
---|
167 | &aux
|
---|
168 | (ring-and-order (make-ring-and-order
|
---|
169 | :ring ring
|
---|
170 | :order order
|
---|
171 | :primary-elimination-order primary-elimination-order
|
---|
172 | :secondary-elimination-order secondary-elimination-order)))
|
---|
173 | "Build RING-AND-ORDER structure. The defaults are determined by various Maxima-level switches,
|
---|
174 | which are names of ring and orders."
|
---|
175 | ring-and-order)
|
---|
176 |
|
---|
177 | (defun maxima->poly (expr vars
|
---|
178 | &optional
|
---|
179 | (ring-and-order (find-ring-and-order-by-name))
|
---|
180 | &aux
|
---|
181 | (vars (coerce-maxima-list vars))
|
---|
182 | (ring (ro-ring ring-and-order)))
|
---|
183 | "Convert a maxima polynomial expression EXPR in variables VARS to
|
---|
184 | internal form. This works by first converting the expression to Lisp,
|
---|
185 | and then evaluating the expression using polynomial arithmetic
|
---|
186 | implemented by the POLYNOMIAL package."
|
---|
187 | (labels ((parse (arg) (maxima->poly arg vars ring-and-order))
|
---|
188 | (parse-list (args) (mapcar #'parse args)))
|
---|
189 | (cond
|
---|
190 | ((eql expr 0) (make-poly-zero))
|
---|
191 | ((member expr vars :test #'equal-test-p)
|
---|
192 | (let ((pos (position expr vars :test #'equal-test-p)))
|
---|
193 | (make-poly-variable ring (length vars) pos)))
|
---|
194 | ((free-of-vars expr vars)
|
---|
195 | ;;This means that variable-free CRE and Poisson forms will be converted
|
---|
196 | ;;to coefficients intact
|
---|
197 | (coerce-coeff ring expr vars))
|
---|
198 | (t
|
---|
199 | (case (caar expr)
|
---|
200 | (mplus (reduce #'(lambda (x y) (poly-add ring-and-order x y)) (parse-list (cdr expr))))
|
---|
201 | (mminus (poly-uminus ring (parse (cadr expr))))
|
---|
202 | (mtimes
|
---|
203 | (if (endp (cddr expr)) ;unary
|
---|
204 | (parse (cdr expr))
|
---|
205 | (reduce #'(lambda (p q) (poly-mul ring-and-order p q)) (parse-list (cdr expr)))))
|
---|
206 | (mexpt
|
---|
207 | (cond
|
---|
208 | ((member (cadr expr) vars :test #'equal-test-p)
|
---|
209 | ;;Special handling of (expt var pow)
|
---|
210 | (let ((pos (position (cadr expr) vars :test #'equal-test-p)))
|
---|
211 | (make-poly-variable ring (length vars) pos (caddr expr))))
|
---|
212 | ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
|
---|
213 | ;; Negative power means division in coefficient ring
|
---|
214 | ;; Non-integer power means non-polynomial coefficient
|
---|
215 | (mtell "~%Warning: Expression ~%~M~%contains power which is not a positive integer. Parsing as coefficient.~%"
|
---|
216 | expr)
|
---|
217 | (coerce-coeff ring expr vars))
|
---|
218 | (t (poly-expt ring-and-order (parse (cadr expr)) (caddr expr)))))
|
---|
219 | (mrat (parse ($ratdisrep expr)))
|
---|
220 | (mpois (parse ($outofpois expr)))
|
---|
221 | (otherwise
|
---|
222 | (coerce-coeff ring expr vars)))))))
|
---|
223 |
|
---|
224 | (defun maxima->poly-list (expr vars
|
---|
225 | &optional
|
---|
226 | (ring-and-order (find-ring-and-order-by-name)))
|
---|
227 | "Convert a Maxima representation of a list of polynomials to the internal form."
|
---|
228 | (case (caar expr)
|
---|
229 | (mlist (mapcar #'(lambda (p)
|
---|
230 | (maxima->poly p vars ring-and-order))
|
---|
231 | (cdr expr)))
|
---|
232 | (otherwise (merror "Expression ~M is not a list of polynomials in variables ~M."
|
---|
233 | expr vars))))
|
---|
234 |
|
---|
235 | (defun maxima->poly-list-list (poly-list-of-lists vars
|
---|
236 | &optional
|
---|
237 | (ring-and-order (find-ring-and-order-by-name)))
|
---|
238 | "Parse a Maxima representation of a list of lists of polynomials."
|
---|
239 | (mapcar #'(lambda (g) (maxima->poly-list g vars ring-and-order))
|
---|
240 | (coerce-maxima-list poly-list-of-lists)))
|
---|
241 |
|
---|
242 |
|
---|
243 |
|
---|
244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
245 | ;;
|
---|
246 | ;; Conversion from internal form to Maxima general form
|
---|
247 | ;;
|
---|
248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
249 |
|
---|
250 | (defun maxima-head ()
|
---|
251 | (if $poly_return_term_list
|
---|
252 | '(mlist)
|
---|
253 | '(mplus)))
|
---|
254 |
|
---|
255 | (defun poly->maxima (poly-type object vars)
|
---|
256 | (case poly-type
|
---|
257 | (:custom object) ;Bypass processing
|
---|
258 | (:polynomial
|
---|
259 | `(,(maxima-head) ,@(mapcar #'(lambda (term) (poly->maxima :term term vars)) (poly-termlist object))))
|
---|
260 | (:poly-list
|
---|
261 | `((mlist) ,@(mapcar #'(lambda (p) ($ratdisrep (poly->maxima :polynomial p vars))) object)))
|
---|
262 | (:term
|
---|
263 | `((mtimes) ,($ratdisrep (term-coeff object))
|
---|
264 | ,@(mapcar #'(lambda (var power) `((mexpt) ,var ,power))
|
---|
265 | vars (monom->list (term-monom object)))))
|
---|
266 | ;; Assumes that Lisp and Maxima logicals coincide
|
---|
267 | (:logical object)
|
---|
268 | (otherwise
|
---|
269 | object)))
|
---|
270 |
|
---|
271 |
|
---|
272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
273 | ;;
|
---|
274 | ;; Facilities for evaluating Grobner package expressions
|
---|
275 | ;; within a prepared environment
|
---|
276 | ;;
|
---|
277 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
278 |
|
---|
279 | #|
|
---|
280 | (defmacro with-monomial-order ((order) &body body)
|
---|
281 | "Evaluate BODY with monomial order set to ORDER."
|
---|
282 | `(let ((*monomial-order* (or (find-order ,order) *monomial-order*)))
|
---|
283 | . ,body))
|
---|
284 |
|
---|
285 | (defmacro with-coefficient-ring ((ring) &body body)
|
---|
286 | "Evaluate BODY with coefficient ring set to RING."
|
---|
287 | `(let ((+maxima-ring+ (or (find-ring ,ring) +maxima-ring+)))
|
---|
288 | . ,body))
|
---|
289 |
|
---|
290 | (defmacro with-ring-and-order ((ring order) &body body)
|
---|
291 | "Evaluate BODY with monomial order set to ORDER and coefficient ring set to RING."
|
---|
292 | `(let ((*monomial-order* (or (find-order ,order) *monomial-order*))
|
---|
293 | (+maxima-ring+ (or (find-ring ,ring) +maxima-ring+)))
|
---|
294 | . ,body))
|
---|
295 |
|
---|
296 | (defmacro with-elimination-orders ((primary secondary elimination-order)
|
---|
297 | &body body)
|
---|
298 | "Evaluate BODY with primary and secondary elimination orders set to PRIMARY and SECONDARY."
|
---|
299 | `(let ((*primary-elimination-order* (or (find-order ,primary) *primary-elimination-order*))
|
---|
300 | (*secondary-elimination-order* (or (find-order ,secondary) *secondary-elimination-order*))
|
---|
301 | (*elimination-order* (or (find-order ,elimination-order) *elimination-order*)))
|
---|
302 | . ,body))
|
---|
303 |
|
---|
304 | |#
|
---|
305 |
|
---|
306 |
|
---|
307 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
308 | ;;
|
---|
309 | ;; Maxima-level interface functions
|
---|
310 | ;;
|
---|
311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
312 |
|
---|
313 | ;; Auxillary function for removing zero polynomial
|
---|
314 | (defun remzero (plist) (remove #'poly-zerop plist))
|
---|
315 |
|
---|
316 | ;;Simple operators
|
---|
317 |
|
---|
318 | #|
|
---|
319 | (define-binop $poly_add poly-add
|
---|
320 | "Adds two polynomials P and Q")
|
---|
321 |
|
---|
322 | (define-binop $poly_subtract poly-sub
|
---|
323 | "Subtracts a polynomial Q from P.")
|
---|
324 |
|
---|
325 | (define-binop $poly_multiply poly-mul
|
---|
326 | "Returns the product of polynomials P and Q.")
|
---|
327 |
|
---|
328 | (define-binop $poly_s_polynomial spoly
|
---|
329 | "Returns the syzygy polynomial (S-polynomial) of two polynomials P and Q.")
|
---|
330 |
|
---|
331 | (define-unop $poly_primitive_part poly-primitive-part
|
---|
332 | "Returns the polynomial P divided by GCD of its coefficients.")
|
---|
333 |
|
---|
334 | (define-unop $poly_normalize poly-normalize
|
---|
335 | "Returns the polynomial P divided by the leading coefficient.")
|
---|
336 | |#
|
---|
337 |
|
---|
338 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
339 | ;;
|
---|
340 | ;; Macro facility for writing Maxima-level wrappers for
|
---|
341 | ;; functions operating on internal representation
|
---|
342 | ;;
|
---|
343 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
344 |
|
---|
345 | (defmacro with-ring-and-order (((maxima-vars &optional (maxima-new-vars nil new-vars-supplied-p))
|
---|
346 | &key
|
---|
347 | (polynomials nil)
|
---|
348 | (poly-lists nil)
|
---|
349 | (poly-list-lists nil)
|
---|
350 | (value-type nil)
|
---|
351 | (ring-and-order-var 'ring-and-order)
|
---|
352 | (ring-var 'ring))
|
---|
353 | &body
|
---|
354 | body
|
---|
355 | &aux
|
---|
356 | (vars (gensym))
|
---|
357 | (new-vars (gensym)))
|
---|
358 | "Evaluate a polynomial expression BODY in an environment
|
---|
359 | constructred from Maxima switches. The supplied arguments
|
---|
360 | POLYNOMIALS, POLY-LISTS and POLY-LIST-LISTS should be polynomials,
|
---|
361 | polynomial lists an lists of lists of polynomials, in Maxima general
|
---|
362 | form. These are translated to NGROBNER package internal form and
|
---|
363 | evaluated using operations in the NGROBNER package. The BODY should be
|
---|
364 | defined in terms of those operations. MAXIMA-VARS is set to the list
|
---|
365 | of variable names used at the Maxima level. The evaluation is
|
---|
366 | performed by the NGROBNER package which ignores variable names, thus
|
---|
367 | MAXIMA-VARS is used only to translate the polynomial expression to
|
---|
368 | NGROBNER internal form. After evaluation, the value of BODY is
|
---|
369 | translated back to the Maxima general form. When MAXIMA-NEW-VARS is
|
---|
370 | present, it is appended to MAXIMA-VARS upon translation from the
|
---|
371 | internal form back to Maxima general form, thus allowing extra
|
---|
372 | variables which may have been created by the evaluation process. The
|
---|
373 | value type can be either :POLYNOMIAL, :POLY-LIST or :TERM, depending
|
---|
374 | on the form of the result returned by the top NGROBNER operation.
|
---|
375 | During evaluation, symbols supplied by RING-AND-ORDER-VAR (defaul
|
---|
376 | value 'RING-AND-ORDER), and RING-VAR (default value 'RING) are bound
|
---|
377 | to RING-AND-ORDER and RING instances."
|
---|
378 | `(let ((,vars (coerce-maxima-list ,maxima-vars))
|
---|
379 | ,@(when new-vars-supplied-p
|
---|
380 | (list `(,new-vars (coerce-maxima-list ,maxima-new-vars)))))
|
---|
381 | (poly->maxima
|
---|
382 | ,value-type
|
---|
383 | (let ((,ring-and-order-var ,(find-ring-and-order-by-name)))
|
---|
384 | ;; Define a shorthand to RING
|
---|
385 | (symbol-macrolet ((,ring-var (ro-ring ring-and-order)))
|
---|
386 | (let ,(let ((args nil))
|
---|
387 | (dolist (p polynomials args)
|
---|
388 | (setf args (cons `(,p (maxima->poly ,p ,vars ,ring-and-order-var)) args)))
|
---|
389 | (dolist (p poly-lists args)
|
---|
390 | (setf args (cons `(,p (maxima->poly-list ,p ,vars ,ring-and-order-var)) args)))
|
---|
391 | (dolist (p poly-list-lists args)
|
---|
392 | (setf args (cons `(,p (maxima->poly-list-list ,p ,vars ,ring-and-order-var)) args))))
|
---|
393 | . ,body)))
|
---|
394 | ,(if new-vars-supplied-p
|
---|
395 | `(append ,vars ,new-vars)
|
---|
396 | vars))))
|
---|
397 |
|
---|
398 |
|
---|
399 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
400 | ;;
|
---|
401 | ;; Unary and binary operation definition facility
|
---|
402 | ;;
|
---|
403 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
404 |
|
---|
405 | (defmacro define-unop (maxima-name fun-name
|
---|
406 | &optional (documentation nil documentation-supplied-p))
|
---|
407 | "Define a MAXIMA-level unary operator MAXIMA-NAME corresponding to unary function FUN-NAME."
|
---|
408 | `(defun ,maxima-name (p vars)
|
---|
409 | ,@(when documentation-supplied-p (list documentation))
|
---|
410 | (with-ring-and-order ((vars) :polynomials (p) :value-type :polynomial)
|
---|
411 | (,fun-name ring p) vars)))
|
---|
412 |
|
---|
413 | (defmacro define-binop (maxima-name fun-name
|
---|
414 | &optional (documentation nil documentation-supplied-p))
|
---|
415 | "Define a MAXIMA-level binary operator MAXIMA-NAME corresponding to binary function FUN-NAME."
|
---|
416 | `(defun ,maxima-name (p vars)
|
---|
417 | ,@(when documentation-supplied-p (list documentation))
|
---|
418 | (with-ring-and-order ((vars) :polynomials (p q) :value-type :polynomial)
|
---|
419 | (,fun-name ring p q) vars)))
|
---|
420 |
|
---|
421 |
|
---|
422 |
|
---|
423 | ;;Functions
|
---|
424 |
|
---|
425 | (defmfun $poly_expand (p vars)
|
---|
426 | "This function is equivalent to EXPAND(P) if P parses correctly to a polynomial.
|
---|
427 | If the representation is not compatible with a polynomial in variables VARS,
|
---|
428 | the result is an error."
|
---|
429 | (with-ring-and-order ((vars) :polynomials (p) :value-type :polynomial) p))
|
---|
430 |
|
---|
431 |
|
---|
432 | (defmfun $poly_expt (p n vars)
|
---|
433 | (with-ring-and-order ((vars) :polynomials (p) :value-type :polynomial)
|
---|
434 | (poly-expt ring-and-order p n)))
|
---|
435 |
|
---|
436 | (defmfun $poly_content (p vars)
|
---|
437 | (with-ring-and-order ((vars) :polynomials (p))
|
---|
438 | (poly-content ring p)))
|
---|
439 |
|
---|
440 | #|
|
---|
441 | (defmfun $poly_pseudo_divide (f fl vars)
|
---|
442 | (with-ring-and-order ((vars)
|
---|
443 | :polynomials (f)
|
---|
444 | :poly-lists (fl)
|
---|
445 | :value-type :custom)
|
---|
446 | (multiple-value-bind (quot rem c division-count)
|
---|
447 | (poly-pseudo-divide ring-and-order f fl)
|
---|
448 | `((mlist)
|
---|
449 | ,(poly->maxima :poly-list quot vars)
|
---|
450 | ,(poly->maxima :polynomial rem vars)
|
---|
451 | ,c
|
---|
452 | ,division-count))))
|
---|
453 | |#
|
---|
454 |
|
---|
455 |
|
---|
456 | (defmfun $poly_exact_divide (f g vars)
|
---|
457 | (with-ring-and-order ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
458 | (poly-exact-divide ring-and-order f g)))
|
---|
459 |
|
---|
460 | (defmfun $poly_normal_form (f fl vars)
|
---|
461 | (with-ring-and-order ((vars) :polynomials (f)
|
---|
462 | :poly-lists (fl)
|
---|
463 | :value-type :polynomial)
|
---|
464 | (normal-form ring-and-order f (remzero fl) nil)))
|
---|
465 |
|
---|
466 | (defmfun $poly_buchberger_criterion (g vars)
|
---|
467 | (with-ring-and-order ((vars) :poly-lists (g) :value-type :logical)
|
---|
468 | (buchberger-criterion ring-and-order g)))
|
---|
469 |
|
---|
470 | (defmfun $poly_buchberger (fl vars)
|
---|
471 | (with-ring-and-order ((vars) :poly-lists (fl) :value-type :poly-list)
|
---|
472 | (buchberger ring-and-order (remzero fl) 0 nil)))
|
---|
473 |
|
---|
474 | (defmfun $poly_reduction (plist vars)
|
---|
475 | (with-ring-and-order ((vars) :poly-lists (plist)
|
---|
476 | :value-type :poly-list)
|
---|
477 | (reduction ring-and-order plist)))
|
---|
478 |
|
---|
479 | (defmfun $poly_minimization (plist vars)
|
---|
480 | (with-ring-and-order ((vars) :poly-lists (plist)
|
---|
481 | :value-type :poly-list)
|
---|
482 | (minimization plist)))
|
---|
483 |
|
---|
484 | (defmfun $poly_normalize_list (plist vars)
|
---|
485 | (with-ring-and-order ((vars) :poly-lists (plist)
|
---|
486 | :value-type :poly-list)
|
---|
487 | (poly-normalize-list ring plist)))
|
---|
488 |
|
---|
489 | (defmfun $poly_grobner (f vars)
|
---|
490 | (with-ring-and-order ((vars) :poly-lists (f)
|
---|
491 | :value-type :poly-list)
|
---|
492 | (grobner ring-and-order (remzero f))))
|
---|
493 |
|
---|
494 | (defmfun $poly_reduced_grobner (f vars)
|
---|
495 | (with-ring-and-order ((vars) :poly-lists (f)
|
---|
496 | :value-type :poly-list)
|
---|
497 | (reduced-grobner ring-and-order (remzero f))))
|
---|
498 |
|
---|
499 | (defmfun $poly_depends_p (p var mvars
|
---|
500 | &aux
|
---|
501 | (vars (coerce-maxima-list mvars))
|
---|
502 | (pos (position var vars)))
|
---|
503 | (with-ring-and-order ((mvars) :polynomials (p) :value-type :custom)
|
---|
504 | (if (null pos)
|
---|
505 | (merror "~%Variable ~M not in the list of variables ~M." var mvars)
|
---|
506 | (poly-depends-p p pos))))
|
---|
507 |
|
---|
508 | (defmfun $poly_elimination_ideal (flist k vars)
|
---|
509 | (with-ring-and-order ((vars) :poly-lists (flist)
|
---|
510 | :value-type :poly-list)
|
---|
511 | (elimination-ideal ring-and-order flist k nil 0)))
|
---|
512 |
|
---|
513 | (defmfun $poly_colon_ideal (f g vars)
|
---|
514 | (with-ring-and-order ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
515 | (colon-ideal ring-and-order f g nil)))
|
---|
516 |
|
---|
517 | (defmfun $poly_ideal_intersection (f g vars)
|
---|
518 | (with-ring-and-order ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
519 | (ideal-intersection ring-and-order f g nil)))
|
---|
520 |
|
---|
521 | (defmfun $poly_lcm (f g vars)
|
---|
522 | (with-ring-and-order ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
523 | (poly-lcm ring-and-order f g)))
|
---|
524 |
|
---|
525 | (defmfun $poly_gcd (f g vars)
|
---|
526 | ($first ($divide (m* f g) ($poly_lcm f g vars))))
|
---|
527 |
|
---|
528 | (defmfun $poly_grobner_equal (g1 g2 vars)
|
---|
529 | (with-ring-and-order ((vars) :poly-lists (g1 g2))
|
---|
530 | (grobner-equal ring-and-order g1 g2)))
|
---|
531 |
|
---|
532 | (defmfun $poly_grobner_subsetp (g1 g2 vars)
|
---|
533 | (with-ring-and-order ((vars) :poly-lists (g1 g2))
|
---|
534 | (grobner-subsetp ring-and-order g1 g2)))
|
---|
535 |
|
---|
536 | (defmfun $poly_grobner_member (p g vars)
|
---|
537 | (with-ring-and-order ((vars) :polynomials (p) :poly-lists (g))
|
---|
538 | (grobner-member ring-and-order p g)))
|
---|
539 |
|
---|
540 | (defmfun $poly_ideal_saturation1 (f p vars)
|
---|
541 | (with-ring-and-order ((vars) :poly-lists (f) :polynomials (p)
|
---|
542 | :value-type :poly-list)
|
---|
543 | (ideal-saturation-1 ring-and-order f p 0)))
|
---|
544 |
|
---|
545 | (defmfun $poly_saturation_extension (f plist vars new-vars)
|
---|
546 | (with-ring-and-order ((vars new-vars)
|
---|
547 | :poly-lists (f plist)
|
---|
548 | :value-type :poly-list)
|
---|
549 | (saturation-extension ring f plist)))
|
---|
550 |
|
---|
551 | (defmfun $poly_polysaturation_extension (f plist vars new-vars)
|
---|
552 | (with-ring-and-order ((vars new-vars)
|
---|
553 | :poly-lists (f plist)
|
---|
554 | :value-type :poly-list)
|
---|
555 | (polysaturation-extension ring f plist)))
|
---|
556 |
|
---|
557 | (defmfun $poly_ideal_polysaturation1 (f plist vars)
|
---|
558 | (with-ring-and-order ((vars) :poly-lists (f plist)
|
---|
559 | :value-type :poly-list)
|
---|
560 | (ideal-polysaturation-1 ring-and-order f plist 0 nil)))
|
---|
561 |
|
---|
562 | (defmfun $poly_ideal_saturation (f g vars)
|
---|
563 | (with-ring-and-order ((vars) :poly-lists (f g)
|
---|
564 | :value-type :poly-list)
|
---|
565 | (ideal-saturation ring-and-order f g 0 nil)))
|
---|
566 |
|
---|
567 | (defmfun $poly_ideal_polysaturation (f ideal-list vars)
|
---|
568 | (with-ring-and-order ((vars) :poly-lists (f)
|
---|
569 | :poly-list-lists (ideal-list)
|
---|
570 | :value-type :poly-list)
|
---|
571 | (ideal-polysaturation ring-and-order f ideal-list 0 nil)))
|
---|
572 |
|
---|
573 | (defmfun $poly_lt (f vars)
|
---|
574 | (with-ring-and-order ((vars) :polynomials (f) :value-type :polynomial)
|
---|
575 | (make-poly-from-termlist (list (poly-lt f)))))
|
---|
576 |
|
---|
577 | (defmfun $poly_lm (f vars)
|
---|
578 | (with-ring-and-order ((vars) :polynomials (f) :value-type :polynomial)
|
---|
579 | (make-poly-from-termlist (list (make-term (poly-lm f) (funcall (ring-unit ring)))))))
|
---|