close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/monom.lisp@ 3500

Last change on this file since 3500 was 3487, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 17.2 KB
Line 
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 "EXPONENT"
26 "MONOM-DIMENSION"
27 "MONOM-EXPONENTS"
28 "MONOM-EQUALP"
29 "MONOM-ELT"
30 "MONOM-TOTAL-DEGREE"
31 "MONOM-SUGAR"
32 "MONOM-MULTIPLY-BY"
33 "MONOM-DIVIDE-BY"
34 "MONOM-COPY-INSTANCE"
35 "MONOM-MULTIPLY-2"
36 "MONOM-MULTIPLY"
37 "MONOM-DIVIDES-P"
38 "MONOM-DIVIDES-LCM-P"
39 "MONOM-LCM-DIVIDES-LCM-P"
40 "MONOM-LCM-EQUAL-LCM-P"
41 "MONOM-DIVISIBLE-BY-P"
42 "MONOM-REL-PRIME-P"
43 "MONOM-LCM"
44 "MONOM-GCD"
45 "MONOM-DEPENDS-P"
46 "MONOM-LEFT-TENSOR-PRODUCT-BY"
47 "MONOM-RIGHT-TENSOR-PRODUCT-BY"
48 "MONOM-LEFT-CONTRACT"
49 "MAKE-MONOM-VARIABLE"
50 "MONOM->LIST"
51 "LEX>"
52 "GRLEX>"
53 "REVLEX>"
54 "GREVLEX>"
55 "INVLEX>"
56 "REVERSE-MONOMIAL-ORDER"
57 "MAKE-ELIMINATION-ORDER-FACTORY")
58 (:documentation
59 "This package implements basic operations on monomials, including
60various monomial orders.
61
62DATA STRUCTURES: Conceptually, monomials can be represented as lists:
63
64 monom: (n1 n2 ... nk) where ni are non-negative integers
65
66However, lists may be implemented as other sequence types, so the
67flexibility to change the representation should be maintained in the
68code to use general operations on sequences whenever possible. The
69optimization for the actual representation should be left to
70declarations and the compiler.
71
72EXAMPLES: Suppose that variables are x and y. Then
73
74 Monom x*y^2 ---> (1 2) "))
75
76(in-package :monom)
77
78(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
79
80(deftype exponent ()
81 "Type of exponent in a monomial."
82 'fixnum)
83
84(defclass monom ()
85 ((exponents :initarg :exponents :accessor monom-exponents
86 :documentation "The powers of the variables."))
87 ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
88 ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
89 (:documentation
90 "Implements a monomial, i.e. a product of powers
91of variables, like X*Y^2."))
92
93(defmethod print-object ((self monom) stream)
94 (print-unreadable-object (self stream :type t :identity t)
95 (with-accessors ((exponents monom-exponents))
96 self
97 (format stream "EXPONENTS=~A"
98 exponents))))
99
100(defmethod initialize-instance :after ((self monom)
101 &key
102 (dimension 0 dimension-supplied-p)
103 (exponents nil exponents-supplied-p)
104 (exponent 0)
105 &allow-other-keys
106 )
107 "The following INITIALIZE-INSTANCE method allows instance initialization
108of a MONOM in a style similar to MAKE-ARRAY, e.g.:
109
110 (MAKE-INSTANCE :EXPONENTS '(1 2 3)) --> #<MONOM EXPONENTS=#(1 2 3)>
111 (MAKE-INSTANCE :DIMENSION 3) --> #<MONOM EXPONENTS=#(0 0 0)>
112 (MAKE-INSTANCE :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>
113
114If both DIMENSION and EXPONENTS are supplied, they must be compatible,
115i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS
116is not supplied, a monom with repeated value EXPONENT is created.
117By default EXPONENT is 0, which results in a constant monomial.
118"
119 (cond
120 (exponents-supplied-p
121 (when (and dimension-supplied-p
122 (/= dimension (length exponents)))
123 (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"
124 exponents dimension))
125 (let ((dim (length exponents)))
126 (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))
127 (dimension-supplied-p
128 ;; when all exponents are to be identical
129 (setf (slot-value self 'exponents) (make-array (list dimension)
130 :initial-element exponent
131 :element-type 'exponent)))
132 (t
133 (error "Initarg DIMENSION or EXPONENTS must be supplied."))))
134
135(defgeneric monom-dimension (m)
136 (:method ((m monom))
137 (length (monom-exponents m))))
138
139(defgeneric monom-equalp (m1 m2)
140 (:documentation "Returns T iff monomials M1 and M2 have identical EXPONENTS.")
141 (:method ((m1 monom) (m2 monom))
142 `(equalp (monom-exponents ,m1) (monom-exponents ,m2))))
143
144(defgeneric monom-elt (m index)
145 (:documentation
146 "Return the power in the monomial M of variable number INDEX.")
147 (:method ((m monom) index)
148 (with-slots (exponents)
149 m
150 (elt exponents index))))
151
152(defgeneric (setf monom-elt) (new-value m index)
153 (:documentation "Return the power in the monomial M of variable number INDEX.")
154 (:method (new-value (m monom) index)
155 (with-slots (exponents)
156 m
157 (setf (elt exponents index) new-value))))
158
159(defgeneric monom-total-degree (m &optional start end)
160 (:documentation "Return the todal degree of a monomoal M. Optinally, a range
161of variables may be specified with arguments START and END.")
162 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
163 (declare (type fixnum start end))
164 (with-slots (exponents)
165 m
166 (reduce #'+ exponents :start start :end end))))
167
168(defgeneric monom-sugar (m &optional start end)
169 (:documentation "Return the sugar of a monomial M. Optinally, a range
170of variables may be specified with arguments START and END.")
171 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
172 (declare (type fixnum start end))
173 (monom-total-degree m start end)))
174
175(defgeneric monom-multiply-by (self other)
176 (:method ((self monom) (other monom))
177 (with-slots ((exponents1 exponents))
178 self
179 (with-slots ((exponents2 exponents))
180 other
181 (unless (= (length exponents1) (length exponents2))
182 (error "Incompatible dimensions"))
183 (map-into exponents1 #'+ exponents1 exponents2)))
184 self))
185
186(defgeneric monom-divide-by (self other)
187 (:method ((self monom) (other monom))
188 (with-slots ((exponents1 exponents))
189 self
190 (with-slots ((exponents2 exponents))
191 other
192 (unless (= (length exponents1) (length exponents2))
193 (error "divide-by: Incompatible dimensions."))
194 (unless (every #'>= exponents1 exponents2)
195 (error "divide-by: Negative power would result."))
196 (map-into exponents1 #'- exponents1 exponents2)))
197 self))
198
199(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
200 "An :AROUND method of COPY-INSTANCE. It replaces
201exponents with a fresh copy of the sequence."
202 (declare (ignore object initargs))
203 (let ((copy (call-next-method)))
204 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
205 copy))
206
207(defmethod monom-multiply-2 ((m1 monom) (m2 monom))
208 "Non-destructively multiply monomial M1 by M2."
209 (monom-multiply-by (copy-instance m1) (copy-instance m2)))
210
211(defmethod monom-multiply ((numerator monom) &rest denominators)
212 "Non-destructively divide monomial NUMERATOR by product of DENOMINATORS."
213 (monom-divide-by (copy-instance numerator) (reduce #'monom-multiply-2 denominators)))
214
215(defmethod monom-divides-p ((m1 monom) (m2 monom))
216 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
217 (with-slots ((exponents1 exponents))
218 m1
219 (with-slots ((exponents2 exponents))
220 m2
221 (every #'<= exponents1 exponents2))))
222
223
224(defmethod monom-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom))
225 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
226 (every #'(lambda (x y z) (<= x (max y z)))
227 m1 m2 m3))
228
229
230(defmethod monom-lcm-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
231 "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
232 (declare (type monom m1 m2 m3 m4))
233 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
234 m1 m2 m3 m4))
235
236(defmethod monom-lcm-equal-lcm-p (m1 m2 m3 m4)
237 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
238 (with-slots ((exponents1 exponents))
239 m1
240 (with-slots ((exponents2 exponents))
241 m2
242 (with-slots ((exponents3 exponents))
243 m3
244 (with-slots ((exponents4 exponents))
245 m4
246 (every
247 #'(lambda (x y z w) (= (max x y) (max z w)))
248 exponents1 exponents2 exponents3 exponents4))))))
249
250(defmethod monom-divisible-by-p ((m1 monom) (m2 monom))
251 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
252 (with-slots ((exponents1 exponents))
253 m1
254 (with-slots ((exponents2 exponents))
255 m2
256 (every #'>= exponents1 exponents2))))
257
258(defmethod monom-rel-prime-p ((m1 monom) (m2 monom))
259 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
260 (with-slots ((exponents1 exponents))
261 m1
262 (with-slots ((exponents2 exponents))
263 m2
264 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2))))
265
266
267(defmethod monom-lcm ((m1 monom) (m2 monom))
268 "Returns least common multiple of monomials M1 and M2."
269 (with-slots ((exponents1 exponents))
270 m1
271 (with-slots ((exponents2 exponents))
272 m2
273 (let* ((exponents (copy-seq exponents1)))
274 (map-into exponents #'max exponents1 exponents2)
275 (make-instance 'monom :exponents exponents)))))
276
277
278(defmethod monom-gcd ((m1 monom) (m2 monom))
279 "Returns greatest common divisor of monomials M1 and M2."
280 (with-slots ((exponents1 exponents))
281 m1
282 (with-slots ((exponents2 exponents))
283 m2
284 (let* ((exponents (copy-seq exponents1)))
285 (map-into exponents #'min exponents1 exponents2)
286 (make-instance 'monom :exponents exponents)))))
287
288(defmethod monom-depends-p ((m monom) k)
289 "Return T if the monomial M depends on variable number K."
290 (declare (type fixnum k))
291 (with-slots (exponents)
292 m
293 (plusp (elt exponents k))))
294
295(defmethod monom-left-tensor-product-by ((self monom) (other monom))
296 (with-slots ((exponents1 exponents))
297 self
298 (with-slots ((exponents2 exponents))
299 other
300 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
301 self)
302
303(defmethod monom-right-tensor-product-by ((self monom) (other monom))
304 (with-slots ((exponents1 exponents))
305 self
306 (with-slots ((exponents2 exponents))
307 other
308 (setf exponents1 (concatenate 'vector exponents1 exponents2))))
309 self)
310
311(defmethod monom-left-contract ((self monom) k)
312 "Drop the first K variables in monomial M."
313 (declare (fixnum k))
314 (with-slots (exponents)
315 self
316 (setf exponents (subseq exponents k)))
317 self)
318
319(defun make-monom-variable (nvars pos &optional (power 1)
320 &aux (m (make-instance 'monom :dimension nvars)))
321 "Construct a monomial in the polynomial ring
322RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
323which represents a single variable. It assumes number of variables
324NVARS and the variable is at position POS. Optionally, the variable
325may appear raised to power POWER. "
326 (declare (type fixnum nvars pos power) (type monom m))
327 (with-slots (exponents)
328 m
329 (setf (elt exponents pos) power)
330 m))
331
332(defmethod monom->list ((m monom))
333 "A human-readable representation of a monomial M as a list of exponents."
334 (coerce (monom-exponents m) 'list))
335
336
337;; pure lexicographic
338(defgeneric lex> (p q &optional start end)
339 (:documentation "Return T if P>Q with respect to lexicographic
340order, otherwise NIL. The second returned value is T if P=Q,
341otherwise it is NIL.")
342 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
343 (declare (type fixnum start end))
344 (do ((i start (1+ i)))
345 ((>= i end) (values nil t))
346 (cond
347 ((> (monom-elt p i) (monom-elt q i))
348 (return-from lex> (values t nil)))
349 ((< (monom-elt p i) (monom-elt q i))
350 (return-from lex> (values nil nil)))))))
351
352;; total degree order, ties broken by lexicographic
353(defgeneric grlex> (p q &optional start end)
354 (:documentation "Return T if P>Q with respect to graded
355lexicographic order, otherwise NIL. The second returned value is T if
356P=Q, otherwise it is NIL.")
357 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
358 (declare (type monom p q) (type fixnum start end))
359 (let ((d1 (monom-total-degree p start end))
360 (d2 (monom-total-degree q start end)))
361 (declare (type fixnum d1 d2))
362 (cond
363 ((> d1 d2) (values t nil))
364 ((< d1 d2) (values nil nil))
365 (t
366 (lex> p q start end))))))
367
368;; reverse lexicographic
369(defgeneric revlex> (p q &optional start end)
370 (:documentation "Return T if P>Q with respect to reverse
371lexicographic order, NIL otherwise. The second returned value is T if
372P=Q, otherwise it is NIL. This is not and admissible monomial order
373because some sets do not have a minimal element. This order is useful
374in constructing other orders.")
375 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
376 (declare (type fixnum start end))
377 (do ((i (1- end) (1- i)))
378 ((< i start) (values nil t))
379 (declare (type fixnum i))
380 (cond
381 ((< (monom-elt p i) (monom-elt q i))
382 (return-from revlex> (values t nil)))
383 ((> (monom-elt p i) (monom-elt q i))
384 (return-from revlex> (values nil nil)))))))
385
386
387;; total degree, ties broken by reverse lexicographic
388(defgeneric grevlex> (p q &optional start end)
389 (:documentation "Return T if P>Q with respect to graded reverse
390lexicographic order, NIL otherwise. The second returned value is T if
391P=Q, otherwise it is NIL.")
392 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
393 (declare (type fixnum start end))
394 (let ((d1 (monom-total-degree p start end))
395 (d2 (monom-total-degree q start end)))
396 (declare (type fixnum d1 d2))
397 (cond
398 ((> d1 d2) (values t nil))
399 ((< d1 d2) (values nil nil))
400 (t
401 (revlex> p q start end))))))
402
403(defgeneric invlex> (p q &optional start end)
404 (:documentation "Return T if P>Q with respect to inverse
405lexicographic order, NIL otherwise The second returned value is T if
406P=Q, otherwise it is NIL.")
407 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
408 (declare (type fixnum start end))
409 (do ((i (1- end) (1- i)))
410 ((< i start) (values nil t))
411 (declare (type fixnum i))
412 (cond
413 ((> (monom-elt p i) (monom-elt q i))
414 (return-from invlex> (values t nil)))
415 ((< (monom-elt p i) (monom-elt q i))
416 (return-from invlex> (values nil nil)))))))
417
418(defun reverse-monomial-order (order)
419 "Create the inverse monomial order to the given monomial order ORDER."
420 #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
421 (declare (type monom p q) (type fixnum start end))
422 (funcall order q p start end)))
423
424;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
425;;
426;; Order making functions
427;;
428;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
429
430;; This returns a closure with the same signature
431;; as all orders such as #'LEX>.
432(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
433 "It constructs an elimination order used for the 1-st elimination ideal,
434i.e. for eliminating the first variable. Thus, the order compares the degrees of the
435first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
436 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
437 (declare (type monom p q) (type fixnum start end))
438 (cond
439 ((> (monom-elt p start) (monom-elt q start))
440 (values t nil))
441 ((< (monom-elt p start) (monom-elt q start))
442 (values nil nil))
443 (t
444 (funcall secondary-elimination-order p q (1+ start) end)))))
445
446;; This returns a closure which is called with an integer argument.
447;; The result is *another closure* with the same signature as all
448;; orders such as #'LEX>.
449(defun make-elimination-order-factory (&optional
450 (primary-elimination-order #'lex>)
451 (secondary-elimination-order #'lex>))
452 "Return a function with a single integer argument K. This should be
453the number of initial K variables X[0],X[1],...,X[K-1], which precede
454remaining variables. The call to the closure creates a predicate
455which compares monomials according to the K-th elimination order. The
456monomial orders PRIMARY-ELIMINATION-ORDER and
457SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
458remaining variables, respectively, with ties broken by lexicographical
459order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
460which indicates that the first K variables appear with identical
461powers, then the result is that of a call to
462SECONDARY-ELIMINATION-ORDER applied to the remaining variables
463X[K],X[K+1],..."
464 #'(lambda (k)
465 (cond
466 ((<= k 0)
467 (error "K must be at least 1"))
468 ((= k 1)
469 (make-elimination-order-factory-1 secondary-elimination-order))
470 (t
471 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
472 (declare (type monom p q) (type fixnum start end))
473 (multiple-value-bind (primary equal)
474 (funcall primary-elimination-order p q start k)
475 (if equal
476 (funcall secondary-elimination-order p q k end)
477 (values primary nil))))))))
478
Note: See TracBrowser for help on using the repository browser.