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

Last change on this file since 4225 was 4225, checked in by Marek Rychlik, 8 years ago

* empty log message *

File size: 24.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 :utils :copy :ring :integer-ring)
24 (:export "MONOM"
25 "TERM"
26 "EXPONENT"
27 "MONOM-DIMENSION"
28 "MONOM-EXPONENTS"
29 "UNIVERSAL-EQUALP"
30 "MONOM-ELT"
31 "TOTAL-DEGREE"
32 "SUGAR"
33 "MULTIPLY-BY"
34 "DIVIDE-BY"
35 "DIVIDE"
36 "MULTIPLY"
37 "DIVIDES-P"
38 "DIVIDES-LCM-P"
39 "LCM-DIVIDES-LCM-P"
40 "LCM-EQUAL-LCM-P"
41 "DIVISIBLE-BY-P"
42 "REL-PRIME-P"
43 "UNIVERSAL-LCM"
44 "UNIVERSAL-GCD"
45 "DEPENDS-P"
46 "LEFT-TENSOR-PRODUCT-BY"
47 "RIGHT-TENSOR-PRODUCT-BY"
48 "LEFT-CONTRACT"
49 "MAKE-MONOM-VARIABLE"
50 "MAKE-MONOM-CONSTANT"
51 "MAKE-TERM-CONSTANT"
52 "->LIST"
53 "->SEXP"
54 "LEX>"
55 "GRLEX>"
56 "REVLEX>"
57 "GREVLEX>"
58 "INVLEX>"
59 "REVERSE-MONOMIAL-ORDER"
60 "MAKE-ELIMINATION-ORDER-FACTORY"
61 "TERM-COEFF"
62 "UNARY-MINUS"
63 "UNARY-INVERSE"
64 "UNIVERSAL-ZEROP")
65 (:documentation
66 "This package implements basic operations on monomials, including
67various monomial orders.
68
69DATA STRUCTURES: Conceptually, monomials can be represented as lists:
70
71 monom: (n1 n2 ... nk) where ni are non-negative integers
72
73However, lists may be implemented as other sequence types, so the
74flexibility to change the representation should be maintained in the
75code to use general operations on sequences whenever possible. The
76optimization for the actual representation should be left to
77declarations and the compiler.
78
79EXAMPLES: Suppose that variables are x and y. Then
80
81 Monom x*y^2 ---> (1 2) "))
82
83(in-package :monom)
84
85(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 0)))
86
87(deftype exponent ()
88 "Type of exponent in a monomial."
89 'fixnum)
90
91(defclass monom ()
92 ((exponents :initarg :exponents :accessor monom-exponents
93 :documentation "The powers of the variables."))
94 ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
95 ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
96 (:documentation
97 "Implements a monomial, i.e. a product of powers
98of variables, like X*Y^2."))
99
100(defmethod print-object ((self monom) stream)
101 (print-unreadable-object (self stream :type t :identity t)
102 (with-accessors ((exponents monom-exponents))
103 self
104 (format stream "EXPONENTS=~A"
105 exponents))))
106
107(defmethod initialize-instance :after ((self monom)
108 &key
109 (dimension 0 dimension-supplied-p)
110 (exponents nil exponents-supplied-p)
111 (exponent 0)
112 &allow-other-keys
113 )
114 "The following INITIALIZE-INSTANCE method allows instance initialization
115of a MONOM in a style similar to MAKE-ARRAY, e.g.:
116
117 (MAKE-INSTANCE 'MONOM :EXPONENTS '(1 2 3)) --> #<MONOM EXPONENTS=#(1 2 3)>
118 (MAKE-INSTANCE 'MONOM :DIMENSION 3) --> #<MONOM EXPONENTS=#(0 0 0)>
119 (MAKE-INSTANCE 'MONOM :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>
120
121If both DIMENSION and EXPONENTS are supplied, they must be compatible,
122i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS
123is not supplied, a monom with repeated value EXPONENT is created.
124By default EXPONENT is 0, which results in a constant monomial.
125"
126 (cond
127 (exponents-supplied-p
128 (when (and dimension-supplied-p
129 (/= dimension (length exponents)))
130 (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"
131 exponents dimension))
132 (let ((dim (length exponents)))
133 (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))
134 (dimension-supplied-p
135 ;; when all exponents are to be identical
136 (setf (slot-value self 'exponents) (make-array (list dimension)
137 :initial-element exponent
138 :element-type 'exponent)))
139 (t
140 (error "Initarg DIMENSION or EXPONENTS must be supplied."))))
141
142(defgeneric monom-dimension (self)
143 (:method ((self monom))
144 (length (monom-exponents self))))
145
146(defgeneric universal-equalp (object1 object2)
147 (:method ((m1 monom) (m2 monom))
148 "Returns T iff monomials M1 and M2 have identical EXPONENTS."
149 (equalp (monom-exponents m1) (monom-exponents m2))))
150
151(defgeneric monom-elt (m index)
152 (:documentation "Return the power in the monomial M of variable number INDEX.")
153 (:method ((m monom) index)
154 "Return the power in the monomial M of variable number INDEX."
155 (with-slots (exponents)
156 m
157 (elt exponents index))))
158
159(defgeneric (setf monom-elt) (new-value m index)
160 (:documentation "Set the power in the monomial M of variable number INDEX.")
161 (:method (new-value (m monom) index)
162 (with-slots (exponents)
163 m
164 (setf (elt exponents index) new-value))))
165
166(defgeneric total-degree (m &optional start end)
167 (:documentation "Return the total degree of a monomoal M. Optinally, a range
168of variables may be specified with arguments START and END.")
169 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
170 (declare (type fixnum start end))
171 (with-slots (exponents)
172 m
173 (reduce #'+ exponents :start start :end end))))
174
175(defgeneric sugar (m &optional start end)
176 (:documentation "Return the sugar of a monomial M. Optinally, a range
177of variables may be specified with arguments START and END.")
178 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
179 (declare (type fixnum start end))
180 (total-degree m start end)))
181
182(defgeneric multiply-by (self other)
183 (:documentation "Multiply SELF by OTHER, return SELF. The object SELF
184may be destructively modified in the process, while OTHER should remain
185unmodified.")
186 (:method ((self number) (other number)) (* self other))
187 (:method ((self monom) (other monom))
188 (with-slots ((exponents1 exponents))
189 self
190 (with-slots ((exponents2 exponents))
191 other
192 (unless (= (length exponents1) (length exponents2))
193 (error "Incompatible dimensions"))
194 (map-into exponents1 #'+ exponents1 exponents2)))
195 self))
196
197(defun multiply (factor &rest more-factors)
198 "Successively multiplies factor FACTOR by the remaining arguments
199MORE-FACTORS, using MULTIPLY-BY to multiply two factors. Thus
200FACTOR may be destructively modified."
201 (reduce #'multiply-by more-factors :initial-value (copy-instance factor)))
202
203(defgeneric divide-by (self other)
204 (:documentation "Divide SELF by OTHER, return SELF.")
205 (:method ((self number) (other number)) (/ self other))
206 (:method ((self monom) (other monom))
207 (with-slots ((exponents1 exponents))
208 self
209 (with-slots ((exponents2 exponents))
210 other
211 (unless (= (length exponents1) (length exponents2))
212 (error "divide-by: Incompatible dimensions."))
213 (unless (every #'>= exponents1 exponents2)
214 (error "divide-by: Negative power would result."))
215 (map-into exponents1 #'- exponents1 exponents2)))
216 self))
217
218(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
219 "An :AROUND method of COPY-INSTANCE. It replaces exponents with a fresh copy of the sequence."
220 (declare (ignore object initargs))
221 (let ((copy (call-next-method)))
222 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
223 copy))
224
225(defgeneric unary-inverse (self)
226 (:documentation "Returns the unary inverse of SELF.")
227 (:method ((self number)) (/ self))
228 (:method :before ((self monom))
229 (assert (zerop (total-degree self))
230 nil
231 "Monom ~A must have total degree 0 to be invertible." self))
232 (:method ((self monom)) self))
233
234(defun divide (numerator &rest denominators)
235 "Successively divides NUMERATOR by elements of DENOMINATORS. The operation
236destructively modifies NUMERATOR."
237 (cond ((endp denominators)
238 (unary-inverse numerator))
239 (t (reduce #'divide-by denominators :initial-value (copy-instance numerator)))))
240
241(defgeneric divides-p (object1 object2)
242 (:documentation "Returns T if OBJECT1 divides OBJECT2.")
243 (:method ((m1 monom) (m2 monom))
244 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
245 (with-slots ((exponents1 exponents))
246 m1
247 (with-slots ((exponents2 exponents))
248 m2
249 (every #'<= exponents1 exponents2)))))
250
251(defgeneric divides-lcm-p (object1 object2 object3)
252 (:documentation "Returns T if OBJECT1 divides LCM(OBJECT2,OBJECT3), NIL otherwise.")
253 (:method ((m1 monom) (m2 monom) (m3 monom))
254 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
255 (with-slots ((exponents1 exponents))
256 m1
257 (with-slots ((exponents2 exponents))
258 m2
259 (with-slots ((exponents3 exponents))
260 m3
261 (every #'(lambda (x y z) (<= x (max y z)))
262 exponents1 exponents2 exponents3))))))
263
264(defgeneric lcm-divides-lcm-p (object1 object2 object3 object4)
265 (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
266 "Returns T if monomial LCM(M1,M2) divides LCM(M3,M4), NIL otherwise."
267 (with-slots ((exponents1 exponents))
268 m1
269 (with-slots ((exponents2 exponents))
270 m2
271 (with-slots ((exponents3 exponents))
272 m3
273 (with-slots ((exponents4 exponents))
274 m4
275 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
276 exponents1 exponents2 exponents3 exponents4)))))))
277
278(defgeneric monom-lcm-equal-lcm-p (object1 object2 object3 object4)
279 (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
280 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
281 (with-slots ((exponents1 exponents))
282 m1
283 (with-slots ((exponents2 exponents))
284 m2
285 (with-slots ((exponents3 exponents))
286 m3
287 (with-slots ((exponents4 exponents))
288 m4
289 (every
290 #'(lambda (x y z w) (= (max x y) (max z w)))
291 exponents1 exponents2 exponents3 exponents4)))))))
292
293(defgeneric divisible-by-p (object1 object2)
294 (:documentation "Return T if OBJECT1 is divisible by OBJECT2.")
295 (:method ((m1 monom) (m2 monom))
296 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
297 (with-slots ((exponents1 exponents))
298 m1
299 (with-slots ((exponents2 exponents))
300 m2
301 (every #'>= exponents1 exponents2)))))
302
303(defgeneric rel-prime-p (object1 object2)
304 (:documentation "Returns T if objects OBJECT1 and OBJECT2 are relatively prime.")
305 (:method ((m1 monom) (m2 monom))
306 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
307 (with-slots ((exponents1 exponents))
308 m1
309 (with-slots ((exponents2 exponents))
310 m2
311 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2)))))
312
313(defgeneric universal-lcm (object1 object2)
314 (:documentation "Returns the multiple of objects OBJECT1 and OBJECT2.")
315 (:method ((m1 monom) (m2 monom))
316 "Returns least common multiple of monomials M1 and M2."
317 (with-slots ((exponents1 exponents))
318 m1
319 (with-slots ((exponents2 exponents))
320 m2
321 (let* ((exponents (copy-seq exponents1)))
322 (map-into exponents #'max exponents1 exponents2)
323 (make-instance 'monom :exponents exponents))))))
324
325
326(defgeneric universal-gcd (object1 object2)
327 (:documentation "Returns GCD of objects OBJECT1 and OBJECT2")
328 (:method ((m1 monom) (m2 monom))
329 "Returns greatest common divisor of monomials M1 and M2."
330 (with-slots ((exponents1 exponents))
331 m1
332 (with-slots ((exponents2 exponents))
333 m2
334 (let* ((exponents (copy-seq exponents1)))
335 (map-into exponents #'min exponents1 exponents2)
336 (make-instance 'monom :exponents exponents))))))
337
338(defgeneric depends-p (object k)
339 (:documentation "Returns T iff object OBJECT depends on variable K.")
340 (:method ((m monom) k)
341 "Return T if the monomial M depends on variable number K."
342 (declare (type fixnum k))
343 (with-slots (exponents)
344 m
345 (plusp (elt exponents k)))))
346
347(defgeneric left-tensor-product-by (self other)
348 (:documentation "Returns a tensor product SELF by OTHER, stored into
349 SELF. Return SELF.")
350 (:method ((self monom) (other monom))
351 (with-slots ((exponents1 exponents))
352 self
353 (with-slots ((exponents2 exponents))
354 other
355 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
356 self))
357
358(defgeneric right-tensor-product-by (self other)
359 (:documentation "Returns a tensor product of OTHER by SELF, stored
360 into SELF. Returns SELF.")
361 (:method ((self monom) (other monom))
362 (with-slots ((exponents1 exponents))
363 self
364 (with-slots ((exponents2 exponents))
365 other
366 (setf exponents1 (concatenate 'vector exponents1 exponents2))))
367 self))
368
369(defgeneric left-contract (self k)
370 (:documentation "Drop the first K variables in object SELF.")
371 (:method ((self monom) k)
372 "Drop the first K variables in monomial M."
373 (declare (fixnum k))
374 (with-slots (exponents)
375 self
376 (setf exponents (subseq exponents k)))
377 self))
378
379(defun make-monom-variable (nvars pos &optional (power 1)
380 &aux (m (make-instance 'monom :dimension nvars)))
381 "Construct a monomial in the polynomial ring
382RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
383which represents a single variable. It assumes number of variables
384NVARS and the variable is at position POS. Optionally, the variable
385may appear raised to power POWER. "
386 (declare (type fixnum nvars pos power) (type monom m))
387 (with-slots (exponents)
388 m
389 (setf (elt exponents pos) power)
390 m))
391
392(defun make-monom-constant (dimension)
393 (make-instance 'monom :dimension dimension))
394
395;; pure lexicographic
396(defgeneric lex> (p q &optional start end)
397 (:documentation "Return T if P>Q with respect to lexicographic
398order, otherwise NIL. The second returned value is T if P=Q,
399otherwise it is NIL.")
400 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
401 (declare (type fixnum start end))
402 (do ((i start (1+ i)))
403 ((>= i end) (values nil t))
404 (cond
405 ((> (monom-elt p i) (monom-elt q i))
406 (return-from lex> (values t nil)))
407 ((< (monom-elt p i) (monom-elt q i))
408 (return-from lex> (values nil nil)))))))
409
410;; total degree order, ties broken by lexicographic
411(defgeneric grlex> (p q &optional start end)
412 (:documentation "Return T if P>Q with respect to graded
413lexicographic order, otherwise NIL. The second returned value is T if
414P=Q, otherwise it is NIL.")
415 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
416 (declare (type monom p q) (type fixnum start end))
417 (let ((d1 (total-degree p start end))
418 (d2 (total-degree q start end)))
419 (declare (type fixnum d1 d2))
420 (cond
421 ((> d1 d2) (values t nil))
422 ((< d1 d2) (values nil nil))
423 (t
424 (lex> p q start end))))))
425
426;; reverse lexicographic
427(defgeneric revlex> (p q &optional start end)
428 (:documentation "Return T if P>Q with respect to reverse
429lexicographic order, NIL otherwise. The second returned value is T if
430P=Q, otherwise it is NIL. This is not and admissible monomial order
431because some sets do not have a minimal element. This order is useful
432in constructing other orders.")
433 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
434 (declare (type fixnum start end))
435 (do ((i (1- end) (1- i)))
436 ((< i start) (values nil t))
437 (declare (type fixnum i))
438 (cond
439 ((< (monom-elt p i) (monom-elt q i))
440 (return-from revlex> (values t nil)))
441 ((> (monom-elt p i) (monom-elt q i))
442 (return-from revlex> (values nil nil)))))))
443
444
445;; total degree, ties broken by reverse lexicographic
446(defgeneric grevlex> (p q &optional start end)
447 (:documentation "Return T if P>Q with respect to graded reverse
448lexicographic order, NIL otherwise. The second returned value is T if
449P=Q, otherwise it is NIL.")
450 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
451 (declare (type fixnum start end))
452 (let ((d1 (total-degree p start end))
453 (d2 (total-degree q start end)))
454 (declare (type fixnum d1 d2))
455 (cond
456 ((> d1 d2) (values t nil))
457 ((< d1 d2) (values nil nil))
458 (t
459 (revlex> p q start end))))))
460
461(defgeneric invlex> (p q &optional start end)
462 (:documentation "Return T if P>Q with respect to inverse
463lexicographic order, NIL otherwise The second returned value is T if
464P=Q, otherwise it is NIL.")
465 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
466 (declare (type fixnum start end))
467 (do ((i (1- end) (1- i)))
468 ((< i start) (values nil t))
469 (declare (type fixnum i))
470 (cond
471 ((> (monom-elt p i) (monom-elt q i))
472 (return-from invlex> (values t nil)))
473 ((< (monom-elt p i) (monom-elt q i))
474 (return-from invlex> (values nil nil)))))))
475
476(defun reverse-monomial-order (order)
477 "Create the inverse monomial order to the given monomial order ORDER."
478 #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
479 (declare (type monom p q) (type fixnum start end))
480 (funcall order q p start end)))
481
482;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
483;;
484;; Order making functions
485;;
486;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
487
488;; This returns a closure with the same signature
489;; as all orders such as #'LEX>.
490(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
491 "It constructs an elimination order used for the 1-st elimination ideal,
492i.e. for eliminating the first variable. Thus, the order compares the degrees of the
493first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
494 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
495 (declare (type monom p q) (type fixnum start end))
496 (cond
497 ((> (monom-elt p start) (monom-elt q start))
498 (values t nil))
499 ((< (monom-elt p start) (monom-elt q start))
500 (values nil nil))
501 (t
502 (funcall secondary-elimination-order p q (1+ start) end)))))
503
504;; This returns a closure which is called with an integer argument.
505;; The result is *another closure* with the same signature as all
506;; orders such as #'LEX>.
507(defun make-elimination-order-factory (&optional
508 (primary-elimination-order #'lex>)
509 (secondary-elimination-order #'lex>))
510 "Return a function with a single integer argument K. This should be
511the number of initial K variables X[0],X[1],...,X[K-1], which precede
512remaining variables. The call to the closure creates a predicate
513which compares monomials according to the K-th elimination order. The
514monomial orders PRIMARY-ELIMINATION-ORDER and
515SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
516remaining variables, respectively, with ties broken by lexicographical
517order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
518which indicates that the first K variables appear with identical
519powers, then the result is that of a call to
520SECONDARY-ELIMINATION-ORDER applied to the remaining variables
521X[K],X[K+1],..."
522 #'(lambda (k)
523 (cond
524 ((<= k 0)
525 (error "K must be at least 1"))
526 ((= k 1)
527 (make-elimination-order-factory-1 secondary-elimination-order))
528 (t
529 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
530 (declare (type monom p q) (type fixnum start end))
531 (multiple-value-bind (primary equal)
532 (funcall primary-elimination-order p q start k)
533 (if equal
534 (funcall secondary-elimination-order p q k end)
535 (values primary nil))))))))
536
537(defclass term (monom)
538 ((coeff :initarg :coeff :initform (error "Must specify coefficient.") :accessor term-coeff :type ring))
539 (:documentation "Implements a term, i.e. a product of a scalar
540and powers of some variables, such as 5*X^2*Y^3."))
541
542(defmethod update-instance-for-different-class :after ((old monom) (new term) &key (coeff 1))
543 "Converts OLD of class MONOM to a NEW of class TERM, initializing coefficient to COEFF."
544 (reinitialize-instance new :coeff coeff))
545
546(defmethod update-instance-for-different-class :after ((old term) (new term) &key (coeff (term-coeff old)))
547 "Converts OLD of class TERM to a NEW of class TERM, initializing coefficient to COEFF."
548 (reinitialize-instance new :coeff coeff))
549
550
551(defmethod print-object ((self term) stream)
552 (print-unreadable-object (self stream :type t :identity t)
553 (with-accessors ((exponents monom-exponents)
554 (coeff term-coeff))
555 self
556 (format stream "EXPONENTS=~A COEFF=~A"
557 exponents coeff))))
558
559(defmethod copy-instance :around ((object term) &rest initargs &key &allow-other-keys)
560 "An :AROUND method of COPY-INSTANCE. It replaces the coefficient with a fresh copy."
561 (declare (ignore object initargs))
562 (let ((copy (call-next-method)))
563 (setf (term-coeff copy) (copy-instance (term-coeff object)))
564 copy))
565
566(defmethod multiply-by ((self term) (other number))
567 (reinitialize-instance self :coeff (multiply-by (term-coeff self) other)))
568
569(defmethod divide-by ((self term) (other number))
570 (reinitialize-instance self :coeff (divide-by (term-coeff self) other)))
571
572(defmethod unary-inverse :after ((self term))
573 (with-slots (coeff)
574 self
575 (setf coeff (unary-inverse coeff))))
576
577(defun make-term-constant (dimension &optional (coeff 1))
578 (make-instance 'term :dimension dimension :coeff coeff))
579
580(defmethod universal-equalp ((term1 term) (term2 term))
581 "Returns T if TERM1 and TERM2 are equal as MONOM, and coefficients
582are UNIVERSAL-EQUALP."
583 (and (call-next-method)
584 (universal-equalp (term-coeff term1) (term-coeff term2))))
585
586(defmethod multiply-by :before ((self term) (other term))
587 "Destructively multiply terms SELF and OTHER and store the result into SELF.
588It returns SELF."
589 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
590
591
592(defmethod left-tensor-product-by :before ((self term) (other term))
593 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
594
595(defmethod right-tensor-product-by :before ((self term) (other term))
596 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
597
598(defmethod divide-by :before ((self term) (other term))
599 (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other))))
600
601(defgeneric unary-minus (self)
602 (:documentation "Negate object SELF and return it.")
603 (:method ((self number)) (- self))
604 (:method ((self term))
605 (setf (term-coeff self) (unary-minus (term-coeff self)))
606 self))
607
608(defgeneric universal-zerop (self)
609 (:documentation "Return T iff SELF is zero.")
610 (:method ((self number)) (zerop self))
611 (:method ((self term))
612 (universal-zerop (term-coeff self))))
613
614(defgeneric ->list (self)
615 (:method ((self monom))
616 "A human-readable representation of a monomial SELF as a list of exponents."
617 (coerce (monom-exponents self) 'list))
618 (:method ((self term))
619 "A human-readable representation of a term SELF as a cons of the list of exponents and the coefficient."
620 (cons (coerce (monom-exponents self) 'list) (term-coeff self))))
621
622(defgeneric ->sexp (object &optional vars)
623 (:documentation "Convert a polynomial OBJECT to an S-expression, using variables VARS.")
624 (:method :before ((object monom) &optional vars)
625 "Check the length of variables VARS against the length of exponents in OBJECT."
626 (with-slots (exponents)
627 object
628 (assert (= (length vars) (length exponents))
629 nil
630 "Variables ~A and exponents ~A must have the same length." vars exponents)))
631 (:method ((object monom) &optional vars)
632 "Convert a monomial OBJECT to infix form, using variable VARS to build the representation."
633 (with-slots (exponents)
634 object
635 (let ((m (mapcan #'(lambda (var power)
636 (cond ((= power 0) nil)
637 ((= power 1) (list var))
638 (t (list `(expt ,var ,power)))))
639 vars (coerce exponents 'list))))
640 (cond ((endp m) 1)
641 ((endp (cdr m)) (car m))
642 (t
643 (cons '* m))))))
644 (:method :around ((object term) &optional vars)
645 "Convert a term OBJECT to infix form, using variable VARS to build the representation."
646 (declare (ignore vars))
647 (with-slots (coeff)
648 object
649 (let ((sexp (call-next-method)))
650 (cond ((eql coeff 1) sexp)
651 ((atom sexp)
652 (cond ((eql sexp 1) coeff)
653 (t (list '* coeff sexp))))
654 ((eql (car sexp) '*)
655 (list* '* coeff (cdr sexp)))
656 (t
657 (list '* coeff sexp)))))))
Note: See TracBrowser for help on using the repository browser.