;;; -*-  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 "MONOM"
  (:use :cl :ring)
  (:export "MONOM"
	   "EXPONENT"
	   "MONOM-DIMENSION"
	   "MONOM-EXPONENTS"
	   "MAKE-MONOM-VARIABLE")
  (:documentation
   "This package implements basic operations on monomials. 
DATA STRUCTURES: Conceptually, monomials can be represented as lists:

 	monom: (n1 n2 ... nk) where ni are non-negative integers

However, lists may be implemented as other sequence types, so the
flexibility to change the representation should be maintained in the
code to use general operations on sequences whenever possible. The
optimization for the actual representation should be left to
declarations and the compiler.

EXAMPLES: Suppose that variables are x and y. Then

 	Monom x*y^2 ---> (1 2) "))

(in-package :monom)

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

(deftype exponent ()
  "Type of exponent in a monomial."
  'fixnum)

(defclass monom ()
  ((dimension :initarg :dimension :accessor monom-dimension
	      :documentation "The number of variables.")
   (exponents :initarg :exponents :accessor monom-exponents
	      :documentation "The powers of the variables."))
  ;; default-initargs are not needed, they are handled by SHARED-INITIALIZE
  ;;(:default-initargs :dimension 'foo :exponents 'bar :exponent 'baz)
  (:documentation 
   "Implements a monomial, i.e. a product of powers
of variables, like X*Y^2."))

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

;; SHARED-INITIALIZE allows instance initialization in a style similar to MAKE-ARRAY, e.g.
;;
;; (MAKE-INSTANCE :EXPONENTS '(1 2 3))      --> #<MONOM DIMENSION=3 EXPONENTS=#(1 2 3)>
;; (MAKE-INSTANCE :DIMENSION 3)             --> #<MONOM DIMENSION=3 EXPONENTS=#(0 0 0)>
;; (MAKE-INSTANCE :DIMENSION 3 :EXPONENT 7) --> #<MONOM DIMENSION=3 EXPONENTS=#(7 7 7)>
;;
(defmethod initialize-instance :after ((self monom) slot-names
				       &key 
					 (dimension 0 dimension-supplied-p)
					 (exponents nil exponents-supplied-p)
					 (exponent  0 exponent-supplied-p)
				       &allow-other-keys
				       )
    (when (and dimension-supplied-p (slot-accessible-p 'dimension))
      (setf (slot-value self 'dimension) dimension))

    (when (and exponents-supplied-p (slot-accessible-p 'exponents))
      (let ((dim (length exponents)))
	(when (and dimension-supplied-p (/= dimension dim))
	  (error "EXPONENTS must have length DIMENSION")) 
	(setf (slot-value self 'dimension) dim
	      (slot-value self 'exponents) (make-array dim :initial-contents exponents))
	(setf (slot-value self 'dimension) (length exponents))))

    ;; when all exponents are to be identical
    (when (and exponent-supplied-p (slot-accessible-p 'exponents))
      (unless (slot-boundp self 'dimension)
	(error "Slot DIMENSION is unbound, but must be known if EXPONENT is supplied."))
      (let ((dim (slot-value self 'dimension)))
	(setf (slot-value self 'exponents)
	      (make-array (list dim) :initial-element exponent
			  :element-type 'exponent))))))

(defmethod r-equalp ((m1 monom) (m2 monom))
  "Returns T iff monomials M1 and M2 have identical
EXPONENTS."
  (equalp (monom-exponents m1) (monom-exponents m2)))

(defmethod r-coeff ((m monom))
  "A MONOM can be treated as a special case of TERM,
where the coefficient is 1."
  1)
  
(defmethod r-elt ((m monom) index)
  "Return the power in the monomial M of variable number INDEX."
  (with-slots (exponents)
      m
    (elt exponents index)))

(defmethod (setf r-elt) (new-value (m monom) index)
  "Return the power in the monomial M of variable number INDEX."
  (with-slots (exponents)
      m
    (setf (elt exponents index) new-value)))

(defmethod r-total-degree ((m monom) &optional (start 0) (end (monom-dimension m)))
  "Return the todal degree of a monomoal M. Optinally, a range
of variables may be specified with arguments START and END."
  (declare (type fixnum start end))
  (with-slots (exponents)
      m
    (reduce #'+ exponents :start start :end end)))


(defmethod r-sugar ((m monom) &aux (start 0) (end (monom-dimension m)))
  "Return the sugar of a monomial M. Optinally, a range
of variables may be specified with arguments START and END."
  (declare (type fixnum start end))
    (r-total-degree m start end))

(defmethod multiply-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      self
    (with-slots ((exponents2 exponents) (dimension2 dimension))
	other
      (unless (= dimension1 dimension2)
	(error "Incompatible dimensions: ~A and ~A.~%" dimension1 dimension2))
      (map-into exponents1 #'+ exponents1 exponents2)))
  self)

(defmethod divide-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      self
    (with-slots ((exponents2 exponents) (dimension2 dimension))
	other
      (unless (= dimension1 dimension2)
	(error "Incompatible dimensions: ~A and ~A.~%" dimension1 dimension2))
      (map-into exponents1 #'- exponents1 exponents2)))
  self)

(defmethod copy-instance :around ((object monom)  &rest initargs &key &allow-other-keys)
  "An :AROUNT method for COPY-INSTANCE. The primary method is a shallow copy,
  while for monomials we typically need a fresh copy of the
  exponents."
  (declare (ignore object initargs))
  (let ((copy (call-next-method)))
    (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))
    copy))

(defmethod r* ((m1 monom) (m2 monom))
  "Non-destructively multiply monomial M1 by M2."
  (multiply-by (copy-instance m1) (copy-instance m2)))

(defmethod r/ ((m1 monom) (m2 monom))
  "Non-destructively divide monomial M1 by monomial M2."
  (divide-by (copy-instance m1) (copy-instance m2)))

(defmethod r-divides-p ((m1 monom) (m2 monom))
  "Returns T if monomial M1 divides monomial M2, NIL otherwise."
  (with-slots ((exponents1 exponents))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (every #'<= exponents1 exponents2))))


(defmethod r-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom))
  "Returns T if monomial M1 divides LCM(M2,M3), NIL otherwise."
  (every #'(lambda (x y z) (<= x (max y z))) 
	 m1 m2 m3))


(defmethod r-lcm-divides-lcm-p ((m1 monom) (m2 monom) (m3 monom) (m4 monom))
  "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
  (declare (type monom m1 m2 m3 m4))
  (every #'(lambda (x y z w) (<= (max x y) (max z w))) 
	 m1 m2 m3 m4))
	 
(defmethod r-lcm-equal-lcm-p (m1 m2 m3 m4)
  "Returns T if monomial LCM(M1,M2) equals LCM(M3,M4), NIL otherwise."
  (with-slots ((exponents1 exponents))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (with-slots ((exponents3 exponents))
	  m3
	(with-slots ((exponents4 exponents))
	    m4
	  (every 
	   #'(lambda (x y z w) (= (max x y) (max z w)))
	   exponents1 exponents2 exponents3 exponents4))))))

(defmethod r-divisible-by-p ((m1 monom) (m2 monom))
  "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
  (with-slots ((exponents1 exponents))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (every #'>= exponents1 exponents2))))

(defmethod r-rel-prime-p ((m1 monom) (m2 monom))
  "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
  (with-slots ((exponents1 exponents))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (every #'(lambda (x y) (zerop (min x y))) exponents1 exponents2))))


(defmethod r-lcm ((m1 monom) (m2 monom)) 
  "Returns least common multiple of monomials M1 and M2."
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (let* ((exponents (copy-seq exponents1))
	     (dimension dimension1))
	(map-into exponents #'max exponents1 exponents2)
	(make-instance 'monom :dimension dimension :exponents exponents)))))


(defmethod r-gcd ((m1 monom) (m2 monom))
  "Returns greatest common divisor of monomials M1 and M2."
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      m1
    (with-slots ((exponents2 exponents))
	m2
      (let* ((exponents (copy-seq exponents1))
	     (dimension dimension1))
	(map-into exponents #'min exponents1 exponents2)
	(make-instance 'monom :dimension dimension :exponents exponents)))))

(defmethod r-depends-p ((m monom) k)
  "Return T if the monomial M depends on variable number K."
  (declare (type fixnum k))
  (with-slots (exponents)
      m
    (plusp (elt exponents k))))

(defmethod left-tensor-product-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      self
    (with-slots ((exponents2 exponents) (dimension2 dimension))
	other
      (setf dimension1 (+ dimension1 dimension2)
	    exponents1 (concatenate 'vector exponents2 exponents1))))
  self)

(defmethod right-tensor-product-by ((self monom) (other monom))
  (with-slots ((exponents1 exponents) (dimension1 dimension))
      self
    (with-slots ((exponents2 exponents) (dimension2 dimension))
	other
      (setf dimension1 (+ dimension1 dimension2)
	    exponents1 (concatenate 'vector exponents1 exponents2))))
  self)

(defmethod left-contract ((self monom) k)
  "Drop the first K variables in monomial M."
  (declare (fixnum k))
  (with-slots (dimension exponents) 
      self
    (setf dimension (- dimension k)
	  exponents (subseq exponents k)))
  self)

(defun make-monom-variable (nvars pos &optional (power 1)
			    &aux (m (make-instance 'monom :dimension nvars)))
  "Construct a monomial in the polynomial ring
RING[X[0],X[1],X[2],...X[NVARS-1]] over the (unspecified) ring RING
which represents a single variable. It assumes number of variables
NVARS and the variable is at position POS. Optionally, the variable
may appear raised to power POWER. "
  (declare (type fixnum nvars pos power) (type monom m))
  (with-slots (exponents)
      m
    (setf (elt exponents pos) power)
    m))

(defmethod r->list ((m monom))
  "A human-readable representation of a monomial M as a list of exponents."  
  (coerce (monom-exponents m) 'list))

(defmethod r-dimension ((self monom))
  (monom-dimension self))

(defmethod r-exponents ((self monom))
  (monom-exponents self))