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

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

* empty log message *

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