source: branches/f4grobner/polynomial-sugar.lisp@ 4519

(in-package "POLYNOMIAL")

(defgeneric static-sugar (object)
  (:documentation "Return statically calculated sugar of object
OBJECT. That is, the sugar value which does not assume that the object
is a result of any prior calculations.")
  (:method ((object monom))
    "Static sugar of a monom OBJECT is simply the total degree."
    (total-degree object))
  (:method ((object poly))
    "Static sugar of a poly OBJECT is the maximum sugar of its terms."
  (with-slots (termlist)
        object
      (loop for trm in termlist maximize (static-sugar trm)))))

(defclass sugar ()
  ((value :initarg :value :initform -1 :accessor sugar-value :type fixnum))
  (:documentation "Sugar is a quantity added to various objects, such as monomials, terms and polynomials."))

(defclass monom-with-sugar (monom sugar) ())

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


(defmethod shared-initialize :after ((self monom-with-sugar) slot-names &rest initargs &key)
  "Initialize sugar value based on the exponents."
  (declare (ignore slot-names initargs))
  (setf (slot-value self 'value) (static-sugar self)))

(defmethod update-instance-for-different-class :after ((old monom) (new monom-with-sugar) &key)
  "Add sugar."
  (reinitialize-instance new :value (static-sugar new)))


(defmethod multiply-by :after ((self sugar) (other sugar))
  (with-slots (value)
      self
    (with-slots ((other-value value))
        other
      (incf value other-value)))
  self)

(defmethod divide-by :after ((self sugar) (other sugar))
  (with-slots (value)
      self
    (with-slots ((other-value value))
        other
      (decf value other-value)))
  self)

(defclass term-with-sugar (term sugar) ())

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

(defmethod update-instance-for-different-class :after ((old term) (new term-with-sugar) &key)
  "Add sugar."
  (reinitialize-instance new :value (static-sugar new)))

(defclass poly-with-sugar (poly sugar) ())

(defmethod print-object ((self poly-with-sugar) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (with-accessors ((termlist poly-termlist)
                     (order poly-term-order)
                     (value sugar-value))
        self
      (format stream "TERMLIST=~A ORDER=~A SUGAR=~A" 
              termlist order value))))


(defmethod shared-initialize :after ((self poly-with-sugar) slot-names &rest initargs &key)
  "Initialize sugar to its static value, which is the maximum of sugar values of the terms."
  (declare (ignore slot-names initargs))
  (setf (slot-value self 'value) (static-sugar self)))

(defmethod update-instance-for-different-class :after ((old poly) (new poly-with-sugar) &key)
  "Add sugar to every term."
  (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term-with-sugar)) (poly-termlist new))))

(defmethod update-instance-for-different-class :after ((old poly-with-sugar) (new poly) &key)
  "Drop sugar in every term."
  (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term)) (poly-termlist new))))

(defmethod add-to ((self poly-with-sugar) (other poly-with-sugar))
  "Sugar value of the sum of two polynomials, SELF and OTHER, is by definition
the maximum of the sugar values of the summands."
  (with-accessors ((value sugar-value))
      self
    (with-accessors ((other-value sugar-value))
        other
      (setf value (max value other-value))))
  self)

(defmethod multiply-by ((self poly-with-sugar) (other poly-with-sugar))
  "Sugar value of the product of two polynomials, SELF and OTHER, is by definition
the sum of the sugar values of the factors."
  (with-accessors ((value sugar-value))
      self
    (with-accessors ((other-value sugar-value))
        other
      (setf value (max value other-value))))
  self)