source: branches/f4grobner/monom.lisp@ 4240

;;; -*-  Mode: Lisp -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>          
;;;                                                                              
;;;  This program is free software; you can redistribute it and/or modify        
;;;  it under the terms of the GNU General Public License as published by        
;;;  the Free Software Foundation; either version 2 of the License, or           
;;;  (at your option) any later version.                                         
;;;                                                                              
;;;  This program is distributed in the hope that it will be useful,             
;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of              
;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the               
;;;  GNU General Public License for more details.                                
;;;                                                                              
;;;  You should have received a copy of the GNU General Public License           
;;;  along with this program; if not, write to the Free Software                 
;;;  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
;;;                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "MONOM"
  (:use :cl :utils :copy :ring :integer-ring)
  (:export "MONOM"
           "TERM"
           "EXPONENT"
           "MONOM-DIMENSION"
           "MONOM-EXPONENTS"
           "UNIVERSAL-EQUALP"
           "MONOM-ELT"
           "TOTAL-DEGREE"
           "SUGAR"
           "MULTIPLY-BY"
           "DIVIDE-BY"
           "DIVIDE"
           "MULTIPLY"
           "DIVIDES-P"
           "DIVIDES-LCM-P"
           "LCM-DIVIDES-LCM-P"
           "LCM-EQUAL-LCM-P"
           "DIVISIBLE-BY-P"
           "REL-PRIME-P"
           "UNIVERSAL-LCM"
           "UNIVERSAL-GCD"
           "DEPENDS-P"
           "LEFT-TENSOR-PRODUCT-BY"
           "RIGHT-TENSOR-PRODUCT-BY"
           "LEFT-CONTRACT"
           "MAKE-MONOM-VARIABLE"
           "MAKE-MONOM-CONSTANT"
           "MAKE-TERM-CONSTANT"
           "->LIST"
           "->SEXP"
           "LEX>"
           "GRLEX>"
           "REVLEX>"
           "GREVLEX>"
           "INVLEX>"
           "REVERSE-MONOMIAL-ORDER"
           "MAKE-ELIMINATION-ORDER-FACTORY"
           "TERM-COEFF"
           "UNARY-MINUS"
           "UNARY-INVERSE"
           "UNIVERSAL-ZEROP")
  (:documentation
   "This package implements basic operations on monomials, including
various monomial orders.

DATA STRUCTURES: Conceptually, monomials can be represented as lists:

        monom: (n1 n2 ... nk) where ni are non-negative integers

However, lists may be implemented as other sequence types, so the
flexibility to change the representation should be maintained in the
code to use general operations on sequences whenever possible. The
optimization for the actual representation should be left to
declarations and the compiler.

EXAMPLES: Suppose that variables are x and y. Then

        Monom x*y^2 ---> (1 2) "))

(in-package :monom)

(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 0)))

