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

;;----------------------------------------------------------------
;;; -*-  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 "POLYNOMIAL-SUGAR"
  (:use :cl :utils :monom :copy :ring :polynomial)
  (:export "MONOM-WITH-SUGAR"
           "TERM-WITH-SUGAR"
           "POLY-WITH-SUGAR"
           "STATIC-SUGAR"
           "SUGAR"
           "SUGAR-VALUE"
           "POLY-INSERT-TERM"
           "ADD-TO"
           "MULTIPLY-BY"
           "MAKE-UNIT-FOR"
           )
  (:documentation "Implements 'sugar'."))

(in-package "POLYNOMIAL-SUGAR")

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

(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-accessors ((termlist poly-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))
  (with-slots (value) 
      self
    (setf 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 shared-initialize :after ((self term-with-sugar) slot-names &rest initargs &key)
  (declare (ignore slot-names initargs))
  (with-slots (value)
      self
    (setf value (static-sugar self))))


(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 poly-insert-term :after ((self poly-with-sugar) (other term-with-sugar))
  (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)

(defmethod make-unit-for ((object poly-with-sugar))
  (change-class (call-next-method) 'poly-with-sugar))