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

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

* empty log message *
File size: 11.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-SUGRAR"
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
52 (:documentation
53 "This package implements basic operations on monomials.
54DATA STRUCTURES: Conceptually, monomials can be represented as lists:
55
56 monom: (n1 n2 ... nk) where ni are non-negative integers
57
58However, lists may be implemented as other sequence types, so the
59flexibility to change the representation should be maintained in the
60code to use general operations on sequences whenever possible. The
61optimization for the actual representation should be left to
62declarations and the compiler.
63
64EXAMPLES: Suppose that variables are x and y. Then
65
66 Monom x*y^2 ---> (1 2) "))
67
68(in-package :monom)
69
70(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
71
72(deftype exponent ()
73 "Type of exponent in a monomial."
74 'fixnum)
75
76(defclass monom ()
77 ((exponents :initarg :exponents :accessor monom-exponents
78 :documentation "The powers of the variables."))
79 ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
80 ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
81 (:documentation
82 "Implements a monomial, i.e. a product of powers
83of variables, like X*Y^2."))
84
85(defmethod print-object ((self monom) stream)
86 (print-unreadable-object (self stream :type t :identity t)
87 (with-accessors ((exponents monom-exponents))
88 self
89 (format stream "EXPONENTS=~A"
90 exponents))))
91
92(defmethod initialize-instance :after ((self monom)
93 &key
94 (dimension 0 dimension-supplied-p)
95 (exponents nil exponents-supplied-p)
96 (exponent 0)
97 &allow-other-keys
98 )
99 "The following INITIALIZE-INSTANCE method allows instance initialization
100of a MONOM in a style similar to MAKE-ARRAY, e.g.:
101
102 (MAKE-INSTANCE :EXPONENTS '(1 2 3)) --> #<MONOM EXPONENTS=#(1 2 3)>
103 (MAKE-INSTANCE :DIMENSION 3) --> #<MONOM EXPONENTS=#(0 0 0)>
104 (MAKE-INSTANCE :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>
105
106If both DIMENSION and EXPONENTS are supplied, they must be compatible,
107i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS
108is not supplied, a monom with repeated value EXPONENT is created.
109By default EXPONENT is 0, which results in a constant monomial.
110"
111 (cond
112 (exponents-supplied-p
113 (when (and dimension-supplied-p
114 (/= dimension (length exponents)))
115 (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"
116 exponents dimension))
117 (let ((dim (length exponents)))
118 (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))
119 (dimension-supplied-p
120 ;; when all exponents are to be identical
121 (setf (slot-value self 'exponents) (make-array (list dimension)
122 :initial-element exponent
123 :element-type 'exponent)))
124 (t
125 (error "Initarg DIMENSION or EXPONENTS must be supplied."))))
126
127(defgeneric monom-dimension (m)
128 (:method ((m monom))
129 (length (monom-exponents m))))
130
131(defgeneric monom-equalp (m1 m2)
132 (:documentation "Returns T iff monomials M1 and M2 have identical EXPONENTS.")
133 (:method ((m1 monom) (m2 monom))
134 `(equalp (monom-exponents ,m1) (monom-exponents ,m2))))
135
136(defgeneric monom-elt (m index)
137 (:documentation
138 "Return the power in the monomial M of variable number INDEX.")
139 (:method ((m monom) index)
140 (with-slots (exponents)
141 m
142 (elt exponents index))))
143
144(defgeneric (setf monom-elt) (new-value m index)
145 (:documentation "Return the power in the monomial M of variable number INDEX.")
146 (:method (new-value (m monom) index)
147 (with-slots (exponents)
148 m
149 (setf (elt exponents index) new-value))))
150
151(defgeneric monom-total-degree (m &optional start end)
152 (:documentation "Return the todal degree of a monomoal M. Optinally, a range
153of variables may be specified with arguments START and END.")
154 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
155 (declare (type fixnum start end))
156 (with-slots (exponents)
157 m
158 (reduce #'+ exponents :start start :end end))))
159
160(defgeneric monom-sugar (m &optional start end)
161 (:documentation "Return the sugar of a monomial 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 (monom-total-degree m start end)))
166
167(defgeneric monom-multiply-by (self other)
168 (:method ((self monom) (other monom))
169 (with-slots ((exponents1 exponents))
170 self
171 (with-slots ((exponents2 exponents))
172 other
173 (unless (= (length exponents1) (length exponents2))
174 (error "Incompatible dimensions"))
175 (map-into exponents1 #'+ exponents1 exponents2)))
176 self))
177
178(defgeneric divide-by (self other)
179 (:method ((self monom) (other monom))
180 (with-slots ((exponents1 exponents))
181 self
182 (with-slots ((exponents2 exponents))
183 other
184 (unless (= (length exponents1) (length exponents2))
185 (error "divide-by: Incompatible dimensions."))
186 (unless (every #'>= exponents1 exponents2)
187 (error "divide-by: Negative power would result."))
188 (map-into exponents1 #'- exponents1 exponents2)))
189 self))
190
191(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
192 "An :AROUND method of COPY-INSTANCE. It replaces
193exponents with a fresh copy of the sequence."
194 (declare (ignore object initargs))
195 (let ((copy (call-next-method)))
196 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
197 copy))
198
199(defmethod monom-multiply-2 ((m1 monom) (m2 monom))
200 "Non-destructively multiply monomial M1 by M2."
201 (monom-multiply-by (copy-instance m1) (copy-instance m2)))
202
203(defmethod monom-multiply ((numerator monom) &rest denominators)
204 "Non-destructively divide monomial NUMERATOR by product of DENOMINATORS."
205 (monom-divide-by (copy-instance numerator) (reduce #'monom-multiply-2 denominators)))
206
207(defmethod monom-divides-p ((m1 monom) (m2 monom))
208 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
209 (with-slots ((exponents1 exponents))
210 m1
211 (with-slots ((exponents2 exponents))
212 m2
213 (every #'<= exponents1 exponents2))))
214
215
216(defmethod monom-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom))
217 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
218 (every #'(lambda (x y z) (<= x (max y z)))
219 m1 m2 m3))
220
221
222(defmethod monom-lcm-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
223 "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
224 (declare (type monom m1 m2 m3 m4))
225 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
226 m1 m2 m3 m4))
227
228(defmethod monom-lcm-equal-lcm-p (m1 m2 m3 m4)
229 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
230 (with-slots ((exponents1 exponents))
231 m1
232 (with-slots ((exponents2 exponents))
233 m2
234 (with-slots ((exponents3 exponents))
235 m3
236 (with-slots ((exponents4 exponents))
237 m4
238 (every
239 #'(lambda (x y z w) (= (max x y) (max z w)))
240 exponents1 exponents2 exponents3 exponents4))))))
241
242(defmethod monom-divisible-by-p ((m1 monom) (m2 monom))
243 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
244 (with-slots ((exponents1 exponents))
245 m1
246 (with-slots ((exponents2 exponents))
247 m2
248 (every #'>= exponents1 exponents2))))
249
250(defmethod monom-rel-prime-p ((m1 monom) (m2 monom))
251 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
252 (with-slots ((exponents1 exponents))
253 m1
254 (with-slots ((exponents2 exponents))
255 m2
256 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2))))
257
258
259(defmethod monom-lcm ((m1 monom) (m2 monom))
260 "Returns least common multiple of monomials M1 and M2."
261 (with-slots ((exponents1 exponents))
262 m1
263 (with-slots ((exponents2 exponents))
264 m2
265 (let* ((exponents (copy-seq exponents1)))
266 (map-into exponents #'max exponents1 exponents2)
267 (make-instance 'monom :exponents exponents)))))
268
269
270(defmethod monom-gcd ((m1 monom) (m2 monom))
271 "Returns greatest common divisor of monomials M1 and M2."
272 (with-slots ((exponents1 exponents))
273 m1
274 (with-slots ((exponents2 exponents))
275 m2
276 (let* ((exponents (copy-seq exponents1)))
277 (map-into exponents #'min exponents1 exponents2)
278 (make-instance 'monom :exponents exponents)))))
279
280(defmethod monom-depends-p ((m monom) k)
281 "Return T if the monomial M depends on variable number K."
282 (declare (type fixnum k))
283 (with-slots (exponents)
284 m
285 (plusp (elt exponents k))))
286
287(defmethod monom-left-tensor-product-by ((self monom) (other monom))
288 (with-slots ((exponents1 exponents))
289 self
290 (with-slots ((exponents2 exponents))
291 other
292 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
293 self)
294
295(defmethod monom-right-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 exponents1 exponents2))))
301 self)
302
303(defmethod monom-left-contract ((self monom) k)
304 "Drop the first K variables in monomial M."
305 (declare (fixnum k))
306 (with-slots (exponents)
307 self
308 (setf exponents (subseq exponents k)))
309 self)
310
311(defun make-monom-variable (nvars pos &optional (power 1)
312 &aux (m (make-instance 'monom :dimension nvars)))
313 "Construct a monomial in the polynomial ring
314RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
315which represents a single variable. It assumes number of variables
316NVARS and the variable is at position POS. Optionally, the variable
317may appear raised to power POWER. "
318 (declare (type fixnum nvars pos power) (type monom m))
319 (with-slots (exponents)
320 m
321 (setf (elt exponents pos) power)
322 m))
323
324(defmethod monom->list ((m monom))
325 "A human-readable representation of a monomial M as a list of exponents."
326 (coerce (monom-exponents m) 'list))
Note: See TracBrowser for help on using the repository browser.