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 | (defpackage "MONOM"
|
---|
23 | (:use :cl :utils :copy :ring)
|
---|
24 | (:export "MONOM"
|
---|
25 | "TERM"
|
---|
26 | "EXPONENT"
|
---|
27 | "MONOM-DIMENSION"
|
---|
28 | "MONOM-EXPONENTS"
|
---|
29 | "UNIVERSAL-EQUALP"
|
---|
30 | "MONOM-ELT"
|
---|
31 | "TOTAL-DEGREE"
|
---|
32 | "SUGAR"
|
---|
33 | "MULTIPLY-BY"
|
---|
34 | "DIVIDE-BY"
|
---|
35 | "DIVIDE"
|
---|
36 | "MULTIPLY"
|
---|
37 | "DIVIDES-P"
|
---|
38 | "DIVIDES-LCM-P"
|
---|
39 | "LCM-DIVIDES-LCM-P"
|
---|
40 | "LCM-EQUAL-LCM-P"
|
---|
41 | "DIVISIBLE-BY-P"
|
---|
42 | "REL-PRIME-P"
|
---|
43 | "UNIVERSAL-LCM"
|
---|
44 | "UNIVERSAL-GCD"
|
---|
45 | "DEPENDS-P"
|
---|
46 | "LEFT-TENSOR-PRODUCT-BY"
|
---|
47 | "RIGHT-TENSOR-PRODUCT-BY"
|
---|
48 | "LEFT-CONTRACT"
|
---|
49 | "MAKE-MONOM-VARIABLE"
|
---|
50 | "MAKE-MONOM-CONSTANT"
|
---|
51 | "MAKE-TERM-CONSTANT"
|
---|
52 | "->LIST"
|
---|
53 | "->SEXP"
|
---|
54 | "LEX>"
|
---|
55 | "GRLEX>"
|
---|
56 | "REVLEX>"
|
---|
57 | "GREVLEX>"
|
---|
58 | "INVLEX>"
|
---|
59 | "REVERSE-MONOMIAL-ORDER"
|
---|
60 | "MAKE-ELIMINATION-ORDER-FACTORY"
|
---|
61 | "TERM-COEFF"
|
---|
62 | "UNARY-MINUS"
|
---|
63 | "UNARY-INVERSE"
|
---|
64 | "UNIVERSAL-ZEROP")
|
---|
65 | (:documentation
|
---|
66 | "This package implements basic operations on monomials, including
|
---|
67 | various monomial orders.
|
---|
68 |
|
---|
69 | DATA STRUCTURES: Conceptually, monomials can be represented as lists:
|
---|
70 |
|
---|
71 | monom: (n1 n2 ... nk) where ni are non-negative integers
|
---|
72 |
|
---|
73 | However, lists may be implemented as other sequence types, so the
|
---|
74 | flexibility to change the representation should be maintained in the
|
---|
75 | code to use general operations on sequences whenever possible. The
|
---|
76 | optimization for the actual representation should be left to
|
---|
77 | declarations and the compiler.
|
---|
78 |
|
---|
79 | EXAMPLES: Suppose that variables are x and y. Then
|
---|
80 |
|
---|
81 | Monom x*y^2 ---> (1 2) "))
|
---|
82 |
|
---|
83 | (in-package "MONOM")
|
---|
84 |
|
---|
85 | (proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 0)))
|
---|
86 |
|
---|
87 | (deftype exponent ()
|
---|
88 | "Type of exponent in a monomial."
|
---|
89 | 'fixnum)
|
---|
90 |
|
---|
91 | (defclass monom ()
|
---|
92 | ((exponents :initarg :exponents :accessor monom-exponents
|
---|
93 | :documentation "The powers of the variables."))
|
---|
94 | ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
|
---|
95 | ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
|
---|
96 | (:documentation
|
---|
97 | "Implements a monomial, i.e. a product of powers
|
---|
98 | of variables, like X*Y^2."))
|
---|
99 |
|
---|
100 | (defmethod print-object ((self monom) stream)
|
---|
101 | (print-unreadable-object (self stream :type t :identity t)
|
---|
102 | (with-accessors ((exponents monom-exponents))
|
---|
103 | self
|
---|
104 | (format stream "EXPONENTS=~A"
|
---|
105 | exponents))))
|
---|
106 |
|
---|
107 | (defmethod initialize-instance :after ((self monom)
|
---|
108 | &key
|
---|
109 | (dimension 0 dimension-supplied-p)
|
---|
110 | (exponents nil exponents-supplied-p)
|
---|
111 | (exponent 0)
|
---|
112 | &allow-other-keys
|
---|
113 | )
|
---|
114 | "The following INITIALIZE-INSTANCE method allows instance initialization
|
---|
115 | of a MONOM in a style similar to MAKE-ARRAY, e.g.:
|
---|
116 |
|
---|
117 | (MAKE-INSTANCE 'MONOM :EXPONENTS '(1 2 3)) --> #<MONOM EXPONENTS=#(1 2 3)>
|
---|
118 | (MAKE-INSTANCE 'MONOM :DIMENSION 3) --> #<MONOM EXPONENTS=#(0 0 0)>
|
---|
119 | (MAKE-INSTANCE 'MONOM :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>
|
---|
120 |
|
---|
121 | If both DIMENSION and EXPONENTS are supplied, they must be compatible,
|
---|
122 | i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS
|
---|
123 | is not supplied, a monom with repeated value EXPONENT is created.
|
---|
124 | By default EXPONENT is 0, which results in a constant monomial.
|
---|
125 | "
|
---|
126 | (cond
|
---|
127 | (exponents-supplied-p
|
---|
128 | (when (and dimension-supplied-p
|
---|
129 | (/= dimension (length exponents)))
|
---|
130 | (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"
|
---|
131 | exponents dimension))
|
---|
132 | (let ((dim (length exponents)))
|
---|
133 | (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))
|
---|
134 | (dimension-supplied-p
|
---|
135 | ;; when all exponents are to be identical
|
---|
136 | (setf (slot-value self 'exponents) (make-array (list dimension)
|
---|
137 | :initial-element exponent
|
---|
138 | :element-type 'exponent)))
|
---|
139 | (t
|
---|
140 | (error "Initarg DIMENSION or EXPONENTS must be supplied."))))
|
---|
141 |
|
---|
142 | (defgeneric monom-dimension (self)
|
---|
143 | (:method ((self monom))
|
---|
144 | (length (monom-exponents self))))
|
---|
145 |
|
---|
146 | (defmethod universal-equalp ((self monom) (other monom))
|
---|
147 | "Returns T iff monomials SELF and OTHER have identical EXPONENTS."
|
---|
148 | (equalp (monom-exponents self) (monom-exponents other)))
|
---|
149 |
|
---|
150 | (defgeneric monom-elt (m index)
|
---|
151 | (:documentation "Return the power in the monomial M of variable number INDEX.")
|
---|
152 | (:method ((m monom) index)
|
---|
153 | "Return the power in the monomial M of variable number INDEX."
|
---|
154 | (with-slots (exponents)
|
---|
155 | m
|
---|
156 | (elt exponents index))))
|
---|
157 |
|
---|
158 | (defgeneric (setf monom-elt) (new-value m index)
|
---|
159 | (:documentation "Set the power in the monomial M of variable number INDEX.")
|
---|
160 | (:method (new-value (m monom) index)
|
---|
161 | (with-slots (exponents)
|
---|
162 | m
|
---|
163 | (setf (elt exponents index) new-value))))
|
---|
164 |
|
---|
165 | (defgeneric total-degree (m &optional start end)
|
---|
166 | (:documentation "Return the total degree of a monomoal M. Optinally, a range
|
---|
167 | of variables may be specified with arguments START and END.")
|
---|
168 | (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
|
---|
169 | (declare (type fixnum start end))
|
---|
170 | (with-slots (exponents)
|
---|
171 | m
|
---|
172 | (reduce #'+ exponents :start start :end end))))
|
---|
173 |
|
---|
174 | (defgeneric sugar (m &optional start end)
|
---|
175 | (:documentation "Return the sugar of a monomial M. Optinally, a range
|
---|
176 | of variables may be specified with arguments START and END.")
|
---|
177 | (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
|
---|
178 | (declare (type fixnum start end))
|
---|
179 | (total-degree m start end)))
|
---|
180 |
|
---|
181 | (defmethod multiply-by ((self monom) (other monom))
|
---|
182 | (with-slots ((exponents1 exponents))
|
---|
183 | self
|
---|
184 | (with-slots ((exponents2 exponents))
|
---|
185 | other
|
---|
186 | (unless (= (length exponents1) (length exponents2))
|
---|
187 | (error "Incompatible dimensions"))
|
---|
188 | (map-into exponents1 #'+ exponents1 exponents2)))
|
---|
189 | self)
|
---|
190 |
|
---|
191 | (defun multiply (factor &rest more-factors)
|
---|
192 | "Successively multiplies factor FACTOR by the remaining arguments
|
---|
193 | MORE-FACTORS, using MULTIPLY-BY to multiply two factors. Thus
|
---|
194 | FACTOR may be destructively modified."
|
---|
195 | (reduce #'multiply-by more-factors :initial-value (copy-instance factor)))
|
---|
196 |
|
---|
197 | (defmethod divide-by ((self monom) (other monom))
|
---|
198 | (with-slots ((exponents1 exponents))
|
---|
199 | self
|
---|
200 | (with-slots ((exponents2 exponents))
|
---|
201 | other
|
---|
202 | (unless (= (length exponents1) (length exponents2))
|
---|
203 | (error "divide-by: Incompatible dimensions."))
|
---|
204 | (unless (every #'>= exponents1 exponents2)
|
---|
205 | (error "divide-by: Negative power would result."))
|
---|
206 | (map-into exponents1 #'- exponents1 exponents2)))
|
---|
207 | self)
|
---|
208 |
|
---|
209 | (defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
|
---|
210 | "An :AROUND method of COPY-INSTANCE. It replaces exponents with a fresh copy of the sequence."
|
---|
211 | (declare (ignore object initargs))
|
---|
212 | (let ((copy (call-next-method)))
|
---|
213 | (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
|
---|
214 | copy))
|
---|
215 |
|
---|
216 | (defmethod unary-inverse :before ((self monom))
|
---|
217 | (assert (zerop (total-degree self))
|
---|
218 | nil
|
---|
219 | "Monom ~A must have total degree 0 to be invertible.")
|
---|
220 | self)
|
---|
221 |
|
---|
222 | (defmethod unary-inverse ((self monom)) self)
|
---|
223 |
|
---|
224 | (defun divide (numerator &rest denominators)
|
---|
225 | "Successively divides NUMERATOR by elements of DENOMINATORS. The operation
|
---|
226 | destructively modifies NUMERATOR."
|
---|
227 | (cond ((endp denominators)
|
---|
228 | (unary-inverse numerator))
|
---|
229 | (t (reduce #'divide-by denominators :initial-value (copy-instance numerator)))))
|
---|
230 |
|
---|
231 | (defgeneric divides-p (object1 object2)
|
---|
232 | (:documentation "Returns T if OBJECT1 divides OBJECT2.")
|
---|
233 | (:method ((m1 monom) (m2 monom))
|
---|
234 | "Returns T if monomial M1 divides monomial M2, NIL otherwise."
|
---|
235 | (with-slots ((exponents1 exponents))
|
---|
236 | m1
|
---|
237 | (with-slots ((exponents2 exponents))
|
---|
238 | m2
|
---|
239 | (every #'<= exponents1 exponents2)))))
|
---|
240 |
|
---|
241 | (defgeneric divides-lcm-p (object1 object2 object3)
|
---|
242 | (:documentation "Returns T if OBJECT1 divides LCM(OBJECT2,OBJECT3), NIL otherwise.")
|
---|
243 | (:method ((m1 monom) (m2 monom) (m3 monom))
|
---|
244 | "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
|
---|
245 | (with-slots ((exponents1 exponents))
|
---|
246 | m1
|
---|
247 | (with-slots ((exponents2 exponents))
|
---|
248 | m2
|
---|
249 | (with-slots ((exponents3 exponents))
|
---|
250 | m3
|
---|
251 | (every #'(lambda (x y z) (<= x (max y z)))
|
---|
252 | exponents1 exponents2 exponents3))))))
|
---|
253 |
|
---|
254 | (defgeneric lcm-divides-lcm-p (object1 object2 object3 object4)
|
---|
255 | (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
|
---|
256 | "Returns T if monomial LCM(M1,M2) divides LCM(M3,M4), NIL otherwise."
|
---|
257 | (with-slots ((exponents1 exponents))
|
---|
258 | m1
|
---|
259 | (with-slots ((exponents2 exponents))
|
---|
260 | m2
|
---|
261 | (with-slots ((exponents3 exponents))
|
---|
262 | m3
|
---|
263 | (with-slots ((exponents4 exponents))
|
---|
264 | m4
|
---|
265 | (every #'(lambda (x y z w) (<= (max x y) (max z w)))
|
---|
266 | exponents1 exponents2 exponents3 exponents4)))))))
|
---|
267 |
|
---|
268 | (defgeneric monom-lcm-equal-lcm-p (object1 object2 object3 object4)
|
---|
269 | (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
|
---|
270 | "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
|
---|
271 | (with-slots ((exponents1 exponents))
|
---|
272 | m1
|
---|
273 | (with-slots ((exponents2 exponents))
|
---|
274 | m2
|
---|
275 | (with-slots ((exponents3 exponents))
|
---|
276 | m3
|
---|
277 | (with-slots ((exponents4 exponents))
|
---|
278 | m4
|
---|
279 | (every
|
---|
280 | #'(lambda (x y z w) (= (max x y) (max z w)))
|
---|
281 | exponents1 exponents2 exponents3 exponents4)))))))
|
---|
282 |
|
---|
283 | (defgeneric divisible-by-p (object1 object2)
|
---|
284 | (:documentation "Return T if OBJECT1 is divisible by OBJECT2.")
|
---|
285 | (:method ((m1 monom) (m2 monom))
|
---|
286 | "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
|
---|
287 | (with-slots ((exponents1 exponents))
|
---|
288 | m1
|
---|
289 | (with-slots ((exponents2 exponents))
|
---|
290 | m2
|
---|
291 | (every #'>= exponents1 exponents2)))))
|
---|
292 |
|
---|
293 | (defgeneric rel-prime-p (object1 object2)
|
---|
294 | (:documentation "Returns T if objects OBJECT1 and OBJECT2 are relatively prime.")
|
---|
295 | (:method ((m1 monom) (m2 monom))
|
---|
296 | "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
|
---|
297 | (with-slots ((exponents1 exponents))
|
---|
298 | m1
|
---|
299 | (with-slots ((exponents2 exponents))
|
---|
300 | m2
|
---|
301 | (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2)))))
|
---|
302 |
|
---|
303 | (defgeneric universal-lcm (object1 object2)
|
---|
304 | (:documentation "Returns the multiple of objects OBJECT1 and OBJECT2.")
|
---|
305 | (:method ((m1 monom) (m2 monom))
|
---|
306 | "Returns least common multiple of monomials M1 and M2."
|
---|
307 | (with-slots ((exponents1 exponents))
|
---|
308 | m1
|
---|
309 | (with-slots ((exponents2 exponents))
|
---|
310 | m2
|
---|
311 | (let* ((exponents (copy-seq exponents1)))
|
---|
312 | (map-into exponents #'max exponents1 exponents2)
|
---|
313 | (make-instance 'monom :exponents exponents))))))
|
---|
314 |
|
---|
315 |
|
---|
316 | (defmethod universal-gcd ((m1 monom) (m2 monom))
|
---|
317 | "Returns greatest common divisor of monomials M1 and M2."
|
---|
318 | (with-slots ((exponents1 exponents))
|
---|
319 | m1
|
---|
320 | (with-slots ((exponents2 exponents))
|
---|
321 | m2
|
---|
322 | (let* ((exponents (copy-seq exponents1)))
|
---|
323 | (map-into exponents #'min exponents1 exponents2)
|
---|
324 | (make-instance 'monom :exponents exponents)))))
|
---|
325 |
|
---|
326 | (defgeneric depends-p (object k)
|
---|
327 | (:documentation "Returns T iff object OBJECT depends on variable K.")
|
---|
328 | (:method ((m monom) k)
|
---|
329 | "Return T if the monomial M depends on variable number K."
|
---|
330 | (declare (type fixnum k))
|
---|
331 | (with-slots (exponents)
|
---|
332 | m
|
---|
333 | (plusp (elt exponents k)))))
|
---|
334 |
|
---|
335 | (defgeneric left-tensor-product-by (self other)
|
---|
336 | (:documentation "Returns a tensor product SELF by OTHER, stored into
|
---|
337 | SELF. Return SELF.")
|
---|
338 | (:method ((self monom) (other monom))
|
---|
339 | (with-slots ((exponents1 exponents))
|
---|
340 | self
|
---|
341 | (with-slots ((exponents2 exponents))
|
---|
342 | other
|
---|
343 | (setf exponents1 (concatenate 'vector exponents2 exponents1))))
|
---|
344 | self))
|
---|
345 |
|
---|
346 | (defgeneric right-tensor-product-by (self other)
|
---|
347 | (:documentation "Returns a tensor product of OTHER by SELF, stored
|
---|
348 | into SELF. Returns SELF.")
|
---|
349 | (:method ((self monom) (other monom))
|
---|
350 | (with-slots ((exponents1 exponents))
|
---|
351 | self
|
---|
352 | (with-slots ((exponents2 exponents))
|
---|
353 | other
|
---|
354 | (setf exponents1 (concatenate 'vector exponents1 exponents2))))
|
---|
355 | self))
|
---|
356 |
|
---|
357 | (defgeneric left-contract (self k)
|
---|
358 | (:documentation "Drop the first K variables in object SELF.")
|
---|
359 | (:method ((self monom) k)
|
---|
360 | "Drop the first K variables in monomial M."
|
---|
361 | (declare (fixnum k))
|
---|
362 | (with-slots (exponents)
|
---|
363 | self
|
---|
364 | (setf exponents (subseq exponents k)))
|
---|
365 | self))
|
---|
366 |
|
---|
367 | (defun make-monom-variable (nvars pos &optional (power 1)
|
---|
368 | &aux (m (make-instance 'monom :dimension nvars)))
|
---|
369 | "Construct a monomial in the polynomial ring
|
---|
370 | RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
|
---|
371 | which represents a single variable. It assumes number of variables
|
---|
372 | NVARS and the variable is at position POS. Optionally, the variable
|
---|
373 | may appear raised to power POWER. "
|
---|
374 | (declare (type fixnum nvars pos power) (type monom m))
|
---|
375 | (with-slots (exponents)
|
---|
376 | m
|
---|
377 | (setf (elt exponents pos) power)
|
---|
378 | m))
|
---|
379 |
|
---|
380 | (defun make-monom-constant (dimension)
|
---|
381 | (make-instance 'monom :dimension dimension))
|
---|
382 |
|
---|
383 | ;; pure lexicographic
|
---|
384 | (defgeneric lex> (p q &optional start end)
|
---|
385 | (:documentation "Return T if P>Q with respect to lexicographic
|
---|
386 | order, otherwise NIL. The second returned value is T if P=Q,
|
---|
387 | otherwise it is NIL.")
|
---|
388 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
389 | (declare (type fixnum start end))
|
---|
390 | (do ((i start (1+ i)))
|
---|
391 | ((>= i end) (values nil t))
|
---|
392 | (cond
|
---|
393 | ((> (monom-elt p i) (monom-elt q i))
|
---|
394 | (return-from lex> (values t nil)))
|
---|
395 | ((< (monom-elt p i) (monom-elt q i))
|
---|
396 | (return-from lex> (values nil nil)))))))
|
---|
397 |
|
---|
398 | ;; total degree order, ties broken by lexicographic
|
---|
399 | (defgeneric grlex> (p q &optional start end)
|
---|
400 | (:documentation "Return T if P>Q with respect to graded
|
---|
401 | lexicographic order, otherwise NIL. The second returned value is T if
|
---|
402 | P=Q, otherwise it is NIL.")
|
---|
403 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
404 | (declare (type monom p q) (type fixnum start end))
|
---|
405 | (let ((d1 (total-degree p start end))
|
---|
406 | (d2 (total-degree q start end)))
|
---|
407 | (declare (type fixnum d1 d2))
|
---|
408 | (cond
|
---|
409 | ((> d1 d2) (values t nil))
|
---|
410 | ((< d1 d2) (values nil nil))
|
---|
411 | (t
|
---|
412 | (lex> p q start end))))))
|
---|
413 |
|
---|
414 | ;; reverse lexicographic
|
---|
415 | (defgeneric revlex> (p q &optional start end)
|
---|
416 | (:documentation "Return T if P>Q with respect to reverse
|
---|
417 | lexicographic order, NIL otherwise. The second returned value is T if
|
---|
418 | P=Q, otherwise it is NIL. This is not and admissible monomial order
|
---|
419 | because some sets do not have a minimal element. This order is useful
|
---|
420 | in constructing other orders.")
|
---|
421 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
422 | (declare (type fixnum start end))
|
---|
423 | (do ((i (1- end) (1- i)))
|
---|
424 | ((< i start) (values nil t))
|
---|
425 | (declare (type fixnum i))
|
---|
426 | (cond
|
---|
427 | ((< (monom-elt p i) (monom-elt q i))
|
---|
428 | (return-from revlex> (values t nil)))
|
---|
429 | ((> (monom-elt p i) (monom-elt q i))
|
---|
430 | (return-from revlex> (values nil nil)))))))
|
---|
431 |
|
---|
432 |
|
---|
433 | ;; total degree, ties broken by reverse lexicographic
|
---|
434 | (defgeneric grevlex> (p q &optional start end)
|
---|
435 | (:documentation "Return T if P>Q with respect to graded reverse
|
---|
436 | lexicographic order, NIL otherwise. The second returned value is T if
|
---|
437 | P=Q, otherwise it is NIL.")
|
---|
438 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
439 | (declare (type fixnum start end))
|
---|
440 | (let ((d1 (total-degree p start end))
|
---|
441 | (d2 (total-degree q start end)))
|
---|
442 | (declare (type fixnum d1 d2))
|
---|
443 | (cond
|
---|
444 | ((> d1 d2) (values t nil))
|
---|
445 | ((< d1 d2) (values nil nil))
|
---|
446 | (t
|
---|
447 | (revlex> p q start end))))))
|
---|
448 |
|
---|
449 | (defgeneric invlex> (p q &optional start end)
|
---|
450 | (:documentation "Return T if P>Q with respect to inverse
|
---|
451 | lexicographic order, NIL otherwise The second returned value is T if
|
---|
452 | P=Q, otherwise it is NIL.")
|
---|
453 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
454 | (declare (type fixnum start end))
|
---|
455 | (do ((i (1- end) (1- i)))
|
---|
456 | ((< i start) (values nil t))
|
---|
457 | (declare (type fixnum i))
|
---|
458 | (cond
|
---|
459 | ((> (monom-elt p i) (monom-elt q i))
|
---|
460 | (return-from invlex> (values t nil)))
|
---|
461 | ((< (monom-elt p i) (monom-elt q i))
|
---|
462 | (return-from invlex> (values nil nil)))))))
|
---|
463 |
|
---|
464 | (defun reverse-monomial-order (order)
|
---|
465 | "Create the inverse monomial order to the given monomial order ORDER."
|
---|
466 | #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
|
---|
467 | (declare (type monom p q) (type fixnum start end))
|
---|
468 | (funcall order q p start end)))
|
---|
469 |
|
---|
470 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
471 | ;;
|
---|
472 | ;; Order making functions
|
---|
473 | ;;
|
---|
474 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
475 |
|
---|
476 | ;; This returns a closure with the same signature
|
---|
477 | ;; as all orders such as #'LEX>.
|
---|
478 | (defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
|
---|
479 | "It constructs an elimination order used for the 1-st elimination ideal,
|
---|
480 | i.e. for eliminating the first variable. Thus, the order compares the degrees of the
|
---|
481 | first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
|
---|
482 | #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
|
---|
483 | (declare (type monom p q) (type fixnum start end))
|
---|
484 | (cond
|
---|
485 | ((> (monom-elt p start) (monom-elt q start))
|
---|
486 | (values t nil))
|
---|
487 | ((< (monom-elt p start) (monom-elt q start))
|
---|
488 | (values nil nil))
|
---|
489 | (t
|
---|
490 | (funcall secondary-elimination-order p q (1+ start) end)))))
|
---|
491 |
|
---|
492 | ;; This returns a closure which is called with an integer argument.
|
---|
493 | ;; The result is *another closure* with the same signature as all
|
---|
494 | ;; orders such as #'LEX>.
|
---|
495 | (defun make-elimination-order-factory (&optional
|
---|
496 | (primary-elimination-order #'lex>)
|
---|
497 | (secondary-elimination-order #'lex>))
|
---|
498 | "Return a function with a single integer argument K. This should be
|
---|
499 | the number of initial K variables X[0],X[1],...,X[K-1], which precede
|
---|
500 | remaining variables. The call to the closure creates a predicate
|
---|
501 | which compares monomials according to the K-th elimination order. The
|
---|
502 | monomial orders PRIMARY-ELIMINATION-ORDER and
|
---|
503 | SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
|
---|
504 | remaining variables, respectively, with ties broken by lexicographical
|
---|
505 | order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
|
---|
506 | which indicates that the first K variables appear with identical
|
---|
507 | powers, then the result is that of a call to
|
---|
508 | SECONDARY-ELIMINATION-ORDER applied to the remaining variables
|
---|
509 | X[K],X[K+1],..."
|
---|
510 | #'(lambda (k)
|
---|
511 | (cond
|
---|
512 | ((<= k 0)
|
---|
513 | (error "K must be at least 1"))
|
---|
514 | ((= k 1)
|
---|
515 | (make-elimination-order-factory-1 secondary-elimination-order))
|
---|
516 | (t
|
---|
517 | #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
|
---|
518 | (declare (type monom p q) (type fixnum start end))
|
---|
519 | (multiple-value-bind (primary equal)
|
---|
520 | (funcall primary-elimination-order p q start k)
|
---|
521 | (if equal
|
---|
522 | (funcall secondary-elimination-order p q k end)
|
---|
523 | (values primary nil))))))))
|
---|
524 |
|
---|
525 | (defclass term (monom)
|
---|
526 | ((coeff :initarg :coeff :initform 1 :accessor term-coeff :type ring))
|
---|
527 | (:default-initargs :coeff 1)
|
---|
528 | (:documentation "Implements a term, i.e. a product of a scalar
|
---|
529 | and powers of some variables, such as 5*X^2*Y^3."))
|
---|
530 |
|
---|
531 | (defmethod shared-initialize :around ((self term) slot-names &rest initargs &key (coeff 1))
|
---|
532 | "A convenience method. If a coefficient is an integer, wrap it in the INTEGER-RING object"
|
---|
533 | ;; Dispatch on the type of supplied :COEFF arg
|
---|
534 | (typecase coeff
|
---|
535 | (rational
|
---|
536 | (setf (getf initargs :coeff) (make-instance 'rational-field :value coeff))))
|
---|
537 | ;; Now pass new initargs to the next method
|
---|
538 | (apply #'call-next-method (list* self slot-names initargs)))
|
---|
539 |
|
---|
540 |
|
---|
541 | (defmethod update-instance-for-different-class :after ((old monom) (new term) &key (coeff 1))
|
---|
542 | "Converts OLD of class MONOM to a NEW of class TERM, initializing coefficient to COEFF."
|
---|
543 | (reinitialize-instance new :coeff coeff))
|
---|
544 |
|
---|
545 | (defmethod update-instance-for-different-class :after ((old term) (new term) &key (coeff (term-coeff old)))
|
---|
546 | "Converts OLD of class TERM to a NEW of class TERM, initializing coefficient to COEFF."
|
---|
547 | (reinitialize-instance new :coeff coeff))
|
---|
548 |
|
---|
549 |
|
---|
550 | (defmethod print-object ((self term) stream)
|
---|
551 | (print-unreadable-object (self stream :type t :identity t)
|
---|
552 | (with-accessors ((exponents monom-exponents)
|
---|
553 | (coeff term-coeff))
|
---|
554 | self
|
---|
555 | (format stream "EXPONENTS=~A COEFF=~A"
|
---|
556 | exponents coeff))))
|
---|
557 |
|
---|
558 | (defmethod copy-instance :around ((object term) &rest initargs &key &allow-other-keys)
|
---|
559 | "An :AROUND method of COPY-INSTANCE. It replaces the coefficient with a fresh copy."
|
---|
560 | (declare (ignore object initargs))
|
---|
561 | (let ((copy (call-next-method)))
|
---|
562 | (setf (term-coeff copy) (copy-instance (term-coeff object)))
|
---|
563 | copy))
|
---|
564 |
|
---|
565 | #|
|
---|
566 | (defmethod multiply-by ((self term) (other number))
|
---|
567 | (reinitialize-instance self :coeff (multiply-by (term-coeff self) other)))
|
---|
568 |
|
---|
569 | (defmethod divide-by ((self term) (other number))
|
---|
570 | (reinitialize-instance self :coeff (divide-by (term-coeff self) other)))
|
---|
571 | |#
|
---|
572 |
|
---|
573 | (defmethod unary-inverse :after ((self term))
|
---|
574 | (with-slots (coeff)
|
---|
575 | self
|
---|
576 | (setf coeff (unary-inverse coeff))))
|
---|
577 |
|
---|
578 | (defun make-term-constant (dimension &optional (coeff 1))
|
---|
579 | (make-instance 'term :dimension dimension :coeff coeff))
|
---|
580 |
|
---|
581 | (defmethod universal-equalp ((term1 term) (term2 term))
|
---|
582 | "Returns T if TERM1 and TERM2 are equal as MONOM, and coefficients
|
---|
583 | are UNIVERSAL-EQUALP."
|
---|
584 | (and (call-next-method)
|
---|
585 | (universal-equalp (term-coeff term1) (term-coeff term2))))
|
---|
586 |
|
---|
587 | (defmethod multiply-by :before ((self term) (other term))
|
---|
588 | "Destructively multiply terms SELF and OTHER and store the result into SELF.
|
---|
589 | It returns SELF."
|
---|
590 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
591 |
|
---|
592 |
|
---|
593 | (defmethod left-tensor-product-by :before ((self term) (other term))
|
---|
594 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
595 |
|
---|
596 | (defmethod right-tensor-product-by :before ((self term) (other term))
|
---|
597 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
598 |
|
---|
599 | (defmethod divide-by :before ((self term) (other term))
|
---|
600 | (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other))))
|
---|
601 |
|
---|
602 | (defmethod unary-minus ((self term))
|
---|
603 | (setf (term-coeff self) (unary-minus (term-coeff self)))
|
---|
604 | self)
|
---|
605 |
|
---|
606 | (defmethod universal-zerop ((self term))
|
---|
607 | (universal-zerop (term-coeff self)))
|
---|
608 |
|
---|
609 | (defgeneric ->list (self)
|
---|
610 | (:method ((self monom))
|
---|
611 | "A human-readable representation of a monomial SELF as a list of exponents."
|
---|
612 | (coerce (monom-exponents self) 'list))
|
---|
613 | (:method ((self term))
|
---|
614 | "A human-readable representation of a term SELF as a cons of the list of exponents and the coefficient."
|
---|
615 | (cons (coerce (monom-exponents self) 'list) (->sexp (term-coeff self)))))
|
---|
616 |
|
---|
617 | (defmethod ->sexp :before ((object monom) &optional vars)
|
---|
618 | "Check the length of variables VARS against the length of exponents in OBJECT."
|
---|
619 | (with-slots (exponents)
|
---|
620 | object
|
---|
621 | (assert (= (length vars) (length exponents))
|
---|
622 | nil
|
---|
623 | "Variables ~A and exponents ~A must have the same length." vars exponents)))
|
---|
624 |
|
---|
625 | (defmethod ->sexp ((object monom) &optional vars)
|
---|
626 | "Convert a monomial OBJECT to infix form, using variable VARS to build the representation."
|
---|
627 | (with-slots (exponents)
|
---|
628 | object
|
---|
629 | (let ((m (mapcan #'(lambda (var power)
|
---|
630 | (cond ((= power 0) nil)
|
---|
631 | ((= power 1) (list var))
|
---|
632 | (t (list `(expt ,var ,power)))))
|
---|
633 | vars (coerce exponents 'list))))
|
---|
634 | (cond ((endp m) 1)
|
---|
635 | ((endp (cdr m)) (car m))
|
---|
636 | (t
|
---|
637 | (cons '* m))))))
|
---|
638 |
|
---|
639 | (defmethod ->sexp :around ((object term) &optional vars)
|
---|
640 | "Convert a term OBJECT to S-expression, using variable VARS to build the representation."
|
---|
641 | (declare (ignore vars))
|
---|
642 | (with-slots (coeff)
|
---|
643 | object
|
---|
644 | (let ((monom-sexp (call-next-method))
|
---|
645 | (coeff-sexp (->sexp coeff)))
|
---|
646 | (cond ((eql coeff-sexp 1) monom-sexp)
|
---|
647 | ((atom monom-sexp)
|
---|
648 | (cond ((eql monom-sexp 1) coeff-sexp)
|
---|
649 | (t (list '* coeff-sexp monom-sexp))))
|
---|
650 | ((eql (car monom-sexp) '*)
|
---|
651 | (list* '* coeff-sexp (cdr monom-sexp)))
|
---|
652 | (t
|
---|
653 | (list '* coeff-sexp monom-sexp))))))
|
---|