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

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

* empty log message *

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