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

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

* empty log message *

File size: 10.5 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(defmethod monom-dimension (m)
105 (length (monom-exponents ,m)))
106
107(defmethod monom-equalp (m1 m2)
108 "Returns T iff monomials M1 and M2 have identical
109EXPONENTS."
110 `(equalp (monom-exponents ,m1) (monom-exponents ,m2)))
111
112(defmethod monom-elt (m index)
113 "Return the power in the monomial M of variable number INDEX."
114 (with-slots (exponents)
115 m
116 (elt exponents index)))
117
118(defmethod (setf monom-elt) (new-value m index)
119 "Return the power in the monomial M of variable number INDEX."
120 (with-slots (exponents)
121 m
122 (setf (elt exponents index) new-value)))
123
124(defmethod monom-total-degree (m &optional (start 0) (end (monom-dimension m)))
125 "Return the todal degree of a monomoal M. Optinally, a range
126of variables may be specified with arguments START and END."
127 (declare (type fixnum start end))
128 (with-slots (exponents)
129 m
130 (reduce #'+ exponents :start start :end end)))
131
132
133(defmethod monom-sugar (m &aux (start 0) (end (monom-dimension m)))
134 "Return the sugar of a monomial M. Optinally, a range
135of variables may be specified with arguments START and END."
136 (declare (type fixnum start end))
137 (monom-total-degree m start end))
138
139(defmethod multiply-by ((self monom) (other monom))
140 (with-slots ((exponents1 exponents))
141 self
142 (with-slots ((exponents2 exponents))
143 other
144 (unless (= (length exponents1) (length exponents2))
145 (error "Incompatible dimensions"))
146 (map-into exponents1 #'+ exponents1 exponents2)))
147 self)
148
149(defmethod divide-by ((self monom) (other monom))
150 (with-slots ((exponents1 exponents))
151 self
152 (with-slots ((exponents2 exponents))
153 other
154 (unless (= (length exponents1) (length exponents2))
155 (error "divide-by: Incompatible dimensions."))
156 (unless (every #'>= exponents1 exponents2)
157 (error "divide-by: Negative power would result."))
158 (map-into exponents1 #'- exponents1 exponents2)))
159 self)
160
161(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
162 "An :AROUNT method for COPY-INSTANCE. The primary method is a shallow copy,
163 while for monomials we typically need a fresh copy of the
164 exponents."
165 (declare (ignore object initargs))
166 (let ((copy (call-next-method)))
167 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
168 copy))
169
170(defmethod monom* ((m1 monom) (m2 monom))
171 "Non-destructively multiply monomial M1 by M2."
172 (multiply-by (copy-instance m1) (copy-instance m2)))
173
174(defmethod monom* ((numerator monom) &rest denominators)
175 "Non-destructively divide monomial NUMERATOR by product of DENOMINATORS."
176 (divide-by (copy-instance numerator) (reduce #'
177 monom* denominators)))
178
179(defmethod monom-divides-p ((m1 monom) (m2 monom))
180 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
181 (with-slots ((exponents1 exponents))
182 m1
183 (with-slots ((exponents2 exponents))
184 m2
185 (every #'<= exponents1 exponents2))))
186
187
188(defmethod monom-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom))
189 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
190 (every #'(lambda (x y z) (<= x (max y z)))
191 m1 m2 m3))
192
193
194(defmethod monom-lcm-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
195 "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
196 (declare (type monom m1 m2 m3 m4))
197 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
198 m1 m2 m3 m4))
199
200(defmethod monom-lcm-equal-lcm-p (m1 m2 m3 m4)
201 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
202 (with-slots ((exponents1 exponents))
203 m1
204 (with-slots ((exponents2 exponents))
205 m2
206 (with-slots ((exponents3 exponents))
207 m3
208 (with-slots ((exponents4 exponents))
209 m4
210 (every
211 #'(lambda (x y z w) (= (max x y) (max z w)))
212 exponents1 exponents2 exponents3 exponents4))))))
213
214(defmethod monom-divisible-by-p ((m1 monom) (m2 monom))
215 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
216 (with-slots ((exponents1 exponents))
217 m1
218 (with-slots ((exponents2 exponents))
219 m2
220 (every #'>= exponents1 exponents2))))
221
222(defmethod monom-rel-prime-p ((m1 monom) (m2 monom))
223 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
224 (with-slots ((exponents1 exponents))
225 m1
226 (with-slots ((exponents2 exponents))
227 m2
228 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2))))
229
230
231(defmethod monom-lcm ((m1 monom) (m2 monom))
232 "Returns least common multiple of monomials M1 and M2."
233 (with-slots ((exponents1 exponents))
234 m1
235 (with-slots ((exponents2 exponents))
236 m2
237 (let* ((exponents (copy-seq exponents1)))
238 (map-into exponents #'max exponents1 exponents2)
239 (make-instance 'monom :exponents exponents)))))
240
241
242(defmethod monom-gcd ((m1 monom) (m2 monom))
243 "Returns greatest common divisor of monomials M1 and M2."
244 (with-slots ((exponents1 exponents))
245 m1
246 (with-slots ((exponents2 exponents))
247 m2
248 (let* ((exponents (copy-seq exponents1)))
249 (map-into exponents #'min exponents1 exponents2)
250 (make-instance 'monom :exponents exponents)))))
251
252(defmethod monom-depends-p ((m monom) k)
253 "Return T if the monomial M depends on variable number K."
254 (declare (type fixnum k))
255 (with-slots (exponents)
256 m
257 (plusp (elt exponents k))))
258
259(defmethod monom-left-tensor-product-by ((self monom) (other monom))
260 (with-slots ((exponents1 exponents))
261 self
262 (with-slots ((exponents2 exponents))
263 other
264 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
265 self)
266
267(defmethod monom-right-tensor-product-by ((self monom) (other monom))
268 (with-slots ((exponents1 exponents))
269 self
270 (with-slots ((exponents2 exponents))
271 other
272 (setf exponents1 (concatenate 'vector exponents1 exponents2))))
273 self)
274
275(defmethod monom-left-contract ((self monom) k)
276 "Drop the first K variables in monomial M."
277 (declare (fixnum k))
278 (with-slots (exponents)
279 self
280 (setf exponents (subseq exponents k)))
281 self)
282
283(defun make-monom-variable (nvars pos &optional (power 1)
284 &aux (m (make-instance 'monom :dimension nvars)))
285 "Construct a monomial in the polynomial ring
286RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
287which represents a single variable. It assumes number of variables
288NVARS and the variable is at position POS. Optionally, the variable
289may appear raised to power POWER. "
290 (declare (type fixnum nvars pos power) (type monom m))
291 (with-slots (exponents)
292 m
293 (setf (elt exponents pos) power)
294 m))
295
296(defmethod monom->list ((m monom))
297 "A human-readable representation of a monomial M as a list of exponents."
298 (coerce (monom-exponents m) 'list))
Note: See TracBrowser for help on using the repository browser.