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@ 3541

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

* empty log message *

File size: 19.4 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 universal-equalp (object1 object2)
140 (:documentation "Returns T iff OBJECT1 and OBJECT2 are equal.")
141 (:method ((m1 monom) (m2 monom))
142 "Returns T iff monomials M1 and M2 have identical EXPONENTS."
143 (equalp (monom-exponents m1) (monom-exponents m2))))
144
145(defgeneric monom-elt (m index)
146 (:documentation
147 "Return the power in the monomial M of variable number INDEX.")
148 (:method ((m monom) index)
149 (with-slots (exponents)
150 m
151 (elt exponents index))))
152
153(defgeneric (setf monom-elt) (new-value m index)
154 (:documentation "Return the power in the monomial M of variable number INDEX.")
155 (:method (new-value (m monom) index)
156 (with-slots (exponents)
157 m
158 (setf (elt exponents index) new-value))))
159
160(defgeneric monom-total-degree (m &optional start end)
161 (:documentation "Return the todal degree of a monomoal M. Optinally, a range
162of variables may be specified with arguments START and END.")
163 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
164 (declare (type fixnum start end))
165 (with-slots (exponents)
166 m
167 (reduce #'+ exponents :start start :end end))))
168
169(defgeneric monom-sugar (m &optional start end)
170 (:documentation "Return the sugar of a monomial M. Optinally, a range
171of 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 (monom-total-degree m start end)))
175
176(defgeneric monom-multiply-by (self other)
177 (:method ((self monom) (other monom))
178 (with-slots ((exponents1 exponents))
179 self
180 (with-slots ((exponents2 exponents))
181 other
182 (unless (= (length exponents1) (length exponents2))
183 (error "Incompatible dimensions"))
184 (map-into exponents1 #'+ exponents1 exponents2)))
185 self))
186
187(defgeneric monom-divide-by (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 "divide-by: Incompatible dimensions."))
195 (unless (every #'>= exponents1 exponents2)
196 (error "divide-by: Negative power would result."))
197 (map-into exponents1 #'- exponents1 exponents2)))
198 self))
199
200(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
201 "An :AROUND method of COPY-INSTANCE. It replaces
202exponents with a fresh copy of the sequence."
203 (declare (ignore object initargs))
204 (let ((copy (call-next-method)))
205 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
206 copy))
207
208(defmethod monom-multiply-2 ((m1 monom) (m2 monom))
209 "Non-destructively multiply monomial M1 by M2."
210 (monom-multiply-by (copy-instance m1) (copy-instance m2)))
211
212(defmethod monom-multiply ((numerator monom) &rest denominators)
213 "Non-destructively divide monomial NUMERATOR by product of DENOMINATORS."
214 (monom-divide-by (copy-instance numerator) (reduce #'monom-multiply-2 denominators)))
215
216(defmethod monom-divides-p ((m1 monom) (m2 monom))
217 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
218 (with-slots ((exponents1 exponents))
219 m1
220 (with-slots ((exponents2 exponents))
221 m2
222 (every #'<= exponents1 exponents2))))
223
224
225(defmethod monom-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom))
226 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
227 (every #'(lambda (x y z) (<= x (max y z)))
228 m1 m2 m3))
229
230
231(defmethod monom-lcm-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
232 "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
233 (declare (type monom m1 m2 m3 m4))
234 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
235 m1 m2 m3 m4))
236
237(defmethod monom-lcm-equal-lcm-p (m1 m2 m3 m4)
238 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
239 (with-slots ((exponents1 exponents))
240 m1
241 (with-slots ((exponents2 exponents))
242 m2
243 (with-slots ((exponents3 exponents))
244 m3
245 (with-slots ((exponents4 exponents))
246 m4
247 (every
248 #'(lambda (x y z w) (= (max x y) (max z w)))
249 exponents1 exponents2 exponents3 exponents4))))))
250
251(defmethod monom-divisible-by-p ((m1 monom) (m2 monom))
252 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
253 (with-slots ((exponents1 exponents))
254 m1
255 (with-slots ((exponents2 exponents))
256 m2
257 (every #'>= exponents1 exponents2))))
258
259(defmethod monom-rel-prime-p ((m1 monom) (m2 monom))
260 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
261 (with-slots ((exponents1 exponents))
262 m1
263 (with-slots ((exponents2 exponents))
264 m2
265 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2))))
266
267
268(defmethod monom-lcm ((m1 monom) (m2 monom))
269 "Returns least common multiple of monomials M1 and M2."
270 (with-slots ((exponents1 exponents))
271 m1
272 (with-slots ((exponents2 exponents))
273 m2
274 (let* ((exponents (copy-seq exponents1)))
275 (map-into exponents #'max exponents1 exponents2)
276 (make-instance 'monom :exponents exponents)))))
277
278
279(defmethod monom-gcd ((m1 monom) (m2 monom))
280 "Returns greatest common divisor of monomials M1 and M2."
281 (with-slots ((exponents1 exponents))
282 m1
283 (with-slots ((exponents2 exponents))
284 m2
285 (let* ((exponents (copy-seq exponents1)))
286 (map-into exponents #'min exponents1 exponents2)
287 (make-instance 'monom :exponents exponents)))))
288
289(defmethod monom-depends-p ((m monom) k)
290 "Return T if the monomial M depends on variable number K."
291 (declare (type fixnum k))
292 (with-slots (exponents)
293 m
294 (plusp (elt exponents k))))
295
296(defmethod monom-left-tensor-product-by ((self monom) (other monom))
297 (with-slots ((exponents1 exponents))
298 self
299 (with-slots ((exponents2 exponents))
300 other
301 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
302 self)
303
304(defmethod monom-right-tensor-product-by ((self monom) (other monom))
305 (with-slots ((exponents1 exponents))
306 self
307 (with-slots ((exponents2 exponents))
308 other
309 (setf exponents1 (concatenate 'vector exponents1 exponents2))))
310 self)
311
312(defmethod monom-left-contract ((self monom) k)
313 "Drop the first K variables in monomial M."
314 (declare (fixnum k))
315 (with-slots (exponents)
316 self
317 (setf exponents (subseq exponents k)))
318 self)
319
320(defun make-monom-variable (nvars pos &optional (power 1)
321 &aux (m (make-instance 'monom :dimension nvars)))
322 "Construct a monomial in the polynomial ring
323RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
324which represents a single variable. It assumes number of variables
325NVARS and the variable is at position POS. Optionally, the variable
326may appear raised to power POWER. "
327 (declare (type fixnum nvars pos power) (type monom m))
328 (with-slots (exponents)
329 m
330 (setf (elt exponents pos) power)
331 m))
332
333(defmethod monom->list ((m monom))
334 "A human-readable representation of a monomial M as a list of exponents."
335 (coerce (monom-exponents m) 'list))
336
337
338;; pure lexicographic
339(defgeneric lex> (p q &optional start end)
340 (:documentation "Return T if P>Q with respect to lexicographic
341order, otherwise NIL. The second returned value is T if P=Q,
342otherwise it is NIL.")
343 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
344 (declare (type fixnum start end))
345 (do ((i start (1+ i)))
346 ((>= i end) (values nil t))
347 (cond
348 ((> (monom-elt p i) (monom-elt q i))
349 (return-from lex> (values t nil)))
350 ((< (monom-elt p i) (monom-elt q i))
351 (return-from lex> (values nil nil)))))))
352
353;; total degree order, ties broken by lexicographic
354(defgeneric grlex> (p q &optional start end)
355 (:documentation "Return T if P>Q with respect to graded
356lexicographic order, otherwise NIL. The second returned value is T if
357P=Q, otherwise it is NIL.")
358 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
359 (declare (type monom p q) (type fixnum start end))
360 (let ((d1 (monom-total-degree p start end))
361 (d2 (monom-total-degree q start end)))
362 (declare (type fixnum d1 d2))
363 (cond
364 ((> d1 d2) (values t nil))
365 ((< d1 d2) (values nil nil))
366 (t
367 (lex> p q start end))))))
368
369;; reverse lexicographic
370(defgeneric revlex> (p q &optional start end)
371 (:documentation "Return T if P>Q with respect to reverse
372lexicographic order, NIL otherwise. The second returned value is T if
373P=Q, otherwise it is NIL. This is not and admissible monomial order
374because some sets do not have a minimal element. This order is useful
375in constructing other orders.")
376 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
377 (declare (type fixnum start end))
378 (do ((i (1- end) (1- i)))
379 ((< i start) (values nil t))
380 (declare (type fixnum i))
381 (cond
382 ((< (monom-elt p i) (monom-elt q i))
383 (return-from revlex> (values t nil)))
384 ((> (monom-elt p i) (monom-elt q i))
385 (return-from revlex> (values nil nil)))))))
386
387
388;; total degree, ties broken by reverse lexicographic
389(defgeneric grevlex> (p q &optional start end)
390 (:documentation "Return T if P>Q with respect to graded reverse
391lexicographic order, NIL otherwise. The second returned value is T if
392P=Q, otherwise it is NIL.")
393 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
394 (declare (type fixnum start end))
395 (let ((d1 (monom-total-degree p start end))
396 (d2 (monom-total-degree q start end)))
397 (declare (type fixnum d1 d2))
398 (cond
399 ((> d1 d2) (values t nil))
400 ((< d1 d2) (values nil nil))
401 (t
402 (revlex> p q start end))))))
403
404(defgeneric invlex> (p q &optional start end)
405 (:documentation "Return T if P>Q with respect to inverse
406lexicographic order, NIL otherwise The second returned value is T if
407P=Q, otherwise it is NIL.")
408 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
409 (declare (type fixnum start end))
410 (do ((i (1- end) (1- i)))
411 ((< i start) (values nil t))
412 (declare (type fixnum i))
413 (cond
414 ((> (monom-elt p i) (monom-elt q i))
415 (return-from invlex> (values t nil)))
416 ((< (monom-elt p i) (monom-elt q i))
417 (return-from invlex> (values nil nil)))))))
418
419(defun reverse-monomial-order (order)
420 "Create the inverse monomial order to the given monomial order ORDER."
421 #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
422 (declare (type monom p q) (type fixnum start end))
423 (funcall order q p start end)))
424
425;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
426;;
427;; Order making functions
428;;
429;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
430
431;; This returns a closure with the same signature
432;; as all orders such as #'LEX>.
433(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
434 "It constructs an elimination order used for the 1-st elimination ideal,
435i.e. for eliminating the first variable. Thus, the order compares the degrees of the
436first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
437 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
438 (declare (type monom p q) (type fixnum start end))
439 (cond
440 ((> (monom-elt p start) (monom-elt q start))
441 (values t nil))
442 ((< (monom-elt p start) (monom-elt q start))
443 (values nil nil))
444 (t
445 (funcall secondary-elimination-order p q (1+ start) end)))))
446
447;; This returns a closure which is called with an integer argument.
448;; The result is *another closure* with the same signature as all
449;; orders such as #'LEX>.
450(defun make-elimination-order-factory (&optional
451 (primary-elimination-order #'lex>)
452 (secondary-elimination-order #'lex>))
453 "Return a function with a single integer argument K. This should be
454the number of initial K variables X[0],X[1],...,X[K-1], which precede
455remaining variables. The call to the closure creates a predicate
456which compares monomials according to the K-th elimination order. The
457monomial orders PRIMARY-ELIMINATION-ORDER and
458SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
459remaining variables, respectively, with ties broken by lexicographical
460order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
461which indicates that the first K variables appear with identical
462powers, then the result is that of a call to
463SECONDARY-ELIMINATION-ORDER applied to the remaining variables
464X[K],X[K+1],..."
465 #'(lambda (k)
466 (cond
467 ((<= k 0)
468 (error "K must be at least 1"))
469 ((= k 1)
470 (make-elimination-order-factory-1 secondary-elimination-order))
471 (t
472 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
473 (declare (type monom p q) (type fixnum start end))
474 (multiple-value-bind (primary equal)
475 (funcall primary-elimination-order p q start k)
476 (if equal
477 (funcall secondary-elimination-order p q k end)
478 (values primary nil))))))))
479
480(defclass term (monom)
481 ((coeff :initarg :coeff :accessor term-coeff))
482 (:default-initargs :coeff nil)
483 (:documentation "Implements a term, i.e. a product of a scalar
484and powers of some variables, such as 5*X^2*Y^3."))
485
486(defmethod print-object ((self term) stream)
487 (print-unreadable-object (self stream :type t :identity t)
488 (with-accessors ((exponents monom-exponents)
489 (coeff term-coeff))
490 self
491 (format stream "EXPONENTS=~A COEFF=~A"
492 exponents coeff))))
493
494(defgeneric universal-equalp ((term1 term) (term2 term))
495 (and (call-next-method)
496 (universal-equalp (term-coeff term1) (term-coeff term2))))
497
498(defmethod update-instance-for-different-class :after ((old monom) (new term) &key)
499 (setf (term-coeff new) 1))
500
501(defmethod term-multiply-by ((self term) (other term))
502 "Destructively multiply terms SELF and OTHER and store the result into SELF.
503It returns SELF."
504 (setf (term-coeff self) (universal-multiply-by (term-coeff self) (scalar-coeff other))))
505
506(defmethod term-left-tensor-product-by ((self term) (other term))
507 (setf (term-coeff self) (universal-multiply-by (term-coeff self) (term-coeff other)))
508 (call-next-method))
509
510(defmethod term-right-tensor-product-by ((self term) (other term))
511 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other)))
512 (call-next-method))
513
514(defmethod monom-divide-by ((self term) (other term))
515 "Destructively divide term SELF by OTHER and store the result into SELF.
516It returns SELF."
517 (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other)))
518 (call-next-method))
519
520(defmethod monom-unary-minus ((self term))
521 (setf (term-coeff self) (monom-unary-minus (term-coeff self)))
522 self)
523
524(defmethod monom-multiply ((term1 term) (term2 term))
525 "Non-destructively multiply TERM1 by TERM2."
526 (monom-multiply-by (copy-instance term1) (copy-instance term2)))
527
528(defmethod monom-multiply ((term1 number) (term2 monom))
529 "Non-destructively multiply TERM1 by TERM2."
530 (monom-multiply term1 (change-class (copy-instance term2) 'term)))
531
532(defmethod monom-zerop ((self term))
533 (zerop (term-coeff self)))
Note: See TracBrowser for help on using the repository browser.