(uiop:define-package :st-buchberger/src/polynomial
(:mix :cl)
(:import-from "st-buchberger/src/parser")
(:mix-reexport :st-buchberger/src/polynomial-ring)
(:export #:polynomial #:lt #:lm #:lc #:multideg
 #:make-polynomial-from-term-list #:make-polynomial
 #:doterms #:mapterm #:print-object #:terms->list
 #:element->string #:ring-zero-p #:ring-copy
 #:base-ring #:terms))

(in-package :st-buchberger/src/polynomial)

(defclass polynomial (ring-element)
 ((base-ring
   :initarg :ring
   :initform (error "You must specify a base ring")
   :accessor base-ring)
  (terms
   :type hash-table
   :initarg :terms
   :initform (make-hash-table :test #'equalp)
   :accessor terms)))

(defgeneric lt (poly)
 (:documentation "Returns the leading term of a polynomial."))

(defgeneric lm (poly)
 (:documentation "Returns the leading monomial of a polynomial.
That is, the leading term with 1 as coefficient"))

(defgeneric lc (poly)
 (:documentation "Returns the leading coefficient of a polynomial"))

(defgeneric multideg (poly)
 (:documentation "Returns the multidegree of a polynomial"))

(defun make-polynomial-from-term-list (term-list &key (ring *ring*))
 "Return a polynomial on RING defined by TERM-LIST.

The terms are of the form (COEFFICIENT POWER-1 POWER-2 ...) where POWER-I is
the power to which the I-th indeterminate of RING is raised."
 (let ((poly (make-instance 'polynomial :ring ring)))
   (dolist (elem term-list poly)
     (setf poly
           (add poly
                (make-instance 'term
                               :coefficient (first elem)
                               :monomial (make-array (1- (length elem))
                                                     :initial-contents (rest elem))))))))

(defun make-polynomial (sexp &key (ring *ring*))
 "Return an instance of POLYNOMIAL in RING constructed from SEXP."
 (flet ((get-indeterminates (term)
          (parser:monomial-indeterminates (parser:term-monomial term))))
   (loop :with poly := (make-instance 'polynomial :ring ring)
         :and parsed := (parser:parse-polynomial sexp)
         :and variables := (variables ring)

         :for v := (make-array (length variables) :element-type '(integer 0)
                    :initial-element '0)
         :for term :in (parser:polynomial-terms parsed)
         :for c := (parser:term-coefficient term)

         :do (loop :for (indet . power) :in (get-indeterminates term)
                   :for idx := (position indet variables :key #'symbol-name
                                                         :test #'string=)
                   :unless idx :do
                     (error "Invalid indeterminate ~S." indet)
                   :do (incf (aref v idx) power)
                   :finally (setf poly
                                  (add poly
                                       (make-instance 'term :coefficient c
                                                            :monomial v))))

         :finally (return poly))))

(defmacro doterms ((var poly &optional resultform) &body body)
 (let ((mono (gensym "MONO"))
       (coef (gensym "COEF")))
   `(loop :for ,mono :being :the :hash-keys :of (terms ,poly)
            :using (hash-value ,coef) :do
              (let ((,var (make-instance 'term :coefficient
                                         ,coef :monomial ,mono)))
                ,@body)
          :finally (return ,resultform))))

(defun mapterm (function polynomial)
 "Apply FUNCTION to successive terms of POLYNOMIAL.  Return list
of FUNCTION return values."
 (let (results)
   (doterms (tt polynomial results)
     (push (funcall function tt) results))))

(defmethod print-object ((p polynomial) stream)
 (print-unreadable-object (p stream :type t)
   (write-string (element->string p) stream)))

(defun terms->list (poly)
 (mapterm #'identity poly))

(defmethod element->string ((poly polynomial) &key)
 (assert poly)
 (if (ring-zero-p poly)
     (format nil "0")
     (let ((term-list
             (sort (terms->list poly) *monomial-ordering* :key #'monomial)))
       (format nil "~a~{ ~a~}"
               (element->string (first term-list)
                                :ring (base-ring poly)
                                :leading-term t)
               (mapcar (lambda (x)
                         (element->string x :ring (base-ring poly)))
                       (rest term-list))))))

(defmethod ring-zero-p ((poly polynomial))
 (zerop (hash-table-count (terms poly))))

(defmethod ring-copy ((poly polynomial))
 "Returns a (deep) copy of the given polynomial"
 (let ((new-poly (make-instance 'polynomial :ring (base-ring poly))))
   (maphash (lambda (m c)
              (setf (gethash (copy-seq m) (terms new-poly)) c))
            (terms poly))
   new-poly))

(defmethod lt ((poly polynomial))
 (let ((term-list (terms->list poly)))
   (first (sort term-list *monomial-ordering* :key #'monomial))))

(defmethod lc ((poly polynomial))
 (coefficient (lt poly)))

(defmethod lm ((poly polynomial))
 (monomial (lt poly)))

(defmethod multideg ((poly polynomial))
 (lc poly))

You are viewing proxied material from tilde.institute. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.