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

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

* empty log message *

File size: 23.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 :utils :copy :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 "MULTIPLY"
36 "DIVIDE"
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(defmethod universal-equalp ((self monom) (other monom))
147 "Returns T iff monomials SELF and OTHER have identical EXPONENTS."
148 (equalp (monom-exponents self) (monom-exponents other)))
149
150(defgeneric monom-elt (m index)
151 (:documentation "Return the power in the monomial M of variable number INDEX.")
152 (:method ((m monom) index)
153 "Return the power in the monomial M of variable number INDEX."
154 (with-slots (exponents)
155 m
156 (elt exponents index))))
157
158(defgeneric (setf monom-elt) (new-value m index)
159 (:documentation "Set the power in the monomial M of variable number INDEX.")
160 (:method (new-value (m monom) index)
161 (with-slots (exponents)
162 m
163 (setf (elt exponents index) new-value))))
164
165(defgeneric total-degree (m &optional start end)
166 (:documentation "Return the total degree of a monomoal M. Optinally, a range
167of variables may be specified with arguments START and END.")
168 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
169 (declare (type fixnum start end))
170 (with-slots (exponents)
171 m
172 (reduce #'+ exponents :start start :end end))))
173
174(defgeneric sugar (m &optional start end)
175 (:documentation "Return the sugar of a monomial M. Optinally, a range
176of variables may be specified with arguments START and END.")
177 (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
178 (declare (type fixnum start end))
179 (total-degree m start end)))
180
181(defmethod multiply-by ((self monom) (other monom))
182 (with-slots ((exponents1 exponents))
183 self
184 (with-slots ((exponents2 exponents))
185 other
186 (unless (= (length exponents1) (length exponents2))
187 (error "Incompatible dimensions"))
188 (map-into exponents1 #'+ exponents1 exponents2)))
189 self)
190
191(defmethod divide-by ((self monom) (other monom))
192 (with-slots ((exponents1 exponents))
193 self
194 (with-slots ((exponents2 exponents))
195 other
196 (unless (= (length exponents1) (length exponents2))
197 (error "divide-by: Incompatible dimensions."))
198 (unless (every #'>= exponents1 exponents2)
199 (error "divide-by: Negative power would result."))
200 (map-into exponents1 #'- exponents1 exponents2)))
201 self)
202
203(defmethod copy-instance :around ((object monom) &rest initargs &key &allow-other-keys)
204 "An :AROUND method of COPY-INSTANCE. It replaces exponents with a fresh copy of the sequence."
205 (declare (ignore object initargs))
206 (let ((copy (call-next-method)))
207 (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
208 copy))
209
210(defmethod unary-inverse :before ((self monom))
211 (assert (zerop (total-degree self))
212 nil
213 "Monom ~A must have total degree 0 to be invertible.")
214 self)
215
216(defmethod unary-inverse ((self monom)) self)
217
218(defgeneric divides-p (object1 object2)
219 (:documentation "Returns T if OBJECT1 divides OBJECT2.")
220 (:method ((m1 monom) (m2 monom))
221 "Returns T if monomial M1 divides monomial M2, NIL otherwise."
222 (with-slots ((exponents1 exponents))
223 m1
224 (with-slots ((exponents2 exponents))
225 m2
226 (every #'<= exponents1 exponents2)))))
227
228(defgeneric divides-lcm-p (object1 object2 object3)
229 (:documentation "Returns T if OBJECT1 divides LCM(OBJECT2,OBJECT3), NIL otherwise.")
230 (:method ((m1 monom) (m2 monom) (m3 monom))
231 "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
232 (with-slots ((exponents1 exponents))
233 m1
234 (with-slots ((exponents2 exponents))
235 m2
236 (with-slots ((exponents3 exponents))
237 m3
238 (every #'(lambda (x y z) (<= x (max y z)))
239 exponents1 exponents2 exponents3))))))
240
241(defgeneric lcm-divides-lcm-p (object1 object2 object3 object4)
242 (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
243 "Returns T if monomial LCM(M1,M2) divides LCM(M3,M4), NIL otherwise."
244 (with-slots ((exponents1 exponents))
245 m1
246 (with-slots ((exponents2 exponents))
247 m2
248 (with-slots ((exponents3 exponents))
249 m3
250 (with-slots ((exponents4 exponents))
251 m4
252 (every #'(lambda (x y z w) (<= (max x y) (max z w)))
253 exponents1 exponents2 exponents3 exponents4)))))))
254
255(defgeneric monom-lcm-equal-lcm-p (object1 object2 object3 object4)
256 (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
257 "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
258 (with-slots ((exponents1 exponents))
259 m1
260 (with-slots ((exponents2 exponents))
261 m2
262 (with-slots ((exponents3 exponents))
263 m3
264 (with-slots ((exponents4 exponents))
265 m4
266 (every
267 #'(lambda (x y z w) (= (max x y) (max z w)))
268 exponents1 exponents2 exponents3 exponents4)))))))
269
270(defgeneric divisible-by-p (object1 object2)
271 (:documentation "Return T if OBJECT1 is divisible by OBJECT2.")
272 (:method ((m1 monom) (m2 monom))
273 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
274 (with-slots ((exponents1 exponents))
275 m1
276 (with-slots ((exponents2 exponents))
277 m2
278 (every #'>= exponents1 exponents2)))))
279
280(defgeneric rel-prime-p (object1 object2)
281 (:documentation "Returns T if objects OBJECT1 and OBJECT2 are relatively prime.")
282 (:method ((m1 monom) (m2 monom))
283 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
284 (with-slots ((exponents1 exponents))
285 m1
286 (with-slots ((exponents2 exponents))
287 m2
288 (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2)))))
289
290(defgeneric universal-lcm (object1 object2)
291 (:documentation "Returns the multiple of objects OBJECT1 and OBJECT2.")
292 (:method ((m1 monom) (m2 monom))
293 "Returns least common multiple of monomials M1 and M2."
294 (with-slots ((exponents1 exponents))
295 m1
296 (with-slots ((exponents2 exponents))
297 m2
298 (let* ((exponents (copy-seq exponents1)))
299 (map-into exponents #'max exponents1 exponents2)
300 (make-instance 'monom :exponents exponents))))))
301
302
303(defmethod universal-gcd ((m1 monom) (m2 monom))
304 "Returns greatest common divisor of monomials M1 and M2."
305 (with-slots ((exponents1 exponents))
306 m1
307 (with-slots ((exponents2 exponents))
308 m2
309 (let* ((exponents (copy-seq exponents1)))
310 (map-into exponents #'min exponents1 exponents2)
311 (make-instance 'monom :exponents exponents)))))
312
313(defgeneric depends-p (object k)
314 (:documentation "Returns T iff object OBJECT depends on variable K.")
315 (:method ((m monom) k)
316 "Return T if the monomial M depends on variable number K."
317 (declare (type fixnum k))
318 (with-slots (exponents)
319 m
320 (plusp (elt exponents k)))))
321
322(defgeneric left-tensor-product-by (self other)
323 (:documentation "Returns a tensor product SELF by OTHER, stored into
324 SELF. Return SELF.")
325 (:method ((self monom) (other monom))
326 (with-slots ((exponents1 exponents))
327 self
328 (with-slots ((exponents2 exponents))
329 other
330 (setf exponents1 (concatenate 'vector exponents2 exponents1))))
331 self))
332
333(defgeneric right-tensor-product-by (self other)
334 (:documentation "Returns a tensor product of OTHER by SELF, stored
335 into SELF. Returns SELF.")
336 (:method ((self monom) (other monom))
337 (with-slots ((exponents1 exponents))
338 self
339 (with-slots ((exponents2 exponents))
340 other
341 (setf exponents1 (concatenate 'vector exponents1 exponents2))))
342 self))
343
344(defgeneric left-contract (self k)
345 (:documentation "Drop the first K variables in object SELF.")
346 (:method ((self monom) k)
347 "Drop the first K variables in monomial M."
348 (declare (fixnum k))
349 (with-slots (exponents)
350 self
351 (setf exponents (subseq exponents k)))
352 self))
353
354(defun make-monom-variable (nvars pos &optional (power 1)
355 &aux (m (make-instance 'monom :dimension nvars)))
356 "Construct a monomial in the polynomial ring
357RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
358which represents a single variable. It assumes number of variables
359NVARS and the variable is at position POS. Optionally, the variable
360may appear raised to power POWER. "
361 (declare (type fixnum nvars pos power) (type monom m))
362 (with-slots (exponents)
363 m
364 (setf (elt exponents pos) power)
365 m))
366
367(defun make-monom-constant (dimension)
368 (make-instance 'monom :dimension dimension))
369
370;; pure lexicographic
371(defgeneric lex> (p q &optional start end)
372 (:documentation "Return T if P>Q with respect to lexicographic
373order, otherwise NIL. The second returned value is T if P=Q,
374otherwise it is NIL.")
375 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
376 (declare (type fixnum start end))
377 (do ((i start (1+ i)))
378 ((>= i end) (values nil t))
379 (cond
380 ((> (monom-elt p i) (monom-elt q i))
381 (return-from lex> (values t nil)))
382 ((< (monom-elt p i) (monom-elt q i))
383 (return-from lex> (values nil nil)))))))
384
385;; total degree order, ties broken by lexicographic
386(defgeneric grlex> (p q &optional start end)
387 (:documentation "Return T if P>Q with respect to graded
388lexicographic order, otherwise NIL. The second returned value is T if
389P=Q, otherwise it is NIL.")
390 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
391 (declare (type monom p q) (type fixnum start end))
392 (let ((d1 (total-degree p start end))
393 (d2 (total-degree q start end)))
394 (declare (type fixnum d1 d2))
395 (cond
396 ((> d1 d2) (values t nil))
397 ((< d1 d2) (values nil nil))
398 (t
399 (lex> p q start end))))))
400
401;; reverse lexicographic
402(defgeneric revlex> (p q &optional start end)
403 (:documentation "Return T if P>Q with respect to reverse
404lexicographic order, NIL otherwise. The second returned value is T if
405P=Q, otherwise it is NIL. This is not and admissible monomial order
406because some sets do not have a minimal element. This order is useful
407in constructing other orders.")
408 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
409 (declare (type fixnum start end))
410 (do ((i (1- end) (1- i)))
411 ((< i start) (values nil t))
412 (declare (type fixnum i))
413 (cond
414 ((< (monom-elt p i) (monom-elt q i))
415 (return-from revlex> (values t nil)))
416 ((> (monom-elt p i) (monom-elt q i))
417 (return-from revlex> (values nil nil)))))))
418
419
420;; total degree, ties broken by reverse lexicographic
421(defgeneric grevlex> (p q &optional start end)
422 (:documentation "Return T if P>Q with respect to graded reverse
423lexicographic order, NIL otherwise. The second returned value is T if
424P=Q, otherwise it is NIL.")
425 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
426 (declare (type fixnum start end))
427 (let ((d1 (total-degree p start end))
428 (d2 (total-degree q start end)))
429 (declare (type fixnum d1 d2))
430 (cond
431 ((> d1 d2) (values t nil))
432 ((< d1 d2) (values nil nil))
433 (t
434 (revlex> p q start end))))))
435
436(defgeneric invlex> (p q &optional start end)
437 (:documentation "Return T if P>Q with respect to inverse
438lexicographic order, NIL otherwise The second returned value is T if
439P=Q, otherwise it is NIL.")
440 (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension p)))
441 (declare (type fixnum start end))
442 (do ((i (1- end) (1- i)))
443 ((< i start) (values nil t))
444 (declare (type fixnum i))
445 (cond
446 ((> (monom-elt p i) (monom-elt q i))
447 (return-from invlex> (values t nil)))
448 ((< (monom-elt p i) (monom-elt q i))
449 (return-from invlex> (values nil nil)))))))
450
451(defun reverse-monomial-order (order)
452 "Create the inverse monomial order to the given monomial order ORDER."
453 #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
454 (declare (type monom p q) (type fixnum start end))
455 (funcall order q p start end)))
456
457;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
458;;
459;; Order making functions
460;;
461;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
462
463;; This returns a closure with the same signature
464;; as all orders such as #'LEX>.
465(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
466 "It constructs an elimination order used for the 1-st elimination ideal,
467i.e. for eliminating the first variable. Thus, the order compares the degrees of the
468first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
469 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
470 (declare (type monom p q) (type fixnum start end))
471 (cond
472 ((> (monom-elt p start) (monom-elt q start))
473 (values t nil))
474 ((< (monom-elt p start) (monom-elt q start))
475 (values nil nil))
476 (t
477 (funcall secondary-elimination-order p q (1+ start) end)))))
478
479;; This returns a closure which is called with an integer argument.
480;; The result is *another closure* with the same signature as all
481;; orders such as #'LEX>.
482(defun make-elimination-order-factory (&optional
483 (primary-elimination-order #'lex>)
484 (secondary-elimination-order #'lex>))
485 "Return a function with a single integer argument K. This should be
486the number of initial K variables X[0],X[1],...,X[K-1], which precede
487remaining variables. The call to the closure creates a predicate
488which compares monomials according to the K-th elimination order. The
489monomial orders PRIMARY-ELIMINATION-ORDER and
490SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
491remaining variables, respectively, with ties broken by lexicographical
492order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
493which indicates that the first K variables appear with identical
494powers, then the result is that of a call to
495SECONDARY-ELIMINATION-ORDER applied to the remaining variables
496X[K],X[K+1],..."
497 #'(lambda (k)
498 (cond
499 ((<= k 0)
500 (error "K must be at least 1"))
501 ((= k 1)
502 (make-elimination-order-factory-1 secondary-elimination-order))
503 (t
504 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
505 (declare (type monom p q) (type fixnum start end))
506 (multiple-value-bind (primary equal)
507 (funcall primary-elimination-order p q start k)
508 (if equal
509 (funcall secondary-elimination-order p q k end)
510 (values primary nil))))))))
511
512(defclass term (monom)
513 ((coeff :initarg :coeff :initform 1 :accessor term-coeff :type ring))
514 (:default-initargs :coeff 1)
515 (:documentation "Implements a term, i.e. a product of a scalar
516and powers of some variables, such as 5*X^2*Y^3."))
517
518(defmethod shared-initialize :around ((self term) slot-names &rest initargs &key (coeff 1))
519 "A convenience method. If a coefficient is an integer, wrap it in the INTEGER-RING object"
520 ;; Dispatch on the type of supplied :COEFF arg
521 (typecase coeff
522 (integer
523 (setf (getf initargs :coeff) (make-instance 'integer-ring :value coeff)))
524 (rational
525 (setf (getf initargs :coeff) (make-instance 'rational-field :value coeff))))
526 ;; Now pass new initargs to the next method
527 (apply #'call-next-method (list* self slot-names initargs)))
528
529
530(defmethod update-instance-for-different-class :after ((old monom) (new term) &key (coeff 1))
531 "Converts OLD of class MONOM to a NEW of class TERM, initializing coefficient to COEFF."
532 (reinitialize-instance new :coeff coeff))
533
534(defmethod update-instance-for-different-class :after ((old term) (new term) &key (coeff (term-coeff old)))
535 "Converts OLD of class TERM to a NEW of class TERM, initializing coefficient to COEFF."
536 (reinitialize-instance new :coeff coeff))
537
538
539(defmethod print-object ((self term) stream)
540 (print-unreadable-object (self stream :type t :identity t)
541 (with-accessors ((exponents monom-exponents)
542 (coeff term-coeff))
543 self
544 (format stream "EXPONENTS=~A COEFF=~A"
545 exponents coeff))))
546
547(defmethod copy-instance :around ((object term) &rest initargs &key &allow-other-keys)
548 "An :AROUND method of COPY-INSTANCE. It replaces the coefficient with a fresh copy."
549 (declare (ignore object initargs))
550 (let ((copy (call-next-method)))
551 (setf (term-coeff copy) (copy-instance (term-coeff object)))
552 copy))
553
554#|
555(defmethod multiply-by ((self term) (other number))
556 (reinitialize-instance self :coeff (multiply-by (term-coeff self) other)))
557
558(defmethod divide-by ((self term) (other number))
559 (reinitialize-instance self :coeff (divide-by (term-coeff self) other)))
560|#
561
562(defmethod unary-inverse :after ((self term))
563 (with-slots (coeff)
564 self
565 (setf coeff (unary-inverse coeff))))
566
567(defun make-term-constant (dimension &optional (coeff 1))
568 (make-instance 'term :dimension dimension :coeff coeff))
569
570(defmethod universal-equalp ((term1 term) (term2 term))
571 "Returns T if TERM1 and TERM2 are equal as MONOM, and coefficients
572are UNIVERSAL-EQUALP."
573 (and (call-next-method)
574 (universal-equalp (term-coeff term1) (term-coeff term2))))
575
576(defmethod multiply-by :before ((self term) (other term))
577 "Destructively multiply terms SELF and OTHER and store the result into SELF.
578It returns SELF."
579 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
580
581(defmethod left-tensor-product-by :before ((self term) (other term))
582 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
583
584(defmethod right-tensor-product-by :before ((self term) (other term))
585 (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))
586
587(defmethod divide-by :before ((self term) (other term))
588 (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other))))
589
590(defmethod unary-minus ((self term))
591 (setf (term-coeff self) (unary-minus (term-coeff self)))
592 self)
593
594(defmethod universal-zerop ((self term))
595 (universal-zerop (term-coeff self)))
596
597(defgeneric ->list (self)
598 (:method ((self monom))
599 "A human-readable representation of a monomial SELF as a list of exponents."
600 (coerce (monom-exponents self) 'list))
601 (:method ((self term))
602 "A human-readable representation of a term SELF as a cons of the list of exponents and the coefficient."
603 (cons (coerce (monom-exponents self) 'list) (->sexp (term-coeff self)))))
604
605(defmethod ->sexp :before ((object monom) &optional vars)
606 "Check the length of variables VARS against the length of exponents in OBJECT."
607 (with-slots (exponents)
608 object
609 (assert (= (length vars) (length exponents))
610 nil
611 "Variables ~A and exponents ~A must have the same length." vars exponents)))
612
613(defmethod ->sexp ((object monom) &optional vars)
614 "Convert a monomial OBJECT to infix form, using variable VARS to build the representation."
615 (with-slots (exponents)
616 object
617 (let ((m (mapcan #'(lambda (var power)
618 (cond ((= power 0) nil)
619 ((= power 1) (list var))
620 (t (list `(expt ,var ,power)))))
621 vars (coerce exponents 'list))))
622 (cond ((endp m) 1)
623 ((endp (cdr m)) (car m))
624 (t
625 (cons '* m))))))
626
627(defmethod ->sexp :around ((object term) &optional vars)
628 "Convert a term OBJECT to S-expression, using variable VARS to build the representation."
629 (declare (ignore vars))
630 (with-slots (coeff)
631 object
632 (let ((monom-sexp (call-next-method))
633 (coeff-sexp (->sexp coeff)))
634 (cond ((eql coeff-sexp 1) monom-sexp)
635 ((atom monom-sexp)
636 (cond ((eql monom-sexp 1) coeff-sexp)
637 (t (list '* coeff-sexp monom-sexp))))
638 ((eql (car monom-sexp) '*)
639 (list* '* coeff-sexp (cdr monom-sexp)))
640 (t
641 (list '* coeff-sexp monom-sexp))))))
Note: See TracBrowser for help on using the repository browser.