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

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

* empty log message *

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