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 :copy)
|
---|
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-2"
|
---|
37 | "MULTIPLY"
|
---|
38 | "DIVIDES-P"
|
---|
39 | "DIVIDES-LCM-P"
|
---|
40 | "LCM-DIVIDES-LCM-P"
|
---|
41 | "LCM-EQUAL-LCM-P"
|
---|
42 | "DIVISIBLE-BY-P"
|
---|
43 | "REL-PRIME-P"
|
---|
44 | "UNIVERSAL-LCM"
|
---|
45 | "UNIVERSAL-GCD"
|
---|
46 | "DEPENDS-P"
|
---|
47 | "LEFT-TENSOR-PRODUCT-BY"
|
---|
48 | "RIGHT-TENSOR-PRODUCT-BY"
|
---|
49 | "LEFT-CONTRACT"
|
---|
50 | "MAKE-MONOM-VARIABLE"
|
---|
51 | "MAKE-MONOM-CONSTANT"
|
---|
52 | "MAKE-TERM-CONSTANT"
|
---|
53 | "->LIST"
|
---|
54 | "->INFIX"
|
---|
55 | "LEX>"
|
---|
56 | "GRLEX>"
|
---|
57 | "REVLEX>"
|
---|
58 | "GREVLEX>"
|
---|
59 | "INVLEX>"
|
---|
60 | "REVERSE-MONOMIAL-ORDER"
|
---|
61 | "MAKE-ELIMINATION-ORDER-FACTORY"
|
---|
62 | "TERM-COEFF"
|
---|
63 | "UNARY-MINUS"
|
---|
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 | (defgeneric universal-equalp (object1 object2)
|
---|
147 | (:documentation "Returns T iff OBJECT1 and OBJECT2 are equal.")
|
---|
148 | (:method ((object1 cons) (object2 cons)) (every #'universal-equalp object1 object2))
|
---|
149 | (:method ((object1 number) (object2 number)) (= object1 object2))
|
---|
150 | (:method ((m1 monom) (m2 monom))
|
---|
151 | "Returns T iff monomials M1 and M2 have identical EXPONENTS."
|
---|
152 | (equalp (monom-exponents m1) (monom-exponents m2))))
|
---|
153 |
|
---|
154 | (defgeneric monom-elt (m index)
|
---|
155 | (:documentation "Return the power in the monomial M of variable number INDEX.")
|
---|
156 | (:method ((m monom) index)
|
---|
157 | "Return the power in the monomial M of variable number INDEX."
|
---|
158 | (with-slots (exponents)
|
---|
159 | m
|
---|
160 | (elt exponents index))))
|
---|
161 |
|
---|
162 | (defgeneric (setf monom-elt) (new-value m index)
|
---|
163 | (:documentation "Set the power in the monomial M of variable number INDEX.")
|
---|
164 | (:method (new-value (m monom) index)
|
---|
165 | (with-slots (exponents)
|
---|
166 | m
|
---|
167 | (setf (elt exponents index) new-value))))
|
---|
168 |
|
---|
169 | (defgeneric total-degree (m &optional start end)
|
---|
170 | (:documentation "Return the total degree of a monomoal M. Optinally, a range
|
---|
171 | of variables may be specified with arguments START and END.")
|
---|
172 | (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
|
---|
173 | (declare (type fixnum start end))
|
---|
174 | (with-slots (exponents)
|
---|
175 | m
|
---|
176 | (reduce #'+ exponents :start start :end end))))
|
---|
177 |
|
---|
178 | (defgeneric sugar (m &optional start end)
|
---|
179 | (:documentation "Return the sugar of a monomial M. Optinally, a range
|
---|
180 | of variables may be specified with arguments START and END.")
|
---|
181 | (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
|
---|
182 | (declare (type fixnum start end))
|
---|
183 | (total-degree m start end)))
|
---|
184 |
|
---|
185 | (defgeneric multiply-by (self other)
|
---|
186 | (:documentation "Multiply SELF by OTHER, return SELF.")
|
---|
187 | (:method ((self number) (other number)) (* self other))
|
---|
188 | (:method ((self monom) (other monom))
|
---|
189 | (with-slots ((exponents1 exponents))
|
---|
190 | self
|
---|
191 | (with-slots ((exponents2 exponents))
|
---|
192 | other
|
---|
193 | (unless (= (length exponents1) (length exponents2))
|
---|
194 | (error "Incompatible dimensions"))
|
---|
195 | (map-into exponents1 #'+ exponents1 exponents2)))
|
---|
196 | self)
|
---|
197 | (:method ((self number) (other term))
|
---|
198 | (reinitialize-instance other :coeff (multiply self (term-coeff other))))
|
---|
199 | (:method ((self term) (other number))
|
---|
200 | (reinitialize-instance self :coeff (multiply (term-coeff self) other))))
|
---|
201 |
|
---|
202 | (defgeneric divide-by (self other)
|
---|
203 | (:documentation "Divide SELF by OTHER, return SELF.")
|
---|
204 | (:method ((self number) (other number)) (/ self other))
|
---|
205 | (:method ((self monom) (other monom))
|
---|
206 | (with-slots ((exponents1 exponents))
|
---|
207 | self
|
---|
208 | (with-slots ((exponents2 exponents))
|
---|
209 | other
|
---|
210 | (unless (= (length exponents1) (length exponents2))
|
---|
211 | (error "divide-by: Incompatible dimensions."))
|
---|
212 | (unless (every #'>= exponents1 exponents2)
|
---|
213 | (error "divide-by: Negative power would result."))
|
---|
214 | (map-into exponents1 #'- exponents1 exponents2)))
|
---|
215 | self)
|
---|
216 | (:method ((self term) (other number))
|
---|
217 | (reinitialize-instance self :coeff (divide (term-coeff self) other))))
|
---|
218 |
|
---|
219 | (defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
|
---|
220 | "An :AROUND method of COPY-INSTANCE. It replaces
|
---|
221 | exponents with a fresh copy of the sequence."
|
---|
222 | (declare (ignore object initargs))
|
---|
223 | (let ((copy (call-next-method)))
|
---|
224 | (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
|
---|
225 | copy))
|
---|
226 |
|
---|
227 | (defun multiply-2 (object1 object2)
|
---|
228 | "Multiply OBJECT1 by OBJECT2"
|
---|
229 | (multiply-by (copy-instance object1) (copy-instance object2)))
|
---|
230 |
|
---|
231 | (defun multiply (&rest factors)
|
---|
232 | "Non-destructively multiply list FACTORS."
|
---|
233 | (cond ((endp factors) 1)
|
---|
234 | ((endp (rest factors)) (first factors))
|
---|
235 | (t (reduce #'multiply-2 factors :initial-value 1))))
|
---|
236 |
|
---|
237 | (defun divide (numerator &rest denominators)
|
---|
238 | "Non-destructively divide object NUMERATOR by product of DENOMINATORS."
|
---|
239 | (cond ((endp denominators)
|
---|
240 | (divide-by 1 numerator))
|
---|
241 | (t (divide-by (copy-instance numerator) (apply #'multiply denominators)))))
|
---|
242 |
|
---|
243 | (defgeneric divides-p (object1 object2)
|
---|
244 | (:documentation "Returns T if OBJECT1 divides OBJECT2.")
|
---|
245 | (:method ((m1 monom) (m2 monom))
|
---|
246 | "Returns T if monomial M1 divides monomial M2, NIL otherwise."
|
---|
247 | (with-slots ((exponents1 exponents))
|
---|
248 | m1
|
---|
249 | (with-slots ((exponents2 exponents))
|
---|
250 | m2
|
---|
251 | (every #'<= exponents1 exponents2)))))
|
---|
252 |
|
---|
253 | (defgeneric divides-lcm-p (object1 object2 object3)
|
---|
254 | (:documentation "Returns T if OBJECT1 divides LCM(OBJECT2,OBJECT3), NIL otherwise.")
|
---|
255 | (:method ((m1 monom) (m2 monom) (m3 monom))
|
---|
256 | "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
|
---|
257 | (with-slots ((exponents1 exponents))
|
---|
258 | m1
|
---|
259 | (with-slots ((exponents2 exponents))
|
---|
260 | m2
|
---|
261 | (with-slots ((exponents3 exponents))
|
---|
262 | m3
|
---|
263 | (every #'(lambda (x y z) (<= x (max y z)))
|
---|
264 | exponents1 exponents2 exponents3))))))
|
---|
265 |
|
---|
266 | (defgeneric lcm-divides-lcm-p (object1 object2 object3 object4)
|
---|
267 | (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
|
---|
268 | "Returns T if monomial LCM(M1,M2) divides LCM(M3,M4), NIL otherwise."
|
---|
269 | (with-slots ((exponents1 exponents))
|
---|
270 | m1
|
---|
271 | (with-slots ((exponents2 exponents))
|
---|
272 | m2
|
---|
273 | (with-slots ((exponents3 exponents))
|
---|
274 | m3
|
---|
275 | (with-slots ((exponents4 exponents))
|
---|
276 | m4
|
---|
277 | (every #'(lambda (x y z w) (<= (max x y) (max z w)))
|
---|
278 | exponents1 exponents2 exponents3 exponents4)))))))
|
---|
279 |
|
---|
280 | (defgeneric monom-lcm-equal-lcm-p (object1 object2 object3 object4)
|
---|
281 | (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
|
---|
282 | "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
|
---|
283 | (with-slots ((exponents1 exponents))
|
---|
284 | m1
|
---|
285 | (with-slots ((exponents2 exponents))
|
---|
286 | m2
|
---|
287 | (with-slots ((exponents3 exponents))
|
---|
288 | m3
|
---|
289 | (with-slots ((exponents4 exponents))
|
---|
290 | m4
|
---|
291 | (every
|
---|
292 | #'(lambda (x y z w) (= (max x y) (max z w)))
|
---|
293 | exponents1 exponents2 exponents3 exponents4)))))))
|
---|
294 |
|
---|
295 | (defgeneric divisible-by-p (object1 object2)
|
---|
296 | (:documentation "Return T if OBJECT1 is divisible by OBJECT2.")
|
---|
297 | (:method ((m1 monom) (m2 monom))
|
---|
298 | "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
|
---|
299 | (with-slots ((exponents1 exponents))
|
---|
300 | m1
|
---|
301 | (with-slots ((exponents2 exponents))
|
---|
302 | m2
|
---|
303 | (every #'>= exponents1 exponents2)))))
|
---|
304 |
|
---|
305 | (defgeneric rel-prime-p (object1 object2)
|
---|
306 | (:documentation "Returns T if objects OBJECT1 and OBJECT2 are relatively prime.")
|
---|
307 | (:method ((m1 monom) (m2 monom))
|
---|
308 | "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
|
---|
309 | (with-slots ((exponents1 exponents))
|
---|
310 | m1
|
---|
311 | (with-slots ((exponents2 exponents))
|
---|
312 | m2
|
---|
313 | (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2)))))
|
---|
314 |
|
---|
315 | (defgeneric universal-lcm (object1 object2)
|
---|
316 | (:documentation "Returns the multiple of objects OBJECT1 and OBJECT2.")
|
---|
317 | (:method ((m1 monom) (m2 monom))
|
---|
318 | "Returns least common multiple of monomials M1 and M2."
|
---|
319 | (with-slots ((exponents1 exponents))
|
---|
320 | m1
|
---|
321 | (with-slots ((exponents2 exponents))
|
---|
322 | m2
|
---|
323 | (let* ((exponents (copy-seq exponents1)))
|
---|
324 | (map-into exponents #'max exponents1 exponents2)
|
---|
325 | (make-instance 'monom :exponents exponents))))))
|
---|
326 |
|
---|
327 |
|
---|
328 | (defgeneric universal-gcd (object1 object2)
|
---|
329 | (:documentation "Returns GCD of objects OBJECT1 and OBJECT2")
|
---|
330 | (:method ((object1 number) (object2 number)) (gcd object1 object2))
|
---|
331 | (:method ((m1 monom) (m2 monom))
|
---|
332 | "Returns greatest common divisor of monomials M1 and M2."
|
---|
333 | (with-slots ((exponents1 exponents))
|
---|
334 | m1
|
---|
335 | (with-slots ((exponents2 exponents))
|
---|
336 | m2
|
---|
337 | (let* ((exponents (copy-seq exponents1)))
|
---|
338 | (map-into exponents #'min exponents1 exponents2)
|
---|
339 | (make-instance 'monom :exponents exponents))))))
|
---|
340 |
|
---|
341 | (defgeneric depends-p (object k)
|
---|
342 | (:documentation "Returns T iff object OBJECT depends on variable K.")
|
---|
343 | (:method ((m monom) k)
|
---|
344 | "Return T if the monomial M depends on variable number K."
|
---|
345 | (declare (type fixnum k))
|
---|
346 | (with-slots (exponents)
|
---|
347 | m
|
---|
348 | (plusp (elt exponents k)))))
|
---|
349 |
|
---|
350 | (defgeneric left-tensor-product-by (self other)
|
---|
351 | (:documentation "Returns a tensor product SELF by OTHER, stored into
|
---|
352 | SELF. Return SELF.")
|
---|
353 | (:method ((self monom) (other monom))
|
---|
354 | (with-slots ((exponents1 exponents))
|
---|
355 | self
|
---|
356 | (with-slots ((exponents2 exponents))
|
---|
357 | other
|
---|
358 | (setf exponents1 (concatenate 'vector exponents2 exponents1))))
|
---|
359 | self))
|
---|
360 |
|
---|
361 | (defgeneric right-tensor-product-by (self other)
|
---|
362 | (:documentation "Returns a tensor product of OTHER by SELF, stored
|
---|
363 | into SELF. Returns SELF.")
|
---|
364 | (:method ((self monom) (other monom))
|
---|
365 | (with-slots ((exponents1 exponents))
|
---|
366 | self
|
---|
367 | (with-slots ((exponents2 exponents))
|
---|
368 | other
|
---|
369 | (setf exponents1 (concatenate 'vector exponents1 exponents2))))
|
---|
370 | self))
|
---|
371 |
|
---|
372 | (defgeneric left-contract (self k)
|
---|
373 | (:documentation "Drop the first K variables in object SELF.")
|
---|
374 | (:method ((self monom) k)
|
---|
375 | "Drop the first K variables in monomial M."
|
---|
376 | (declare (fixnum k))
|
---|
377 | (with-slots (exponents)
|
---|
378 | self
|
---|
379 | (setf exponents (subseq exponents k)))
|
---|
380 | self))
|
---|
381 |
|
---|
382 | (defun make-monom-variable (nvars pos &optional (power 1)
|
---|
383 | &aux (m (make-instance 'monom :dimension nvars)))
|
---|
384 | "Construct a monomial in the polynomial ring
|
---|
385 | RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
|
---|
386 | which represents a single variable. It assumes number of variables
|
---|
387 | NVARS and the variable is at position POS. Optionally, the variable
|
---|
388 | may appear raised to power POWER. "
|
---|
389 | (declare (type fixnum nvars pos power) (type monom m))
|
---|
390 | (with-slots (exponents)
|
---|
391 | m
|
---|
392 | (setf (elt exponents pos) power)
|
---|
393 | m))
|
---|
394 |
|
---|
395 | (defun make-monom-constant (dimension)
|
---|
396 | (make-instance 'monom :dimension dimension))
|
---|
397 |
|
---|
398 | ;; pure lexicographic
|
---|
399 | (defgeneric lex> (p q &optional start end)
|
---|
400 | (:documentation "Return T if P>Q with respect to lexicographic
|
---|
401 | order, otherwise NIL. The second returned value is T if P=Q,
|
---|
402 | otherwise it is NIL.")
|
---|
403 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
404 | (declare (type fixnum start end))
|
---|
405 | (do ((i start (1+ i)))
|
---|
406 | ((>= i end) (values nil t))
|
---|
407 | (cond
|
---|
408 | ((> (monom-elt p i) (monom-elt q i))
|
---|
409 | (return-from lex> (values t nil)))
|
---|
410 | ((< (monom-elt p i) (monom-elt q i))
|
---|
411 | (return-from lex> (values nil nil)))))))
|
---|
412 |
|
---|
413 | ;; total degree order, ties broken by lexicographic
|
---|
414 | (defgeneric grlex> (p q &optional start end)
|
---|
415 | (:documentation "Return T if P>Q with respect to graded
|
---|
416 | lexicographic order, otherwise NIL. The second returned value is T if
|
---|
417 | P=Q, otherwise it is NIL.")
|
---|
418 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
419 | (declare (type monom p q) (type fixnum start end))
|
---|
420 | (let ((d1 (total-degree p start end))
|
---|
421 | (d2 (total-degree q start end)))
|
---|
422 | (declare (type fixnum d1 d2))
|
---|
423 | (cond
|
---|
424 | ((> d1 d2) (values t nil))
|
---|
425 | ((< d1 d2) (values nil nil))
|
---|
426 | (t
|
---|
427 | (lex> p q start end))))))
|
---|
428 |
|
---|
429 | ;; reverse lexicographic
|
---|
430 | (defgeneric revlex> (p q &optional start end)
|
---|
431 | (:documentation "Return T if P>Q with respect to reverse
|
---|
432 | lexicographic order, NIL otherwise. The second returned value is T if
|
---|
433 | P=Q, otherwise it is NIL. This is not and admissible monomial order
|
---|
434 | because some sets do not have a minimal element. This order is useful
|
---|
435 | in constructing other orders.")
|
---|
436 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
437 | (declare (type fixnum start end))
|
---|
438 | (do ((i (1- end) (1- i)))
|
---|
439 | ((< i start) (values nil t))
|
---|
440 | (declare (type fixnum i))
|
---|
441 | (cond
|
---|
442 | ((< (monom-elt p i) (monom-elt q i))
|
---|
443 | (return-from revlex> (values t nil)))
|
---|
444 | ((> (monom-elt p i) (monom-elt q i))
|
---|
445 | (return-from revlex> (values nil nil)))))))
|
---|
446 |
|
---|
447 |
|
---|
448 | ;; total degree, ties broken by reverse lexicographic
|
---|
449 | (defgeneric grevlex> (p q &optional start end)
|
---|
450 | (:documentation "Return T if P>Q with respect to graded reverse
|
---|
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 | (let ((d1 (total-degree p start end))
|
---|
456 | (d2 (total-degree q start end)))
|
---|
457 | (declare (type fixnum d1 d2))
|
---|
458 | (cond
|
---|
459 | ((> d1 d2) (values t nil))
|
---|
460 | ((< d1 d2) (values nil nil))
|
---|
461 | (t
|
---|
462 | (revlex> p q start end))))))
|
---|
463 |
|
---|
464 | (defgeneric invlex> (p q &optional start end)
|
---|
465 | (:documentation "Return T if P>Q with respect to inverse
|
---|
466 | lexicographic order, NIL otherwise The second returned value is T if
|
---|
467 | P=Q, otherwise it is NIL.")
|
---|
468 | (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
|
---|
469 | (declare (type fixnum start end))
|
---|
470 | (do ((i (1- end) (1- i)))
|
---|
471 | ((< i start) (values nil t))
|
---|
472 | (declare (type fixnum i))
|
---|
473 | (cond
|
---|
474 | ((> (monom-elt p i) (monom-elt q i))
|
---|
475 | (return-from invlex> (values t nil)))
|
---|
476 | ((< (monom-elt p i) (monom-elt q i))
|
---|
477 | (return-from invlex> (values nil nil)))))))
|
---|
478 |
|
---|
479 | (defun reverse-monomial-order (order)
|
---|
480 | "Create the inverse monomial order to the given monomial order ORDER."
|
---|
481 | #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
|
---|
482 | (declare (type monom p q) (type fixnum start end))
|
---|
483 | (funcall order q p start end)))
|
---|
484 |
|
---|
485 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
486 | ;;
|
---|
487 | ;; Order making functions
|
---|
488 | ;;
|
---|
489 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
490 |
|
---|
491 | ;; This returns a closure with the same signature
|
---|
492 | ;; as all orders such as #'LEX>.
|
---|
493 | (defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
|
---|
494 | "It constructs an elimination order used for the 1-st elimination ideal,
|
---|
495 | i.e. for eliminating the first variable. Thus, the order compares the degrees of the
|
---|
496 | first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
|
---|
497 | #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
|
---|
498 | (declare (type monom p q) (type fixnum start end))
|
---|
499 | (cond
|
---|
500 | ((> (monom-elt p start) (monom-elt q start))
|
---|
501 | (values t nil))
|
---|
502 | ((< (monom-elt p start) (monom-elt q start))
|
---|
503 | (values nil nil))
|
---|
504 | (t
|
---|
505 | (funcall secondary-elimination-order p q (1+ start) end)))))
|
---|
506 |
|
---|
507 | ;; This returns a closure which is called with an integer argument.
|
---|
508 | ;; The result is *another closure* with the same signature as all
|
---|
509 | ;; orders such as #'LEX>.
|
---|
510 | (defun make-elimination-order-factory (&optional
|
---|
511 | (primary-elimination-order #'lex>)
|
---|
512 | (secondary-elimination-order #'lex>))
|
---|
513 | "Return a function with a single integer argument K. This should be
|
---|
514 | the number of initial K variables X[0],X[1],...,X[K-1], which precede
|
---|
515 | remaining variables. The call to the closure creates a predicate
|
---|
516 | which compares monomials according to the K-th elimination order. The
|
---|
517 | monomial orders PRIMARY-ELIMINATION-ORDER and
|
---|
518 | SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
|
---|
519 | remaining variables, respectively, with ties broken by lexicographical
|
---|
520 | order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
|
---|
521 | which indicates that the first K variables appear with identical
|
---|
522 | powers, then the result is that of a call to
|
---|
523 | SECONDARY-ELIMINATION-ORDER applied to the remaining variables
|
---|
524 | X[K],X[K+1],..."
|
---|
525 | #'(lambda (k)
|
---|
526 | (cond
|
---|
527 | ((<= k 0)
|
---|
528 | (error "K must be at least 1"))
|
---|
529 | ((= k 1)
|
---|
530 | (make-elimination-order-factory-1 secondary-elimination-order))
|
---|
531 | (t
|
---|
532 | #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
|
---|
533 | (declare (type monom p q) (type fixnum start end))
|
---|
534 | (multiple-value-bind (primary equal)
|
---|
535 | (funcall primary-elimination-order p q start k)
|
---|
536 | (if equal
|
---|
537 | (funcall secondary-elimination-order p q k end)
|
---|
538 | (values primary nil))))))))
|
---|
539 |
|
---|
540 | (defclass term (monom)
|
---|
541 | ((coeff :initarg :coeff :accessor term-coeff))
|
---|
542 | (:default-initargs :coeff nil)
|
---|
543 | (:documentation "Implements a term, i.e. a product of a scalar
|
---|
544 | and powers of some variables, such as 5*X^2*Y^3."))
|
---|
545 |
|
---|
546 | (defmethod update-instance-for-different-class ((old monom) (new term) &key (coeff 1))
|
---|
547 | "Converts OLD of class MONOM to a NEW of class TERM, initializing coefficient to COEFF."
|
---|
548 | (reinitialize-instance new :coeff coeff))
|
---|
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 | (defun make-term-constant (dimension &optional (coeff 1))
|
---|
559 | (make-instance 'term :dimension dimension :coeff coeff))
|
---|
560 |
|
---|
561 | (defmethod universal-equalp ((term1 term) (term2 term))
|
---|
562 | "Returns T if TERM1 and TERM2 are equal as MONOM, and coefficients
|
---|
563 | are UNIVERSAL-EQUALP."
|
---|
564 | (and (call-next-method)
|
---|
565 | (universal-equalp (term-coeff term1) (term-coeff term2))))
|
---|
566 |
|
---|
567 | (defmethod update-instance-for-different-class :after ((old monom) (new term) &key)
|
---|
568 | (setf (term-coeff new) 1))
|
---|
569 |
|
---|
570 | (defmethod multiply-by :before ((self term) (other term))
|
---|
571 | "Destructively multiply terms SELF and OTHER and store the result into SELF.
|
---|
572 | It returns SELF."
|
---|
573 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
574 |
|
---|
575 | (defmethod left-tensor-product-by :before ((self term) (other term))
|
---|
576 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
577 |
|
---|
578 | (defmethod right-tensor-product-by :before ((self term) (other term))
|
---|
579 | (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
|
---|
580 |
|
---|
581 | (defmethod divide-by :before ((self term) (other term))
|
---|
582 | (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other))))
|
---|
583 |
|
---|
584 | (defgeneric unary-minus (self)
|
---|
585 | (:documentation "Negate object SELF and return it.")
|
---|
586 | (:method ((self number)) (- self))
|
---|
587 | (:method ((self term))
|
---|
588 | (setf (term-coeff self) (unary-minus (term-coeff self)))
|
---|
589 | self))
|
---|
590 |
|
---|
591 | (defgeneric universal-zerop (self)
|
---|
592 | (:documentation "Return T iff SELF is zero.")
|
---|
593 | (:method ((self number)) (zerop self))
|
---|
594 | (:method ((self term))
|
---|
595 | (universal-zerop (term-coeff self))))
|
---|
596 |
|
---|
597 | (defgeneric ->list (self)
|
---|
598 | (:method ((self monom))
|
---|
599 | "A human-readable representation of a monomial SELF as a list of exponents."
|
---|
600 | (coerce (monom-exponents self) 'list))
|
---|
601 | (:method ((self term))
|
---|
602 | "A human-readable representation of a term SELF as a cons of the list of exponents and the coefficient."
|
---|
603 | (cons (coerce (monom-exponents self) 'list) (term-coeff self))))
|
---|
604 |
|
---|
605 | (defgeneric ->infix (self &optional vars)
|
---|
606 | (:method ((self monom) &optional vars)
|
---|
607 | (with-slots (exponents dimension)
|
---|
608 | (makelist-1 (exp (elt i vars) ( elt i exponents)) i 0 dimension))))
|
---|