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

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

* empty log message *

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