1 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
|
---|
2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
3 | ;;;
|
---|
4 | ;;; Copyright (C) 1999, 2002, 2009 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 | (in-package :maxima)
|
---|
23 |
|
---|
24 | (macsyma-module cgb-maxima)
|
---|
25 |
|
---|
26 | (eval-when
|
---|
27 | #+gcl (load eval)
|
---|
28 | #-gcl (:load-toplevel :execute)
|
---|
29 | (format t "~&Loading maxima-grobner ~a ~a~%"
|
---|
30 | "$Revision: 2.0 $" "$Date: 2015/06/02 0:34:17 $"))
|
---|
31 |
|
---|
32 | ;;FUNCTS is loaded because it contains the definition of LCM
|
---|
33 | ($load "functs")
|
---|
34 |
|
---|
35 |
|
---|
36 |
|
---|
37 |
|
---|
38 | |
---|
39 |
|
---|
40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
41 | ;;
|
---|
42 | ;; Global switches
|
---|
43 | ;; (Can be used in Maxima just fine)
|
---|
44 | ;;
|
---|
45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
46 |
|
---|
47 | (defmvar $poly_monomial_order '$lex
|
---|
48 | "This switch controls which monomial order is used in polynomial
|
---|
49 | and Grobner basis calculations. If not set, LEX will be used")
|
---|
50 |
|
---|
51 | (defmvar $poly_coefficient_ring '$expression_ring
|
---|
52 | "This switch indicates the coefficient ring of the polynomials
|
---|
53 | that will be used in grobner calculations. If not set, Maxima's
|
---|
54 | general expression ring will be used. This variable may be set
|
---|
55 | to RING_OF_INTEGERS if desired.")
|
---|
56 |
|
---|
57 | (defmvar $poly_primary_elimination_order nil
|
---|
58 | "Name of the default order for eliminated variables in elimination-based functions.
|
---|
59 | If not set, LEX will be used.")
|
---|
60 |
|
---|
61 | (defmvar $poly_secondary_elimination_order nil
|
---|
62 | "Name of the default order for kept variables in elimination-based functions.
|
---|
63 | If not set, LEX will be used.")
|
---|
64 |
|
---|
65 | (defmvar $poly_elimination_order nil
|
---|
66 | "Name of the default elimination order used in elimination calculations.
|
---|
67 | If set, it overrides the settings in variables POLY_PRIMARY_ELIMINATION_ORDER
|
---|
68 | and SECONDARY_ELIMINATION_ORDER. The user must ensure that this is a true
|
---|
69 | elimination order valid for the number of eliminated variables.")
|
---|
70 |
|
---|
71 | (defmvar $poly_return_term_list nil
|
---|
72 | "If set to T, all functions in this package will return each polynomial as a
|
---|
73 | list of terms in the current monomial order rather than a Maxima general expression.")
|
---|
74 |
|
---|
75 | (defmvar $poly_grobner_debug nil
|
---|
76 | "If set to TRUE, produce debugging and tracing output.")
|
---|
77 |
|
---|
78 | (defmvar $poly_grobner_algorithm '$buchberger
|
---|
79 | "The name of the algorithm used to find grobner bases.")
|
---|
80 |
|
---|
81 | (defmvar $poly_top_reduction_only nil
|
---|
82 | "If not FALSE, use top reduction only whenever possible.
|
---|
83 | Top reduction means that division algorithm stops after the first reduction.")
|
---|
84 |
|
---|
85 | |
---|
86 |
|
---|
87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
88 | ;;
|
---|
89 | ;; Coefficient ring operations
|
---|
90 | ;;
|
---|
91 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
92 | ;;
|
---|
93 | ;; These are ALL operations that are performed on the coefficients by
|
---|
94 | ;; the package, and thus the coefficient ring can be changed by merely
|
---|
95 | ;; redefining these operations.
|
---|
96 | ;;
|
---|
97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
98 |
|
---|
99 | (defstruct (ring)
|
---|
100 | (parse #'identity :type function)
|
---|
101 | (unit #'identity :type function)
|
---|
102 | (zerop #'identity :type function)
|
---|
103 | (add #'identity :type function)
|
---|
104 | (sub #'identity :type function)
|
---|
105 | (uminus #'identity :type function)
|
---|
106 | (mul #'identity :type function)
|
---|
107 | (div #'identity :type function)
|
---|
108 | (lcm #'identity :type function)
|
---|
109 | (ezgcd #'identity :type function)
|
---|
110 | (gcd #'identity :type function))
|
---|
111 |
|
---|
112 | (defparameter *ring-of-integers*
|
---|
113 | (make-ring
|
---|
114 | :parse #'identity
|
---|
115 | :unit #'(lambda () 1)
|
---|
116 | :zerop #'zerop
|
---|
117 | :add #'+
|
---|
118 | :sub #'-
|
---|
119 | :uminus #'-
|
---|
120 | :mul #'*
|
---|
121 | :div #'/
|
---|
122 | :lcm #'lcm
|
---|
123 | :ezgcd #'(lambda (x y &aux (c (gcd x y))) (values c (/ x c) (/ y c)))
|
---|
124 | :gcd #'gcd)
|
---|
125 | "The ring of integers.")
|
---|
126 |
|
---|
127 | |
---|
128 |
|
---|
129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
130 | ;;
|
---|
131 | ;; This is how we perform operations on coefficients
|
---|
132 | ;; using Maxima functions.
|
---|
133 | ;;
|
---|
134 | ;; Functions and macros dealing with internal representation structure
|
---|
135 | ;;
|
---|
136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
137 |
|
---|
138 |
|
---|
139 | |
---|
140 |
|
---|
141 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
142 | ;;
|
---|
143 | ;; Low-level polynomial arithmetic done on
|
---|
144 | ;; lists of terms
|
---|
145 | ;;
|
---|
146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
147 |
|
---|
148 | (defmacro termlist-lt (p) `(car ,p))
|
---|
149 | (defun termlist-lm (p) (term-monom (termlist-lt p)))
|
---|
150 | (defun termlist-lc (p) (term-coeff (termlist-lt p)))
|
---|
151 |
|
---|
152 | (define-modify-macro scalar-mul (c) coeff-mul)
|
---|
153 |
|
---|
154 | (defun scalar-times-termlist (ring c p)
|
---|
155 | "Multiply scalar C by a polynomial P. This function works
|
---|
156 | even if there are divisors of 0."
|
---|
157 | (mapcan
|
---|
158 | #'(lambda (term)
|
---|
159 | (let ((c1 (funcall (ring-mul ring) c (term-coeff term))))
|
---|
160 | (unless (funcall (ring-zerop ring) c1)
|
---|
161 | (list (make-term (term-monom term) c1)))))
|
---|
162 | p))
|
---|
163 |
|
---|
164 |
|
---|
165 | (defun term-mul (ring term1 term2)
|
---|
166 | "Returns (LIST TERM) wheter TERM is the product of the terms TERM1 TERM2,
|
---|
167 | or NIL when the product is 0. This definition takes care of divisors of 0
|
---|
168 | in the coefficient ring."
|
---|
169 | (let ((c (funcall (ring-mul ring) (term-coeff term1) (term-coeff term2))))
|
---|
170 | (unless (funcall (ring-zerop ring) c)
|
---|
171 | (list (make-term (monom-mul (term-monom term1) (term-monom term2)) c)))))
|
---|
172 |
|
---|
173 | (defun term-times-termlist (ring term f)
|
---|
174 | (declare (type ring ring))
|
---|
175 | (mapcan #'(lambda (term-f) (term-mul ring term term-f)) f))
|
---|
176 |
|
---|
177 | (defun termlist-times-term (ring f term)
|
---|
178 | (mapcan #'(lambda (term-f) (term-mul ring term-f term)) f))
|
---|
179 |
|
---|
180 | (defun monom-times-term (m term)
|
---|
181 | (make-term (monom-mul m (term-monom term)) (term-coeff term)))
|
---|
182 |
|
---|
183 | (defun monom-times-termlist (m f)
|
---|
184 | (cond
|
---|
185 | ((null f) nil)
|
---|
186 | (t
|
---|
187 | (mapcar #'(lambda (x) (monom-times-term m x)) f))))
|
---|
188 |
|
---|
189 | (defun termlist-uminus (ring f)
|
---|
190 | (mapcar #'(lambda (x)
|
---|
191 | (make-term (term-monom x) (funcall (ring-uminus ring) (term-coeff x))))
|
---|
192 | f))
|
---|
193 |
|
---|
194 | (defun termlist-add (ring p q)
|
---|
195 | (declare (type list p q))
|
---|
196 | (do (r)
|
---|
197 | ((cond
|
---|
198 | ((endp p)
|
---|
199 | (setf r (revappend r q)) t)
|
---|
200 | ((endp q)
|
---|
201 | (setf r (revappend r p)) t)
|
---|
202 | (t
|
---|
203 | (multiple-value-bind
|
---|
204 | (lm-greater lm-equal)
|
---|
205 | (monomial-order (termlist-lm p) (termlist-lm q))
|
---|
206 | (cond
|
---|
207 | (lm-equal
|
---|
208 | (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
|
---|
209 | (unless (funcall (ring-zerop ring) s) ;check for cancellation
|
---|
210 | (setf r (cons (make-term (termlist-lm p) s) r)))
|
---|
211 | (setf p (cdr p) q (cdr q))))
|
---|
212 | (lm-greater
|
---|
213 | (setf r (cons (car p) r)
|
---|
214 | p (cdr p)))
|
---|
215 | (t (setf r (cons (car q) r)
|
---|
216 | q (cdr q)))))
|
---|
217 | nil))
|
---|
218 | r)))
|
---|
219 |
|
---|
220 | (defun termlist-sub (ring p q)
|
---|
221 | (declare (type list p q))
|
---|
222 | (do (r)
|
---|
223 | ((cond
|
---|
224 | ((endp p)
|
---|
225 | (setf r (revappend r (termlist-uminus ring q)))
|
---|
226 | t)
|
---|
227 | ((endp q)
|
---|
228 | (setf r (revappend r p))
|
---|
229 | t)
|
---|
230 | (t
|
---|
231 | (multiple-value-bind
|
---|
232 | (mgreater mequal)
|
---|
233 | (monomial-order (termlist-lm p) (termlist-lm q))
|
---|
234 | (cond
|
---|
235 | (mequal
|
---|
236 | (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
|
---|
237 | (unless (funcall (ring-zerop ring) s) ;check for cancellation
|
---|
238 | (setf r (cons (make-term (termlist-lm p) s) r)))
|
---|
239 | (setf p (cdr p) q (cdr q))))
|
---|
240 | (mgreater
|
---|
241 | (setf r (cons (car p) r)
|
---|
242 | p (cdr p)))
|
---|
243 | (t (setf r (cons (make-term (termlist-lm q) (funcall (ring-uminus ring) (termlist-lc q))) r)
|
---|
244 | q (cdr q)))))
|
---|
245 | nil))
|
---|
246 | r)))
|
---|
247 |
|
---|
248 | ;; Multiplication of polynomials
|
---|
249 | ;; Non-destructive version
|
---|
250 | (defun termlist-mul (ring p q)
|
---|
251 | (cond ((or (endp p) (endp q)) nil) ;p or q is 0 (represented by NIL)
|
---|
252 | ;; If p=p0+p1 and q=q0+q1 then pq=p0q0+p0q1+p1q
|
---|
253 | ((endp (cdr p))
|
---|
254 | (term-times-termlist ring (car p) q))
|
---|
255 | ((endp (cdr q))
|
---|
256 | (termlist-times-term ring p (car q)))
|
---|
257 | (t
|
---|
258 | (let ((head (term-mul ring (termlist-lt p) (termlist-lt q)))
|
---|
259 | (tail (termlist-add ring (term-times-termlist ring (car p) (cdr q))
|
---|
260 | (termlist-mul ring (cdr p) q))))
|
---|
261 | (cond ((null head) tail)
|
---|
262 | ((null tail) head)
|
---|
263 | (t (nconc head tail)))))))
|
---|
264 |
|
---|
265 | (defun termlist-unit (ring dimension)
|
---|
266 | (declare (fixnum dimension))
|
---|
267 | (list (make-term (make-monom dimension :initial-element 0)
|
---|
268 | (funcall (ring-unit ring)))))
|
---|
269 |
|
---|
270 | (defun termlist-expt (ring poly n &aux (dim (monom-dimension (termlist-lm poly))))
|
---|
271 | (declare (type fixnum n dim))
|
---|
272 | (cond
|
---|
273 | ((minusp n) (error "termlist-expt: Negative exponent."))
|
---|
274 | ((endp poly) (if (zerop n) (termlist-unit ring dim) nil))
|
---|
275 | (t
|
---|
276 | (do ((k 1 (ash k 1))
|
---|
277 | (q poly (termlist-mul ring q q)) ;keep squaring
|
---|
278 | (p (termlist-unit ring dim) (if (not (zerop (logand k n))) (termlist-mul ring p q) p)))
|
---|
279 | ((> k n) p)
|
---|
280 | (declare (fixnum k))))))
|
---|
281 |
|
---|
282 | |
---|
283 |
|
---|
284 |
|
---|
285 |
|
---|
286 |
|
---|
287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
288 | ;;
|
---|
289 | ;; Debugging/tracing
|
---|
290 | ;;
|
---|
291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
292 | (defmacro debug-cgb (&rest args)
|
---|
293 | `(when $poly_grobner_debug (format *terminal-io* ,@args)))
|
---|
294 |
|
---|
295 |
|
---|
296 |
|
---|
297 | |
---|
298 |
|
---|
299 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
300 | ;;
|
---|
301 | ;; These are provided mostly for debugging purposes To enable
|
---|
302 | ;; verification of grobner bases with BUCHBERGER-CRITERION, do
|
---|
303 | ;; (pushnew :grobner-check *features*) and compile/load this file.
|
---|
304 | ;; With this feature, the calculations will slow down CONSIDERABLY.
|
---|
305 | ;;
|
---|
306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
307 |
|
---|
308 | (defun grobner-test (ring g f)
|
---|
309 | "Test whether G is a Grobner basis and F is contained in G. Return T
|
---|
310 | upon success and NIL otherwise."
|
---|
311 | (debug-cgb "~&GROBNER CHECK: ")
|
---|
312 | (let (($poly_grobner_debug nil)
|
---|
313 | (stat1 (buchberger-criterion ring g))
|
---|
314 | (stat2
|
---|
315 | (every #'poly-zerop
|
---|
316 | (makelist (normal-form ring (copy-tree (elt f i)) g nil)
|
---|
317 | (i 0 (1- (length f)))))))
|
---|
318 | (unless stat1 (error "~&Buchberger criterion failed."))
|
---|
319 | (unless stat2
|
---|
320 | (error "~&Original polys not in ideal spanned by Grobner.")))
|
---|
321 | (debug-cgb "~&GROBNER CHECK END")
|
---|
322 | t)
|
---|
323 |
|
---|
324 |
|
---|
325 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
326 | ;;
|
---|
327 | ;; Selection of algorithm and pair heuristic
|
---|
328 | ;;
|
---|
329 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
330 |
|
---|
331 | (defun find-grobner-function (algorithm)
|
---|
332 | "Return a function which calculates Grobner basis, based on its
|
---|
333 | names. Names currently used are either Lisp symbols, Maxima symbols or
|
---|
334 | keywords."
|
---|
335 | (ecase algorithm
|
---|
336 | ((buchberger :buchberger $buchberger) #'buchberger)
|
---|
337 | ((parallel-buchberger :parallel-buchberger $parallel_buchberger) #'parallel-buchberger)
|
---|
338 | ((gebauer-moeller :gebauer_moeller $gebauer_moeller) #'gebauer-moeller)))
|
---|
339 |
|
---|
340 | (defun grobner (ring f &optional (start 0) (top-reduction-only nil))
|
---|
341 | ;;(setf F (sort F #'< :key #'sugar))
|
---|
342 | (funcall
|
---|
343 | (find-grobner-function $poly_grobner_algorithm)
|
---|
344 | ring f start top-reduction-only))
|
---|
345 |
|
---|
346 | (defun reduced-grobner (ring f &optional (start 0) (top-reduction-only $poly_top_reduction_only))
|
---|
347 | (reduction ring (grobner ring f start top-reduction-only)))
|
---|
348 |
|
---|
349 | (defun set-pair-heuristic (method)
|
---|
350 | "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used
|
---|
351 | to determine the priority of critical pairs in the priority queue."
|
---|
352 | (ecase method
|
---|
353 | ((sugar :sugar $sugar)
|
---|
354 | (setf *pair-key-function* #'sugar-pair-key
|
---|
355 | *pair-order* #'sugar-order))
|
---|
356 | ; ((minimal-mock-spoly :minimal-mock-spoly $minimal_mock_spoly)
|
---|
357 | ; (setf *pair-key-function* #'mock-spoly
|
---|
358 | ; *pair-order* #'mock-spoly-order))
|
---|
359 | ((minimal-lcm :minimal-lcm $minimal_lcm)
|
---|
360 | (setf *pair-key-function* #'(lambda (p q)
|
---|
361 | (monom-lcm (poly-lm p) (poly-lm q)))
|
---|
362 | *pair-order* #'reverse-monomial-order))
|
---|
363 | ((minimal-total-degree :minimal-total-degree $minimal_total_degree)
|
---|
364 | (setf *pair-key-function* #'(lambda (p q)
|
---|
365 | (monom-total-degree
|
---|
366 | (monom-lcm (poly-lm p) (poly-lm q))))
|
---|
367 | *pair-order* #'<))
|
---|
368 | ((minimal-length :minimal-length $minimal_length)
|
---|
369 | (setf *pair-key-function* #'(lambda (p q)
|
---|
370 | (+ (poly-length p) (poly-length q)))
|
---|
371 | *pair-order* #'<))))
|
---|
372 |
|
---|
373 |
|
---|
374 | |
---|
375 |
|
---|
376 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
377 | ;;
|
---|
378 | ;; Set up the coefficients to be polynomials
|
---|
379 | ;;
|
---|
380 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
381 |
|
---|
382 | ;; (defun poly-ring (ring vars)
|
---|
383 | ;; (make-ring
|
---|
384 | ;; :parse #'(lambda (expr) (poly-eval ring expr vars))
|
---|
385 | ;; :unit #'(lambda () (poly-unit ring (length vars)))
|
---|
386 | ;; :zerop #'poly-zerop
|
---|
387 | ;; :add #'(lambda (x y) (poly-add ring x y))
|
---|
388 | ;; :sub #'(lambda (x y) (poly-sub ring x y))
|
---|
389 | ;; :uminus #'(lambda (x) (poly-uminus ring x))
|
---|
390 | ;; :mul #'(lambda (x y) (poly-mul ring x y))
|
---|
391 | ;; :div #'(lambda (x y) (poly-exact-divide ring x y))
|
---|
392 | ;; :lcm #'(lambda (x y) (poly-lcm ring x y))
|
---|
393 | ;; :ezgcd #'(lambda (x y &aux (gcd (poly-gcd ring x y)))
|
---|
394 | ;; (values gcd
|
---|
395 | ;; (poly-exact-divide ring x gcd)
|
---|
396 | ;; (poly-exact-divide ring y gcd)))
|
---|
397 | ;; :gcd #'(lambda (x y) (poly-gcd x y))))
|
---|
398 |
|
---|
399 | |
---|
400 |
|
---|
401 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
402 | ;;
|
---|
403 | ;; Conversion from internal to infix form
|
---|
404 | ;;
|
---|
405 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
406 |
|
---|
407 | (defun coerce-to-infix (poly-type object vars)
|
---|
408 | (case poly-type
|
---|
409 | (:termlist
|
---|
410 | `(+ ,@(mapcar #'(lambda (term) (coerce-to-infix :term term vars)) object)))
|
---|
411 | (:polynomial
|
---|
412 | (coerce-to-infix :termlist (poly-termlist object) vars))
|
---|
413 | (:poly-list
|
---|
414 | `([ ,@(mapcar #'(lambda (p) (coerce-to-infix :polynomial p vars)) object)))
|
---|
415 | (:term
|
---|
416 | `(* ,(term-coeff object)
|
---|
417 | ,@(mapcar #'(lambda (var power) `(expt ,var ,power))
|
---|
418 | vars (monom-exponents (term-monom object)))))
|
---|
419 | (otherwise
|
---|
420 | object)))
|
---|
421 |
|
---|
422 | |
---|
423 |
|
---|
424 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
425 | ;;
|
---|
426 | ;; Maxima expression ring
|
---|
427 | ;;
|
---|
428 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
429 |
|
---|
430 | (defparameter *expression-ring*
|
---|
431 | (make-ring
|
---|
432 | ;;(defun coeff-zerop (expr) (meval1 `(($is) (($equal) ,expr 0))))
|
---|
433 | :parse #'(lambda (expr)
|
---|
434 | (when modulus (setf expr ($rat expr)))
|
---|
435 | expr)
|
---|
436 | :unit #'(lambda () (if modulus ($rat 1) 1))
|
---|
437 | :zerop #'(lambda (expr)
|
---|
438 | ;;When is exactly a maxima expression equal to 0?
|
---|
439 | (cond ((numberp expr)
|
---|
440 | (= expr 0))
|
---|
441 | ((atom expr) nil)
|
---|
442 | (t
|
---|
443 | (case (caar expr)
|
---|
444 | (mrat (eql ($ratdisrep expr) 0))
|
---|
445 | (otherwise (eql ($totaldisrep expr) 0))))))
|
---|
446 | :add #'(lambda (x y) (m+ x y))
|
---|
447 | :sub #'(lambda (x y) (m- x y))
|
---|
448 | :uminus #'(lambda (x) (m- x))
|
---|
449 | :mul #'(lambda (x y) (m* x y))
|
---|
450 | ;;(defun coeff-div (x y) (cadr ($divide x y)))
|
---|
451 | :div #'(lambda (x y) (m// x y))
|
---|
452 | :lcm #'(lambda (x y) (meval1 `((|$LCM|) ,x ,y)))
|
---|
453 | :ezgcd #'(lambda (x y) (apply #'values (cdr ($ezgcd ($totaldisrep x) ($totaldisrep y)))))
|
---|
454 | ;; :gcd #'(lambda (x y) (second ($ezgcd x y)))))
|
---|
455 | :gcd #'(lambda (x y) ($gcd x y))))
|
---|
456 |
|
---|
457 | (defvar *maxima-ring* *expression-ring*
|
---|
458 | "The ring of coefficients, over which all polynomials
|
---|
459 | are assumed to be defined.")
|
---|
460 |
|
---|
461 |
|
---|
462 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
463 | ;;
|
---|
464 | ;; Order utilities
|
---|
465 | ;;
|
---|
466 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
467 | (defun find-order (order)
|
---|
468 | "This function returns the order function bases on its name."
|
---|
469 | (cond
|
---|
470 | ((null order) nil)
|
---|
471 | ((symbolp order)
|
---|
472 | (case order
|
---|
473 | ((lex :lex $lex) #'lex>)
|
---|
474 | ((grlex :grlex $grlex) #'grlex>)
|
---|
475 | ((grevlex :grevlex $grevlex) #'grevlex>)
|
---|
476 | ((invlex :invlex $invlex) #'invlex>)
|
---|
477 | ((elimination-order-1 :elimination-order-1 elimination_order_1) #'elimination-order-1)
|
---|
478 | (otherwise
|
---|
479 | (mtell "~%Warning: Order ~M not found. Using default.~%" order))))
|
---|
480 | (t
|
---|
481 | (mtell "~%Order specification ~M is not recognized. Using default.~%" order)
|
---|
482 | nil)))
|
---|
483 |
|
---|
484 | (defun find-ring (ring)
|
---|
485 | "This function returns the ring structure bases on input symbol."
|
---|
486 | (cond
|
---|
487 | ((null ring) nil)
|
---|
488 | ((symbolp ring)
|
---|
489 | (case ring
|
---|
490 | ((expression-ring :expression-ring $expression_ring) *expression-ring*)
|
---|
491 | ((ring-of-integers :ring-of-integers $ring_of_integers) *ring-of-integers*)
|
---|
492 | (otherwise
|
---|
493 | (mtell "~%Warning: Ring ~M not found. Using default.~%" ring))))
|
---|
494 | (t
|
---|
495 | (mtell "~%Ring specification ~M is not recognized. Using default.~%" ring)
|
---|
496 | nil)))
|
---|
497 |
|
---|
498 | (defmacro with-monomial-order ((order) &body body)
|
---|
499 | "Evaluate BODY with monomial order set to ORDER."
|
---|
500 | `(let ((*monomial-order* (or (find-order ,order) *monomial-order*)))
|
---|
501 | . ,body))
|
---|
502 |
|
---|
503 | (defmacro with-coefficient-ring ((ring) &body body)
|
---|
504 | "Evaluate BODY with coefficient ring set to RING."
|
---|
505 | `(let ((*maxima-ring* (or (find-ring ,ring) *maxima-ring*)))
|
---|
506 | . ,body))
|
---|
507 |
|
---|
508 | (defmacro with-elimination-orders ((primary secondary elimination-order)
|
---|
509 | &body body)
|
---|
510 | "Evaluate BODY with primary and secondary elimination orders set to PRIMARY and SECONDARY."
|
---|
511 | `(let ((*primary-elimination-order* (or (find-order ,primary) *primary-elimination-order*))
|
---|
512 | (*secondary-elimination-order* (or (find-order ,secondary) *secondary-elimination-order*))
|
---|
513 | (*elimination-order* (or (find-order ,elimination-order) *elimination-order*)))
|
---|
514 | . ,body))
|
---|
515 |
|
---|
516 | |
---|
517 |
|
---|
518 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
519 | ;;
|
---|
520 | ;; Conversion from internal form to Maxima general form
|
---|
521 | ;;
|
---|
522 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
523 |
|
---|
524 | (defun maxima-head ()
|
---|
525 | (if $poly_return_term_list
|
---|
526 | '(mlist)
|
---|
527 | '(mplus)))
|
---|
528 |
|
---|
529 | (defun coerce-to-maxima (poly-type object vars)
|
---|
530 | (case poly-type
|
---|
531 | (:polynomial
|
---|
532 | `(,(maxima-head) ,@(mapcar #'(lambda (term) (coerce-to-maxima :term term vars)) (poly-termlist object))))
|
---|
533 | (:poly-list
|
---|
534 | `((mlist) ,@(mapcar #'(lambda (p) ($ratdisrep (coerce-to-maxima :polynomial p vars))) object)))
|
---|
535 | (:term
|
---|
536 | `((mtimes) ,($ratdisrep (term-coeff object))
|
---|
537 | ,@(mapcar #'(lambda (var power) `((mexpt) ,var ,power))
|
---|
538 | vars (monom-exponents (term-monom object)))))
|
---|
539 | ;; Assumes that Lisp and Maxima logicals coincide
|
---|
540 | (:logical object)
|
---|
541 | (otherwise
|
---|
542 | object)))
|
---|
543 |
|
---|
544 | |
---|
545 |
|
---|
546 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
547 | ;;
|
---|
548 | ;; Macro facility for writing Maxima-level wrappers for
|
---|
549 | ;; functions operating on internal representation
|
---|
550 | ;;
|
---|
551 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
552 |
|
---|
553 | (defmacro with-parsed-polynomials (((maxima-vars &optional (maxima-new-vars nil new-vars-supplied-p))
|
---|
554 | &key (polynomials nil)
|
---|
555 | (poly-lists nil)
|
---|
556 | (poly-list-lists nil)
|
---|
557 | (value-type nil))
|
---|
558 | &body body
|
---|
559 | &aux (vars (gensym))
|
---|
560 | (new-vars (gensym)))
|
---|
561 | `(let ((,vars (coerce-maxima-list ,maxima-vars))
|
---|
562 | ,@(when new-vars-supplied-p
|
---|
563 | (list `(,new-vars (coerce-maxima-list ,maxima-new-vars)))))
|
---|
564 | (coerce-to-maxima
|
---|
565 | ,value-type
|
---|
566 | (with-coefficient-ring ($poly_coefficient_ring)
|
---|
567 | (with-monomial-order ($poly_monomial_order)
|
---|
568 | (with-elimination-orders ($poly_primary_elimination_order
|
---|
569 | $poly_secondary_elimination_order
|
---|
570 | $poly_elimination_order)
|
---|
571 | (let ,(let ((args nil))
|
---|
572 | (dolist (p polynomials args)
|
---|
573 | (setf args (cons `(,p (parse-poly ,p ,vars)) args)))
|
---|
574 | (dolist (p poly-lists args)
|
---|
575 | (setf args (cons `(,p (parse-poly-list ,p ,vars)) args)))
|
---|
576 | (dolist (p poly-list-lists args)
|
---|
577 | (setf args (cons `(,p (parse-poly-list-list ,p ,vars)) args))))
|
---|
578 | . ,body))))
|
---|
579 | ,(if new-vars-supplied-p
|
---|
580 | `(append ,vars ,new-vars)
|
---|
581 | vars))))
|
---|
582 |
|
---|
583 | (defmacro define-unop (maxima-name fun-name
|
---|
584 | &optional (documentation nil documentation-supplied-p))
|
---|
585 | "Define a MAXIMA-level unary operator MAXIMA-NAME corresponding to unary function FUN-NAME."
|
---|
586 | `(defun ,maxima-name (p vars
|
---|
587 | &aux
|
---|
588 | (vars (coerce-maxima-list vars))
|
---|
589 | (p (parse-poly p vars)))
|
---|
590 | ,@(when documentation-supplied-p (list documentation))
|
---|
591 | (coerce-to-maxima :polynomial (,fun-name *maxima-ring* p) vars)))
|
---|
592 |
|
---|
593 | (defmacro define-binop (maxima-name fun-name
|
---|
594 | &optional (documentation nil documentation-supplied-p))
|
---|
595 | "Define a MAXIMA-level binary operator MAXIMA-NAME corresponding to binary function FUN-NAME."
|
---|
596 | `(defmfun ,maxima-name (p q vars
|
---|
597 | &aux
|
---|
598 | (vars (coerce-maxima-list vars))
|
---|
599 | (p (parse-poly p vars))
|
---|
600 | (q (parse-poly q vars)))
|
---|
601 | ,@(when documentation-supplied-p (list documentation))
|
---|
602 | (coerce-to-maxima :polynomial (,fun-name *maxima-ring* p q) vars)))
|
---|
603 |
|
---|
604 | |
---|
605 |
|
---|
606 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
607 | ;;
|
---|
608 | ;; Maxima-level interface functions
|
---|
609 | ;;
|
---|
610 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
611 |
|
---|
612 | ;; Auxillary function for removing zero polynomial
|
---|
613 | (defun remzero (plist) (remove #'poly-zerop plist))
|
---|
614 |
|
---|
615 | ;;Simple operators
|
---|
616 |
|
---|
617 | (define-binop $poly_add poly-add
|
---|
618 | "Adds two polynomials P and Q")
|
---|
619 |
|
---|
620 | (define-binop $poly_subtract poly-sub
|
---|
621 | "Subtracts a polynomial Q from P.")
|
---|
622 |
|
---|
623 | (define-binop $poly_multiply poly-mul
|
---|
624 | "Returns the product of polynomials P and Q.")
|
---|
625 |
|
---|
626 | (define-binop $poly_s_polynomial spoly
|
---|
627 | "Returns the syzygy polynomial (S-polynomial) of two polynomials P and Q.")
|
---|
628 |
|
---|
629 | (define-unop $poly_primitive_part poly-primitive-part
|
---|
630 | "Returns the polynomial P divided by GCD of its coefficients.")
|
---|
631 |
|
---|
632 | (define-unop $poly_normalize poly-normalize
|
---|
633 | "Returns the polynomial P divided by the leading coefficient.")
|
---|
634 |
|
---|
635 | ;;Functions
|
---|
636 |
|
---|
637 | (defmfun $poly_expand (p vars)
|
---|
638 | "This function is equivalent to EXPAND(P) if P parses correctly to a polynomial.
|
---|
639 | If the representation is not compatible with a polynomial in variables VARS,
|
---|
640 | the result is an error."
|
---|
641 | (with-parsed-polynomials ((vars) :polynomials (p)
|
---|
642 | :value-type :polynomial)
|
---|
643 | p))
|
---|
644 |
|
---|
645 | (defmfun $poly_expt (p n vars)
|
---|
646 | (with-parsed-polynomials ((vars) :polynomials (p) :value-type :polynomial)
|
---|
647 | (poly-expt *maxima-ring* p n)))
|
---|
648 |
|
---|
649 | (defmfun $poly_content (p vars)
|
---|
650 | (with-parsed-polynomials ((vars) :polynomials (p))
|
---|
651 | (poly-content *maxima-ring* p)))
|
---|
652 |
|
---|
653 | (defmfun $poly_pseudo_divide (f fl vars
|
---|
654 | &aux (vars (coerce-maxima-list vars))
|
---|
655 | (f (parse-poly f vars))
|
---|
656 | (fl (parse-poly-list fl vars)))
|
---|
657 | (multiple-value-bind (quot rem c division-count)
|
---|
658 | (poly-pseudo-divide *maxima-ring* f fl)
|
---|
659 | `((mlist)
|
---|
660 | ,(coerce-to-maxima :poly-list quot vars)
|
---|
661 | ,(coerce-to-maxima :polynomial rem vars)
|
---|
662 | ,c
|
---|
663 | ,division-count)))
|
---|
664 |
|
---|
665 | (defmfun $poly_exact_divide (f g vars)
|
---|
666 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
667 | (poly-exact-divide *maxima-ring* f g)))
|
---|
668 |
|
---|
669 | (defmfun $poly_normal_form (f fl vars)
|
---|
670 | (with-parsed-polynomials ((vars) :polynomials (f)
|
---|
671 | :poly-lists (fl)
|
---|
672 | :value-type :polynomial)
|
---|
673 | (normal-form *maxima-ring* f (remzero fl) nil)))
|
---|
674 |
|
---|
675 | (defmfun $poly_buchberger_criterion (g vars)
|
---|
676 | (with-parsed-polynomials ((vars) :poly-lists (g) :value-type :logical)
|
---|
677 | (buchberger-criterion *maxima-ring* g)))
|
---|
678 |
|
---|
679 | (defmfun $poly_buchberger (fl vars)
|
---|
680 | (with-parsed-polynomials ((vars) :poly-lists (fl) :value-type :poly-list)
|
---|
681 | (buchberger *maxima-ring* (remzero fl) 0 nil)))
|
---|
682 |
|
---|
683 | (defmfun $poly_reduction (plist vars)
|
---|
684 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
685 | :value-type :poly-list)
|
---|
686 | (reduction *maxima-ring* plist)))
|
---|
687 |
|
---|
688 | (defmfun $poly_minimization (plist vars)
|
---|
689 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
690 | :value-type :poly-list)
|
---|
691 | (minimization plist)))
|
---|
692 |
|
---|
693 | (defmfun $poly_normalize_list (plist vars)
|
---|
694 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
695 | :value-type :poly-list)
|
---|
696 | (poly-normalize-list *maxima-ring* plist)))
|
---|
697 |
|
---|
698 | (defmfun $poly_grobner (f vars)
|
---|
699 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
700 | :value-type :poly-list)
|
---|
701 | (grobner *maxima-ring* (remzero f))))
|
---|
702 |
|
---|
703 | (defmfun $poly_reduced_grobner (f vars)
|
---|
704 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
705 | :value-type :poly-list)
|
---|
706 | (reduced-grobner *maxima-ring* (remzero f))))
|
---|
707 |
|
---|
708 | (defmfun $poly_depends_p (p var mvars
|
---|
709 | &aux (vars (coerce-maxima-list mvars))
|
---|
710 | (pos (position var vars)))
|
---|
711 | (if (null pos)
|
---|
712 | (merror "~%Variable ~M not in the list of variables ~M." var mvars)
|
---|
713 | (poly-depends-p (parse-poly p vars) pos)))
|
---|
714 |
|
---|
715 | (defmfun $poly_elimination_ideal (flist k vars)
|
---|
716 | (with-parsed-polynomials ((vars) :poly-lists (flist)
|
---|
717 | :value-type :poly-list)
|
---|
718 | (elimination-ideal *maxima-ring* flist k nil 0)))
|
---|
719 |
|
---|
720 | (defmfun $poly_colon_ideal (f g vars)
|
---|
721 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
722 | (colon-ideal *maxima-ring* f g nil)))
|
---|
723 |
|
---|
724 | (defmfun $poly_ideal_intersection (f g vars)
|
---|
725 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
726 | (ideal-intersection *maxima-ring* f g nil)))
|
---|
727 |
|
---|
728 | (defmfun $poly_lcm (f g vars)
|
---|
729 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
730 | (poly-lcm *maxima-ring* f g)))
|
---|
731 |
|
---|
732 | (defmfun $poly_gcd (f g vars)
|
---|
733 | ($first ($divide (m* f g) ($poly_lcm f g vars))))
|
---|
734 |
|
---|
735 | (defmfun $poly_grobner_equal (g1 g2 vars)
|
---|
736 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
737 | (grobner-equal *maxima-ring* g1 g2)))
|
---|
738 |
|
---|
739 | (defmfun $poly_grobner_subsetp (g1 g2 vars)
|
---|
740 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
741 | (grobner-subsetp *maxima-ring* g1 g2)))
|
---|
742 |
|
---|
743 | (defmfun $poly_grobner_member (p g vars)
|
---|
744 | (with-parsed-polynomials ((vars) :polynomials (p) :poly-lists (g))
|
---|
745 | (grobner-member *maxima-ring* p g)))
|
---|
746 |
|
---|
747 | (defmfun $poly_ideal_saturation1 (f p vars)
|
---|
748 | (with-parsed-polynomials ((vars) :poly-lists (f) :polynomials (p)
|
---|
749 | :value-type :poly-list)
|
---|
750 | (ideal-saturation-1 *maxima-ring* f p 0)))
|
---|
751 |
|
---|
752 | (defmfun $poly_saturation_extension (f plist vars new-vars)
|
---|
753 | (with-parsed-polynomials ((vars new-vars)
|
---|
754 | :poly-lists (f plist)
|
---|
755 | :value-type :poly-list)
|
---|
756 | (saturation-extension *maxima-ring* f plist)))
|
---|
757 |
|
---|
758 | (defmfun $poly_polysaturation_extension (f plist vars new-vars)
|
---|
759 | (with-parsed-polynomials ((vars new-vars)
|
---|
760 | :poly-lists (f plist)
|
---|
761 | :value-type :poly-list)
|
---|
762 | (polysaturation-extension *maxima-ring* f plist)))
|
---|
763 |
|
---|
764 | (defmfun $poly_ideal_polysaturation1 (f plist vars)
|
---|
765 | (with-parsed-polynomials ((vars) :poly-lists (f plist)
|
---|
766 | :value-type :poly-list)
|
---|
767 | (ideal-polysaturation-1 *maxima-ring* f plist 0 nil)))
|
---|
768 |
|
---|
769 | (defmfun $poly_ideal_saturation (f g vars)
|
---|
770 | (with-parsed-polynomials ((vars) :poly-lists (f g)
|
---|
771 | :value-type :poly-list)
|
---|
772 | (ideal-saturation *maxima-ring* f g 0 nil)))
|
---|
773 |
|
---|
774 | (defmfun $poly_ideal_polysaturation (f ideal-list vars)
|
---|
775 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
776 | :poly-list-lists (ideal-list)
|
---|
777 | :value-type :poly-list)
|
---|
778 | (ideal-polysaturation *maxima-ring* f ideal-list 0 nil)))
|
---|
779 |
|
---|
780 | (defmfun $poly_lt (f vars)
|
---|
781 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
782 | (make-poly-from-termlist (list (poly-lt f)))))
|
---|
783 |
|
---|
784 | (defmfun $poly_lm (f vars)
|
---|
785 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
786 | (make-poly-from-termlist (list (make-term (poly-lm f) (funcall (ring-unit *maxima-ring*)))))))
|
---|
787 |
|
---|