(deftype exponent ()
  "Type of exponent in a monomial."
  'fixnum)

(defclass monom ()
  ((exponents :initarg :exponents :accessor monom-exponents
              :documentation "The powers of the variables."))
  ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
  ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
  (:documentation 
   "Implements a monomial, i.e. a product of powers
of variables, like X*Y^2."))

(defmethod print-object ((self monom) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (with-accessors ((exponents monom-exponents))
        self
      (format stream "EXPONENTS=~A"
              exponents))))

(defmethod initialize-instance :after ((self monom)
                                       &key 
                                         (dimension 0 dimension-supplied-p)
                                         (exponents nil exponents-supplied-p)
                                         (exponent  0)
                                       &allow-other-keys
                                       )
  "The following INITIALIZE-INSTANCE method allows instance initialization
of a MONOM in a style similar to MAKE-ARRAY, e.g.:

 (MAKE-INSTANCE 'MONOM :EXPONENTS '(1 2 3))      --> #<MONOM EXPONENTS=#(1 2 3)>
 (MAKE-INSTANCE 'MONOM :DIMENSION 3)             --> #<MONOM EXPONENTS=#(0 0 0)>
 (MAKE-INSTANCE 'MONOM :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>

If both DIMENSION and EXPONENTS are supplied, they must be compatible,
i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS
is not supplied, a monom with repeated value EXPONENT is created.
By default EXPONENT is 0, which results in a constant monomial.
"
  (cond 
    (exponents-supplied-p
     (when (and dimension-supplied-p
                (/= dimension (length exponents)))
       (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"
              exponents dimension))
     (let ((dim (length exponents)))
       (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))
    (dimension-supplied-p
     ;; when all exponents are to be identical
     (setf (slot-value self 'exponents) (make-array (list dimension) 
                                                    :initial-element exponent
                                                    :element-type 'exponent)))
    (t  
     (error "Initarg DIMENSION or EXPONENTS must be supplied."))))

(defgeneric monom-dimension (self)
  (:method ((self monom))
    (length (monom-exponents self))))

(defmethod universal-equalp ((self monom) (other monom))
    "Returns T iff monomials SELF and OTHER have identical EXPONENTS."
  (equalp (monom-exponents self) (monom-exponents other)))

(defgeneric monom-elt (m index)
  (:documentation "Return the power in the monomial M of variable number INDEX.")
  (:method ((m monom) index)
    "Return the power in the monomial M of variable number INDEX."
    (with-slots (exponents)
        m
      (elt exponents index))))

(defgeneric (setf monom-elt) (new-value m index)
  (:documentation "Set the power in the monomial M of variable number INDEX.")
  (:method (new-value (m monom) index)
    (with-slots (exponents)
        m
      (setf (elt exponents index) new-value))))

(defgeneric total-degree (m &optional start end)
  (:documentation "Return the total degree of a monomoal M. Optinally, a range
of variables may be specified with arguments START and END.")
  (:method ((m monom) &optional (start 0) (end (monom-dimension m)))
    (declare (type fixnum start end))
    (with-slots (exponents)
        m
      (reduce #'+ exponents :start start :end end))))

(defgeneric sugar (m &optional start end)
  (:documentation "Return the sugar of a monomial M. Optinally, a range
of variables may be specified with arguments START and END.")
  (:method ((m monom)  &optional (start 0) (end (monom-dimension m)))
    (declare (type fixnum start end))
    (total-degree m start end)))

(defmethod multiply-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents))
      self
    (with-slots ((exponents2 exponents))
        other
      (unless (= (length exponents1) (length exponents2))
        (error "Incompatible dimensions"))
      (map-into exponents1 #'+ exponents1 exponents2)))
  self)

(defun multiply (factor &rest more-factors)
  "Successively multiplies factor FACTOR by the remaining arguments
MORE-FACTORS, using MULTIPLY-BY to multiply two factors. Thus
FACTOR may be destructively modified."
  (reduce #'multiply-by more-factors :initial-value (copy-instance factor)))

(defmethod divide-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents))
      self
    (with-slots ((exponents2 exponents))
        other
      (unless (= (length exponents1) (length exponents2))
        (error "divide-by: Incompatible dimensions."))
      (unless (every #'>= exponents1 exponents2)
        (error "divide-by: Negative power would result."))
      (map-into exponents1 #'- exponents1 exponents2)))
  self)

(defmethod copy-instance :around ((object monom)  &rest initargs &key &allow-other-keys)
  "An :AROUND method of COPY-INSTANCE. It replaces exponents with a fresh copy of the sequence."
  (declare (ignore object initargs))
  (let ((copy (call-next-method)))
    (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
    copy))

(defmethod unary-inverse :before ((self monom))
  (assert (zerop (total-degree self))
          nil
          "Monom ~A must have total degree 0 to be invertible.")
  self)

(defmethod unary-inverse ((self monom)) self)

(defun divide (numerator &rest denominators)
  "Successively divides NUMERATOR by elements of DENOMINATORS. The operation
destructively modifies NUMERATOR."
  (cond ((endp denominators)
         (unary-inverse numerator))
        (t (reduce #'divide-by denominators :initial-value (copy-instance numerator)))))

(defgeneric divides-p (object1 object2)
  (:documentation "Returns T if OBJECT1 divides OBJECT2.")
  (:method ((m1 monom) (m2 monom))
    "Returns T if monomial M1 divides monomial M2, NIL otherwise."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (every #'<= exponents1 exponents2)))))

(defgeneric divides-lcm-p (object1 object2 object3) 
  (:documentation "Returns T if OBJECT1 divides LCM(OBJECT2,OBJECT3), NIL otherwise.")
  (:method ((m1 monom) (m2 monom) (m3 monom))
    "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (with-slots ((exponents3 exponents))
            m3
          (every #'(lambda (x y z) (<= x (max y z))) 
                 exponents1 exponents2 exponents3))))))

(defgeneric lcm-divides-lcm-p (object1 object2 object3 object4)
  (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
    "Returns T if monomial LCM(M1,M2) divides LCM(M3,M4), NIL otherwise."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (with-slots ((exponents3 exponents))
            m3
          (with-slots ((exponents4 exponents))
              m4
            (every #'(lambda (x y z w) (<= (max x y) (max z w))) 
                   exponents1 exponents2 exponents3 exponents4)))))))
         
(defgeneric monom-lcm-equal-lcm-p (object1 object2 object3 object4)
  (:method ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
    "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (with-slots ((exponents3 exponents))
            m3
          (with-slots ((exponents4 exponents))
              m4
            (every 
             #'(lambda (x y z w) (= (max x y) (max z w)))
             exponents1 exponents2 exponents3 exponents4)))))))

(defgeneric divisible-by-p (object1 object2)
  (:documentation "Return T if OBJECT1 is divisible by OBJECT2.")
  (:method ((m1 monom) (m2 monom))
    "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (every #'>= exponents1 exponents2)))))

(defgeneric rel-prime-p (object1 object2)
  (:documentation "Returns T if objects OBJECT1 and OBJECT2 are relatively prime.")
  (:method ((m1 monom) (m2 monom))
    "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2)))))

(defgeneric universal-lcm (object1 object2)
  (:documentation "Returns the multiple of objects OBJECT1 and OBJECT2.")
  (:method ((m1 monom) (m2 monom))
    "Returns least common multiple of monomials M1 and M2."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (let* ((exponents (copy-seq exponents1)))
          (map-into exponents #'max exponents1 exponents2)
          (make-instance 'monom :exponents exponents))))))


(defgeneric universal-gcd (object1 object2)
  (:documentation "Returns GCD of objects OBJECT1 and OBJECT2")
  (:method ((m1 monom) (m2 monom))
    "Returns greatest common divisor of monomials M1 and M2."
    (with-slots ((exponents1 exponents))
        m1
      (with-slots ((exponents2 exponents))
          m2
        (let* ((exponents (copy-seq exponents1)))
          (map-into exponents #'min exponents1 exponents2)
          (make-instance 'monom :exponents exponents))))))

(defgeneric depends-p (object k)
  (:documentation "Returns T iff object OBJECT depends on variable K.")
  (:method ((m monom) k)
    "Return T if the monomial M depends on variable number K."
    (declare (type fixnum k))
    (with-slots (exponents)
        m
      (plusp (elt exponents k)))))

(defgeneric left-tensor-product-by (self other)
  (:documentation "Returns a tensor product SELF by OTHER, stored into
  SELF. Return SELF.")
  (:method ((self monom) (other monom))
    (with-slots ((exponents1 exponents))
        self
      (with-slots ((exponents2 exponents))
          other
        (setf exponents1 (concatenate 'vector exponents2 exponents1))))
    self))

(defgeneric right-tensor-product-by (self other)
  (:documentation "Returns a tensor product of OTHER by SELF, stored
  into SELF. Returns SELF.")
  (:method ((self monom) (other monom))
    (with-slots ((exponents1 exponents))
        self
      (with-slots ((exponents2 exponents))
          other
        (setf exponents1 (concatenate 'vector exponents1 exponents2))))
    self))

(defgeneric left-contract (self k)
  (:documentation "Drop the first K variables in object SELF.")
  (:method ((self monom) k)
    "Drop the first K variables in monomial M."
    (declare (fixnum k))
    (with-slots (exponents) 
        self
      (setf exponents (subseq exponents k)))
    self))

(defun make-monom-variable (nvars pos &optional (power 1)
                            &aux (m (make-instance 'monom :dimension nvars)))
  "Construct a monomial in the polynomial ring
RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
which represents a single variable. It assumes number of variables
NVARS and the variable is at position POS. Optionally, the variable
may appear raised to power POWER. "
  (declare (type fixnum nvars pos power) (type monom m))
  (with-slots (exponents)
      m
    (setf (elt exponents pos) power)
    m))

(defun make-monom-constant (dimension)
  (make-instance 'monom :dimension dimension))

;; pure lexicographic
(defgeneric lex> (p q &optional start end)
  (:documentation "Return T if P>Q with respect to lexicographic
order, otherwise NIL.  The second returned value is T if P=Q,
otherwise it is NIL.")
  (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension  p)))
    (declare (type fixnum start end))
    (do ((i start (1+ i)))
        ((>= i end) (values nil t))
      (cond
        ((> (monom-elt p i) (monom-elt q i))
         (return-from lex> (values t nil)))
        ((< (monom-elt p i) (monom-elt q i))
         (return-from lex> (values nil nil)))))))

;; total degree order, ties broken by lexicographic
(defgeneric grlex> (p q &optional start end)
  (:documentation "Return T if P>Q with respect to graded
lexicographic order, otherwise NIL.  The second returned value is T if
P=Q, otherwise it is NIL.")
  (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension  p)))
    (declare (type monom p q) (type fixnum start end))
    (let ((d1 (total-degree p start end))
          (d2 (total-degree q start end)))
      (declare (type fixnum d1 d2))
      (cond
        ((> d1 d2) (values t nil))
        ((< d1 d2) (values nil nil))
        (t
         (lex> p q start end))))))

;; reverse lexicographic
(defgeneric revlex> (p q &optional start end)
  (:documentation "Return T if P>Q with respect to reverse
lexicographic order, NIL otherwise.  The second returned value is T if
P=Q, otherwise it is NIL. This is not and admissible monomial order
because some sets do not have a minimal element. This order is useful
in constructing other orders.")
  (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension  p)))
    (declare (type fixnum start end))
    (do ((i (1- end) (1- i)))
        ((< i start) (values nil t))
      (declare (type fixnum i))
      (cond
        ((< (monom-elt p i) (monom-elt q i))
         (return-from revlex> (values t nil)))
        ((> (monom-elt p i) (monom-elt q i))
         (return-from revlex> (values nil nil)))))))


;; total degree, ties broken by reverse lexicographic
(defgeneric grevlex> (p q &optional start end)
  (:documentation "Return T if P>Q with respect to graded reverse
lexicographic order, NIL otherwise. The second returned value is T if
P=Q, otherwise it is NIL.")
  (:method  ((p monom) (q monom) &optional (start 0) (end (monom-dimension  p)))
    (declare (type fixnum start end))
    (let ((d1 (total-degree p start end))
          (d2 (total-degree q start end)))
      (declare (type fixnum d1 d2))
      (cond
        ((> d1 d2) (values t nil))
        ((< d1 d2) (values nil nil))
        (t
         (revlex> p q start end))))))

(defgeneric invlex> (p q &optional start end)
  (:documentation "Return T if P>Q with respect to inverse
lexicographic order, NIL otherwise The second returned value is T if
P=Q, otherwise it is NIL.")
  (:method ((p monom) (q monom) &optional (start 0) (end (monom-dimension  p)))
    (declare  (type fixnum start end))
    (do ((i (1- end) (1- i)))
        ((< i start) (values nil t))
      (declare (type fixnum i))
      (cond
        ((> (monom-elt p i) (monom-elt q i))
         (return-from invlex> (values t nil)))
        ((< (monom-elt p i) (monom-elt q i))
         (return-from invlex> (values nil nil)))))))

(defun reverse-monomial-order (order)
  "Create the inverse monomial order to the given monomial order ORDER."
  #'(lambda (p q &optional (start 0) (end (monom-dimension q))) 
      (declare (type monom p q) (type fixnum start end))
      (funcall order q p start end)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Order making functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This returns a closure with the same signature
;; as all orders such as #'LEX>.
(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
  "It constructs an elimination order used for the 1-st elimination ideal,
i.e. for eliminating the first variable. Thus, the order compares the degrees of the
first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
  #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
      (declare (type monom p q) (type fixnum start end))
      (cond
        ((> (monom-elt p start) (monom-elt q start))
         (values t nil))
        ((< (monom-elt p start) (monom-elt q start))
         (values nil nil))
        (t 
         (funcall secondary-elimination-order p q (1+ start) end)))))

;; This returns a closure which is called with an integer argument.
;; The result is *another closure* with the same signature as all
;; orders such as #'LEX>.
(defun make-elimination-order-factory (&optional 
                                         (primary-elimination-order #'lex>)
                                         (secondary-elimination-order #'lex>))
  "Return a function with a single integer argument K. This should be
the number of initial K variables X[0],X[1],...,X[K-1], which precede
remaining variables.  The call to the closure creates a predicate
which compares monomials according to the K-th elimination order. The
monomial orders PRIMARY-ELIMINATION-ORDER and
SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
remaining variables, respectively, with ties broken by lexicographical
order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
which indicates that the first K variables appear with identical
powers, then the result is that of a call to
SECONDARY-ELIMINATION-ORDER applied to the remaining variables
X[K],X[K+1],..."
  #'(lambda (k) 
      (cond 
        ((<= k 0) 
         (error "K must be at least 1"))
        ((= k 1)
         (make-elimination-order-factory-1 secondary-elimination-order))
        (t
         #'(lambda (p q &optional (start 0) (end (monom-dimension  p)))
             (declare (type monom p q) (type fixnum start end))
             (multiple-value-bind (primary equal)
                 (funcall primary-elimination-order p q start k)
               (if equal
                   (funcall secondary-elimination-order p q k end)
                   (values primary nil))))))))

(defclass term (monom)
  ((coeff :initarg :coeff :accessor term-coeff :type ring))
  (:default-initargs :coeff 1)
  (:documentation "Implements a term, i.e. a product of a scalar
and powers of some variables, such as 5*X^2*Y^3."))

(defmethod initialize-instance :around ((self term) &rest initargs &key (coeff 1))
  "A convenience method. If a coefficient is an integer, wrap it in the INTEGER-RING object"
  ;; Dispatch on supplied type of coefficient
  (typecase coeff
    (integer
     (setf (getf initargs :coeff) (make-instance 'integer-ring :value coeff))))
  ;; Now pass new initargs to the next method
  (apply #'call-next-method (cons self initargs)))
  
(defmethod update-instance-for-different-class :after ((old monom) (new term) &key coeff)
  "Converts OLD of class MONOM to a NEW of class TERM, initializing coefficient to COEFF."
  (reinitialize-instance new :coeff coeff))

(defmethod update-instance-for-different-class :after ((old term) (new term) &key (coeff (term-coeff old)))
  "Converts OLD of class TERM to a NEW of class TERM, initializing coefficient to COEFF."
  (reinitialize-instance new :coeff coeff))


(defmethod print-object ((self term) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (with-accessors ((exponents monom-exponents)
                     (coeff term-coeff))
        self
      (format stream "EXPONENTS=~A COEFF=~A"
              exponents coeff))))

(defmethod copy-instance :around ((object term)  &rest initargs &key &allow-other-keys)
  "An :AROUND method of COPY-INSTANCE. It replaces the coefficient with a fresh copy."
    (declare (ignore object initargs))
    (let ((copy (call-next-method)))
      (setf (term-coeff copy) (copy-instance (term-coeff object)))
      copy))

(defmethod multiply-by ((self term) (other number))
  (reinitialize-instance self :coeff (multiply-by (term-coeff self) other)))

(defmethod divide-by ((self term) (other number))
  (reinitialize-instance self :coeff (divide-by (term-coeff self) other)))

(defmethod unary-inverse :after ((self term))
           (with-slots (coeff)
               self
             (setf coeff (unary-inverse coeff))))

(defun make-term-constant (dimension &optional (coeff 1))
  (make-instance 'term :dimension dimension :coeff coeff))

(defmethod universal-equalp ((term1 term) (term2 term))
  "Returns T if TERM1 and TERM2 are equal as MONOM, and coefficients
are UNIVERSAL-EQUALP."
  (and (call-next-method)
       (universal-equalp (term-coeff term1) (term-coeff term2))))

(defmethod multiply-by :before ((self term) (other term))
  "Destructively multiply terms SELF and OTHER and store the result into SELF.
It returns SELF."
  (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))


(defmethod left-tensor-product-by :before ((self term) (other term))
  (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))

(defmethod right-tensor-product-by :before ((self term) (other term))
  (setf (term-coeff self) (multiply-by (term-coeff self) (term-coeff other))))

(defmethod divide-by :before ((self term) (other term))
  (setf (term-coeff self) (divide-by (term-coeff self) (term-coeff other))))

(defmethod unary-minus ((self term))
  (setf (term-coeff self) (unary-minus (term-coeff self)))
  self)

(defgeneric universal-zerop (self) 
  (:documentation "Return T iff SELF is zero.")
  (:method ((self number)) (zerop self))
  (:method ((self term))
    (universal-zerop (term-coeff self))))

(defgeneric ->list (self)
  (:method ((self monom))
    "A human-readable representation of a monomial SELF as a list of exponents."  
    (coerce (monom-exponents self) 'list))
  (:method ((self term))
    "A human-readable representation of a term SELF as a cons of the list of exponents and the coefficient."
    (cons (coerce (monom-exponents self) 'list) (->sexp (term-coeff self)))))

(defgeneric ->sexp (object &optional vars)
  (:documentation "Convert a polynomial OBJECT to an S-expression, using variables VARS.")
  (:method :before ((object monom) &optional vars)
           "Check the length of variables VARS against the length of exponents in OBJECT."
           (with-slots (exponents)
               object
             (assert (= (length vars) (length exponents))
                     nil
                     "Variables ~A and exponents ~A must have the same length." vars exponents)))
  (:method ((object monom) &optional vars)
    "Convert a monomial OBJECT to infix form, using variable VARS to build the representation."
    (with-slots (exponents) 
        object
      (let ((m (mapcan #'(lambda (var power) 
                                 (cond ((= power 0) nil)
                                       ((= power 1) (list var))
                                       (t (list `(expt ,var ,power)))))
                       vars (coerce exponents 'list))))
        (cond ((endp m) 1)
              ((endp (cdr m)) (car m))
              (t 
               (cons '* m))))))
  (:method :around ((object term) &optional vars)
    "Convert a term OBJECT to infix form, using variable VARS to build the representation."
    (declare (ignore vars))
    (with-slots (coeff) 
        object
      (let ((monom-sexp (call-next-method))
            (coeff-sexp (->sexp coeff)))
        (cond ((eql coeff-sexp 1) monom-sexp)
              ((atom monom-sexp) 
               (cond ((eql monom-sexp 1) coeff-sexp)
                     (t (list '* coeff-sexp monom-sexp))))
              ((eql (car monom-sexp) '*) 
               (list* '* coeff-sexp (cdr monom-sexp)))
              (t 
               (list '* coeff-sexp monom-sexp)))))))