;;----------------------------------------------------------------
;;; -*-  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 to a monom OLD."
  (reinitialize-instance new :value (static-sugar new)))


(defmethod multiply-by :after ((self sugar) (other sugar))
  "By definition, sugar is additive under multiplication."
  (with-slots (value)
      self
    (with-slots ((other-value value))
	other
      (incf 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))