[4502] | 1 | (in-package "POLYNOMIAL")
|
---|
| 2 |
|
---|
| 3 | (defgeneric static-sugar (object)
|
---|
| 4 | (:documentation "Return statically calculated sugar of object OBJECT. That is,
|
---|
| 5 | the sugar value which does not assume that the object is a result of any prior calculations.")
|
---|
| 6 | (:method ((object monom))
|
---|
[4505] | 7 | "Static sugar of a monom OBJECT is simply the total degree."
|
---|
[4502] | 8 | (total-degree object))
|
---|
| 9 | (:method ((object poly))
|
---|
[4505] | 10 | "Static sugar of a poly OBJECT is the maximum sugar of its terms."
|
---|
| 11 | (with-slots (termlist)
|
---|
[4502] | 12 | object
|
---|
[4511] | 13 | (loop for trm in termlist maximize (static-sugar trm)))))
|
---|
[4502] | 14 |
|
---|
| 15 | (defclass sugar ()
|
---|
[4507] | 16 | ((value :initarg :value :initform -1 :accessor sugar-value :type fixnum))
|
---|
[4509] | 17 | (:documentation "Sugar is a quantity added to various objects, such as monomials, terms and polynomials."))
|
---|
[4502] | 18 |
|
---|
| 19 | (defclass monom-with-sugar (monom sugar) ())
|
---|
| 20 |
|
---|
[4505] | 21 | (defmethod print-object ((self monom-with-sugar) stream)
|
---|
| 22 | (print-unreadable-object (self stream :type t :identity t)
|
---|
| 23 | (with-accessors ((exponents monom-exponents) (value sugar-value))
|
---|
| 24 | self
|
---|
| 25 | (format stream "EXPONENTS=~A SUGAR=~A"
|
---|
| 26 | exponents value))))
|
---|
| 27 |
|
---|
| 28 |
|
---|
[4502] | 29 | (defmethod shared-initialize :after ((self monom-with-sugar) slot-names &rest initargs &key)
|
---|
[4504] | 30 | "Initialize sugar value based on the exponents."
|
---|
[4502] | 31 | (declare (ignore slot-names initargs))
|
---|
[4504] | 32 | (setf (slot-value self 'value) (static-sugar self)))
|
---|
[4502] | 33 |
|
---|
[4514] | 34 | (defmethod update-instance-for-different-class :after ((old monom) (new monom-with-sugar) &key)
|
---|
[4515] | 35 | "Add sugar."
|
---|
[4514] | 36 | (reinitialize-instance new :value (static-sugar new)))
|
---|
| 37 |
|
---|
| 38 |
|
---|
[4511] | 39 | (defmethod multiply-by :after ((self sugar) (other sugar))
|
---|
| 40 | (with-slots (value)
|
---|
| 41 | self
|
---|
| 42 | (with-slots ((other-value value))
|
---|
| 43 | other
|
---|
| 44 | (incf value other-value)))
|
---|
| 45 | self)
|
---|
| 46 |
|
---|
[4512] | 47 | (defmethod divide-by :after ((self sugar) (other sugar))
|
---|
| 48 | (with-slots (value)
|
---|
| 49 | self
|
---|
| 50 | (with-slots ((other-value value))
|
---|
| 51 | other
|
---|
| 52 | (decf value other-value)))
|
---|
| 53 | self)
|
---|
| 54 |
|
---|
[4505] | 55 | (defclass term-with-sugar (term sugar) ())
|
---|
[4502] | 56 |
|
---|
[4505] | 57 | (defmethod print-object ((self term-with-sugar) stream)
|
---|
| 58 | (print-unreadable-object (self stream :type t :identity t)
|
---|
| 59 | (with-accessors ((exponents monom-exponents) (value sugar-value) (coeff term-coeff))
|
---|
| 60 | self
|
---|
| 61 | (format stream "EXPONENTS=~A COEFF=~A SUGAR=~A"
|
---|
| 62 | exponents coeff value))))
|
---|
[4510] | 63 |
|
---|
[4515] | 64 | (defmethod update-instance-for-different-class :after ((old term) (new term-with-sugar) &key)
|
---|
| 65 | "Add sugar."
|
---|
| 66 | (reinitialize-instance new :value (static-sugar new)))
|
---|
| 67 |
|
---|
| 68 |
|
---|
| 69 |
|
---|
[4510] | 70 | (defclass poly-with-sugar (poly sugar) ())
|
---|
| 71 |
|
---|
| 72 | (defmethod shared-initialize :after ((self poly-with-sugar) slot-names &rest initargs &key)
|
---|
[4511] | 73 | "Initialize sugar to its static value, which is the maximum of sugar values of the terms."
|
---|
[4510] | 74 | (declare (ignore slot-names initargs))
|
---|
| 75 | (setf (slot-value self 'value) (static-sugar self)))
|
---|
[4513] | 76 |
|
---|
[4514] | 77 | (defmethod update-instance-for-different-class :after ((old poly) (new poly-with-sugar) &key)
|
---|
| 78 | "Add sugar to every term."
|
---|
| 79 | (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term-with-sugar)) (poly-termlist new))))
|
---|
| 80 |
|
---|
| 81 | (defmethod update-instance-for-different-class :after ((old poly-with-sugar) (new poly) &key)
|
---|
| 82 | "Drop sugar in every term."
|
---|
| 83 | (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term)) (poly-termlist new))))
|
---|
| 84 |
|
---|
| 85 |
|
---|
[4513] | 86 | (defmethod add-to ((self poly-with-sugar) (other poly-with-sugar))
|
---|
| 87 | "Sugar value of the sum of two polynomials, SELF and OTHER, is by definition
|
---|
[4514] | 88 | the maximum of the sugar values of the summands."
|
---|
[4513] | 89 | (with-accessors ((value sugar-value))
|
---|
| 90 | self
|
---|
| 91 | (with-accessors ((other-value sugar-value))
|
---|
| 92 | other
|
---|
[4514] | 93 | (setf value (max value other-value))))
|
---|
| 94 | self)
|
---|
| 95 |
|
---|
| 96 | (defmethod multiply-by ((self poly-with-sugar) (other poly-with-sugar))
|
---|
| 97 | "Sugar value of the product of two polynomials, SELF and OTHER, is by definition
|
---|
| 98 | the sum of the sugar values of the factors."
|
---|
| 99 | (with-accessors ((value sugar-value))
|
---|
| 100 | self
|
---|
| 101 | (with-accessors ((other-value sugar-value))
|
---|
| 102 | other
|
---|
| 103 | (setf value (max value other-value))))
|
---|
| 104 | self)
|
---|