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

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

* empty log message *

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