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 | ;;
|
---|
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
27 |
|
---|
28 | (in-package :maxima)
|
---|
29 |
|
---|
30 | (macsyma-module cgb-maxima)
|
---|
31 |
|
---|
32 | (eval-when
|
---|
33 | #+gcl (load eval)
|
---|
34 | #-gcl (:load-toplevel :execute)
|
---|
35 | (format t "~&Loading maxima-grobner ~a ~a~%"
|
---|
36 | "$Revision: 2.0 $" "$Date: 2015/06/02 0:34:17 $"))
|
---|
37 |
|
---|
38 | ;;FUNCTS is loaded because it contains the definition of LCM
|
---|
39 | ($load "functs")
|
---|
40 |
|
---|
41 | #+gcl (unless (macro-function 'with-compilation-unit)
|
---|
42 | (defmacro with-compilation-unit (a &rest b) `(progn ,@b)))
|
---|
43 |
|
---|
44 | #+sbcl(require 'asdf)
|
---|
45 | ($load "utils")
|
---|
46 | ($load "grobner")
|
---|
47 | ($load "monomial")
|
---|
48 | ($load "term")
|
---|
49 | ($load "termlist")
|
---|
50 | ($load "polynomial")
|
---|
51 | ($load "order")
|
---|
52 | ($load "order-mk")
|
---|
53 | ($load "priority-queue")
|
---|
54 | ($load "pair-queue")
|
---|
55 | ($load "division")
|
---|
56 | ($load "criterion")
|
---|
57 | ($load "buchberger")
|
---|
58 | ($load "gebauer-moeller")
|
---|
59 | ($load "gb-postprocessing")
|
---|
60 | ($load "ideal")
|
---|
61 |
|
---|
62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
63 | ;;
|
---|
64 | ;; Maxima expression ring
|
---|
65 | ;;
|
---|
66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
67 |
|
---|
68 | (defparameter *expression-ring*
|
---|
69 | (make-ring
|
---|
70 | ;;(defun coeff-zerop (expr) (meval1 `(($is) (($equal) ,expr 0))))
|
---|
71 | :parse #'(lambda (expr)
|
---|
72 | (when modulus (setf expr ($rat expr)))
|
---|
73 | expr)
|
---|
74 | :unit #'(lambda () (if modulus ($rat 1) 1))
|
---|
75 | :zerop #'(lambda (expr)
|
---|
76 | ;;When is exactly a maxima expression equal to 0?
|
---|
77 | (cond ((numberp expr)
|
---|
78 | (= expr 0))
|
---|
79 | ((atom expr) nil)
|
---|
80 | (t
|
---|
81 | (case (caar expr)
|
---|
82 | (mrat (eql ($ratdisrep expr) 0))
|
---|
83 | (otherwise (eql ($totaldisrep expr) 0))))))
|
---|
84 | :add #'(lambda (x y) (m+ x y))
|
---|
85 | :sub #'(lambda (x y) (m- x y))
|
---|
86 | :uminus #'(lambda (x) (m- x))
|
---|
87 | :mul #'(lambda (x y) (m* x y))
|
---|
88 | ;;(defun coeff-div (x y) (cadr ($divide x y)))
|
---|
89 | :div #'(lambda (x y) (m// x y))
|
---|
90 | :lcm #'(lambda (x y) (meval1 `((|$LCM|) ,x ,y)))
|
---|
91 | :ezgcd #'(lambda (x y) (apply #'values (cdr ($ezgcd ($totaldisrep x) ($totaldisrep y)))))
|
---|
92 | ;; :gcd #'(lambda (x y) (second ($ezgcd x y)))))
|
---|
93 | :gcd #'(lambda (x y) ($gcd x y))))
|
---|
94 |
|
---|
95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
96 | ;;
|
---|
97 | ;; Maxima expression parsing
|
---|
98 | ;;
|
---|
99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
100 |
|
---|
101 | (defun equal-test-p (expr1 expr2)
|
---|
102 | (alike1 expr1 expr2))
|
---|
103 |
|
---|
104 | (defun coerce-maxima-list (expr)
|
---|
105 | "convert a maxima list to lisp list."
|
---|
106 | (cond
|
---|
107 | ((and (consp (car expr)) (eql (caar expr) 'mlist)) (cdr expr))
|
---|
108 | (t expr)))
|
---|
109 |
|
---|
110 | (defun free-of-vars (expr vars) (apply #'$freeof `(,@vars ,expr)))
|
---|
111 |
|
---|
112 | (defun parse-poly (expr vars &aux (vars (coerce-maxima-list vars)))
|
---|
113 | "Convert a maxima polynomial expression EXPR in variables VARS to internal form."
|
---|
114 | (labels ((parse (arg) (parse-poly arg vars))
|
---|
115 | (parse-list (args) (mapcar #'parse args)))
|
---|
116 | (cond
|
---|
117 | ((eql expr 0) (make-poly-zero))
|
---|
118 | ((member expr vars :test #'equal-test-p)
|
---|
119 | (let ((pos (position expr vars :test #'equal-test-p)))
|
---|
120 | (make-variable *maxima-ring* (length vars) pos)))
|
---|
121 | ((free-of-vars expr vars)
|
---|
122 | ;;This means that variable-free CRE and Poisson forms will be converted
|
---|
123 | ;;to coefficients intact
|
---|
124 | (coerce-coeff *maxima-ring* expr vars))
|
---|
125 | (t
|
---|
126 | (case (caar expr)
|
---|
127 | (mplus (reduce #'(lambda (x y) (poly-add *maxima-ring* x y)) (parse-list (cdr expr))))
|
---|
128 | (mminus (poly-uminus *maxima-ring* (parse (cadr expr))))
|
---|
129 | (mtimes
|
---|
130 | (if (endp (cddr expr)) ;unary
|
---|
131 | (parse (cdr expr))
|
---|
132 | (reduce #'(lambda (p q) (poly-mul *maxima-ring* p q)) (parse-list (cdr expr)))))
|
---|
133 | (mexpt
|
---|
134 | (cond
|
---|
135 | ((member (cadr expr) vars :test #'equal-test-p)
|
---|
136 | ;;Special handling of (expt var pow)
|
---|
137 | (let ((pos (position (cadr expr) vars :test #'equal-test-p)))
|
---|
138 | (make-variable *maxima-ring* (length vars) pos (caddr expr))))
|
---|
139 | ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
|
---|
140 | ;; Negative power means division in coefficient ring
|
---|
141 | ;; Non-integer power means non-polynomial coefficient
|
---|
142 | (mtell "~%Warning: Expression ~%~M~%contains power which is not a positive integer. Parsing as coefficient.~%"
|
---|
143 | expr)
|
---|
144 | (coerce-coeff *maxima-ring* expr vars))
|
---|
145 | (t (poly-expt *maxima-ring* (parse (cadr expr)) (caddr expr)))))
|
---|
146 | (mrat (parse ($ratdisrep expr)))
|
---|
147 | (mpois (parse ($outofpois expr)))
|
---|
148 | (otherwise
|
---|
149 | (coerce-coeff *maxima-ring* expr vars)))))))
|
---|
150 |
|
---|
151 | (defun parse-poly-list (expr vars)
|
---|
152 | (case (caar expr)
|
---|
153 | (mlist (mapcar #'(lambda (p) (parse-poly p vars)) (cdr expr)))
|
---|
154 | (t (merror "Expression ~M is not a list of polynomials in variables ~M."
|
---|
155 | expr vars))))
|
---|
156 | (defun parse-poly-list-list (poly-list-list vars)
|
---|
157 | (mapcar #'(lambda (g) (parse-poly-list g vars)) (coerce-maxima-list poly-list-list)))
|
---|
158 |
|
---|
159 |
|
---|
160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
161 | ;;
|
---|
162 | ;; Unary and binary operation definition facility
|
---|
163 | ;;
|
---|
164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
165 |
|
---|
166 | (defmacro define-unop (maxima-name fun-name
|
---|
167 | &optional (documentation nil documentation-supplied-p))
|
---|
168 | "Define a MAXIMA-level unary operator MAXIMA-NAME corresponding to unary function FUN-NAME."
|
---|
169 | `(defun ,maxima-name (p vars
|
---|
170 | &aux
|
---|
171 | (vars (coerce-maxima-list vars))
|
---|
172 | (p (parse-poly p vars)))
|
---|
173 | ,@(when documentation-supplied-p (list documentation))
|
---|
174 | (coerce-to-maxima :polynomial (,fun-name *maxima-ring* p) vars)))
|
---|
175 |
|
---|
176 | (defmacro define-binop (maxima-name fun-name
|
---|
177 | &optional (documentation nil documentation-supplied-p))
|
---|
178 | "Define a MAXIMA-level binary operator MAXIMA-NAME corresponding to binary function FUN-NAME."
|
---|
179 | `(defmfun ,maxima-name (p q vars
|
---|
180 | &aux
|
---|
181 | (vars (coerce-maxima-list vars))
|
---|
182 | (p (parse-poly p vars))
|
---|
183 | (q (parse-poly q vars)))
|
---|
184 | ,@(when documentation-supplied-p (list documentation))
|
---|
185 | (coerce-to-maxima :polynomial (,fun-name *maxima-ring* p q) vars)))
|
---|
186 |
|
---|
187 |
|
---|
188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
189 | ;;
|
---|
190 | ;; Maxima-level interface functions
|
---|
191 | ;;
|
---|
192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
193 |
|
---|
194 | ;; Auxillary function for removing zero polynomial
|
---|
195 | (defun remzero (plist) (remove #'poly-zerop plist))
|
---|
196 |
|
---|
197 | ;;Simple operators
|
---|
198 |
|
---|
199 | (define-binop $poly_add poly-add
|
---|
200 | "Adds two polynomials P and Q")
|
---|
201 |
|
---|
202 | (define-binop $poly_subtract poly-sub
|
---|
203 | "Subtracts a polynomial Q from P.")
|
---|
204 |
|
---|
205 | (define-binop $poly_multiply poly-mul
|
---|
206 | "Returns the product of polynomials P and Q.")
|
---|
207 |
|
---|
208 | (define-binop $poly_s_polynomial spoly
|
---|
209 | "Returns the syzygy polynomial (S-polynomial) of two polynomials P and Q.")
|
---|
210 |
|
---|
211 | (define-unop $poly_primitive_part poly-primitive-part
|
---|
212 | "Returns the polynomial P divided by GCD of its coefficients.")
|
---|
213 |
|
---|
214 | (define-unop $poly_normalize poly-normalize
|
---|
215 | "Returns the polynomial P divided by the leading coefficient.")
|
---|
216 |
|
---|
217 | ;;Functions
|
---|
218 |
|
---|
219 | (defmfun $poly_expand (p vars)
|
---|
220 | "This function is equivalent to EXPAND(P) if P parses correctly to a polynomial.
|
---|
221 | If the representation is not compatible with a polynomial in variables VARS,
|
---|
222 | the result is an error."
|
---|
223 | (with-parsed-polynomials ((vars) :polynomials (p)
|
---|
224 | :value-type :polynomial)
|
---|
225 | p))
|
---|
226 |
|
---|
227 | (defmfun $poly_expt (p n vars)
|
---|
228 | (with-parsed-polynomials ((vars) :polynomials (p) :value-type :polynomial)
|
---|
229 | (poly-expt *maxima-ring* p n)))
|
---|
230 |
|
---|
231 | (defmfun $poly_content (p vars)
|
---|
232 | (with-parsed-polynomials ((vars) :polynomials (p))
|
---|
233 | (poly-content *maxima-ring* p)))
|
---|
234 |
|
---|
235 | (defmfun $poly_pseudo_divide (f fl vars
|
---|
236 | &aux (vars (coerce-maxima-list vars))
|
---|
237 | (f (parse-poly f vars))
|
---|
238 | (fl (parse-poly-list fl vars)))
|
---|
239 | (multiple-value-bind (quot rem c division-count)
|
---|
240 | (poly-pseudo-divide *maxima-ring* f fl)
|
---|
241 | `((mlist)
|
---|
242 | ,(coerce-to-maxima :poly-list quot vars)
|
---|
243 | ,(coerce-to-maxima :polynomial rem vars)
|
---|
244 | ,c
|
---|
245 | ,division-count)))
|
---|
246 |
|
---|
247 | (defmfun $poly_exact_divide (f g vars)
|
---|
248 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
249 | (poly-exact-divide *maxima-ring* f g)))
|
---|
250 |
|
---|
251 | (defmfun $poly_normal_form (f fl vars)
|
---|
252 | (with-parsed-polynomials ((vars) :polynomials (f)
|
---|
253 | :poly-lists (fl)
|
---|
254 | :value-type :polynomial)
|
---|
255 | (normal-form *maxima-ring* f (remzero fl) nil)))
|
---|
256 |
|
---|
257 | (defmfun $poly_buchberger_criterion (g vars)
|
---|
258 | (with-parsed-polynomials ((vars) :poly-lists (g) :value-type :logical)
|
---|
259 | (buchberger-criterion *maxima-ring* g)))
|
---|
260 |
|
---|
261 | (defmfun $poly_buchberger (fl vars)
|
---|
262 | (with-parsed-polynomials ((vars) :poly-lists (fl) :value-type :poly-list)
|
---|
263 | (buchberger *maxima-ring* (remzero fl) 0 nil)))
|
---|
264 |
|
---|
265 | (defmfun $poly_reduction (plist vars)
|
---|
266 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
267 | :value-type :poly-list)
|
---|
268 | (reduction *maxima-ring* plist)))
|
---|
269 |
|
---|
270 | (defmfun $poly_minimization (plist vars)
|
---|
271 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
272 | :value-type :poly-list)
|
---|
273 | (minimization plist)))
|
---|
274 |
|
---|
275 | (defmfun $poly_normalize_list (plist vars)
|
---|
276 | (with-parsed-polynomials ((vars) :poly-lists (plist)
|
---|
277 | :value-type :poly-list)
|
---|
278 | (poly-normalize-list *maxima-ring* plist)))
|
---|
279 |
|
---|
280 | (defmfun $poly_grobner (f vars)
|
---|
281 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
282 | :value-type :poly-list)
|
---|
283 | (grobner *maxima-ring* (remzero f))))
|
---|
284 |
|
---|
285 | (defmfun $poly_reduced_grobner (f vars)
|
---|
286 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
287 | :value-type :poly-list)
|
---|
288 | (reduced-grobner *maxima-ring* (remzero f))))
|
---|
289 |
|
---|
290 | (defmfun $poly_depends_p (p var mvars
|
---|
291 | &aux (vars (coerce-maxima-list mvars))
|
---|
292 | (pos (position var vars)))
|
---|
293 | (if (null pos)
|
---|
294 | (merror "~%Variable ~M not in the list of variables ~M." var mvars)
|
---|
295 | (poly-depends-p (parse-poly p vars) pos)))
|
---|
296 |
|
---|
297 | (defmfun $poly_elimination_ideal (flist k vars)
|
---|
298 | (with-parsed-polynomials ((vars) :poly-lists (flist)
|
---|
299 | :value-type :poly-list)
|
---|
300 | (elimination-ideal *maxima-ring* flist k nil 0)))
|
---|
301 |
|
---|
302 | (defmfun $poly_colon_ideal (f g vars)
|
---|
303 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
304 | (colon-ideal *maxima-ring* f g nil)))
|
---|
305 |
|
---|
306 | (defmfun $poly_ideal_intersection (f g vars)
|
---|
307 | (with-parsed-polynomials ((vars) :poly-lists (f g) :value-type :poly-list)
|
---|
308 | (ideal-intersection *maxima-ring* f g nil)))
|
---|
309 |
|
---|
310 | (defmfun $poly_lcm (f g vars)
|
---|
311 | (with-parsed-polynomials ((vars) :polynomials (f g) :value-type :polynomial)
|
---|
312 | (poly-lcm *maxima-ring* f g)))
|
---|
313 |
|
---|
314 | (defmfun $poly_gcd (f g vars)
|
---|
315 | ($first ($divide (m* f g) ($poly_lcm f g vars))))
|
---|
316 |
|
---|
317 | (defmfun $poly_grobner_equal (g1 g2 vars)
|
---|
318 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
319 | (grobner-equal *maxima-ring* g1 g2)))
|
---|
320 |
|
---|
321 | (defmfun $poly_grobner_subsetp (g1 g2 vars)
|
---|
322 | (with-parsed-polynomials ((vars) :poly-lists (g1 g2))
|
---|
323 | (grobner-subsetp *maxima-ring* g1 g2)))
|
---|
324 |
|
---|
325 | (defmfun $poly_grobner_member (p g vars)
|
---|
326 | (with-parsed-polynomials ((vars) :polynomials (p) :poly-lists (g))
|
---|
327 | (grobner-member *maxima-ring* p g)))
|
---|
328 |
|
---|
329 | (defmfun $poly_ideal_saturation1 (f p vars)
|
---|
330 | (with-parsed-polynomials ((vars) :poly-lists (f) :polynomials (p)
|
---|
331 | :value-type :poly-list)
|
---|
332 | (ideal-saturation-1 *maxima-ring* f p 0)))
|
---|
333 |
|
---|
334 | (defmfun $poly_saturation_extension (f plist vars new-vars)
|
---|
335 | (with-parsed-polynomials ((vars new-vars)
|
---|
336 | :poly-lists (f plist)
|
---|
337 | :value-type :poly-list)
|
---|
338 | (saturation-extension *maxima-ring* f plist)))
|
---|
339 |
|
---|
340 | (defmfun $poly_polysaturation_extension (f plist vars new-vars)
|
---|
341 | (with-parsed-polynomials ((vars new-vars)
|
---|
342 | :poly-lists (f plist)
|
---|
343 | :value-type :poly-list)
|
---|
344 | (polysaturation-extension *maxima-ring* f plist)))
|
---|
345 |
|
---|
346 | (defmfun $poly_ideal_polysaturation1 (f plist vars)
|
---|
347 | (with-parsed-polynomials ((vars) :poly-lists (f plist)
|
---|
348 | :value-type :poly-list)
|
---|
349 | (ideal-polysaturation-1 *maxima-ring* f plist 0 nil)))
|
---|
350 |
|
---|
351 | (defmfun $poly_ideal_saturation (f g vars)
|
---|
352 | (with-parsed-polynomials ((vars) :poly-lists (f g)
|
---|
353 | :value-type :poly-list)
|
---|
354 | (ideal-saturation *maxima-ring* f g 0 nil)))
|
---|
355 |
|
---|
356 | (defmfun $poly_ideal_polysaturation (f ideal-list vars)
|
---|
357 | (with-parsed-polynomials ((vars) :poly-lists (f)
|
---|
358 | :poly-list-lists (ideal-list)
|
---|
359 | :value-type :poly-list)
|
---|
360 | (ideal-polysaturation *maxima-ring* f ideal-list 0 nil)))
|
---|
361 |
|
---|
362 | (defmfun $poly_lt (f vars)
|
---|
363 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
364 | (make-poly-from-termlist (list (poly-lt f)))))
|
---|
365 |
|
---|
366 | (defmfun $poly_lm (f vars)
|
---|
367 | (with-parsed-polynomials ((vars) :polynomials (f) :value-type :polynomial)
|
---|
368 | (make-poly-from-termlist (list (make-term (poly-lm f) (funcall (ring-unit *maxima-ring*)))))))
|
---|
369 |
|
---|