source: branches/f4grobner/monom.lisp@ 3458

;;; -*-  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 :copy)

  (:export "MONOM"

           "EXPONENT"

           "MONOM-DIMENSION"

           "MONOM-EXPONENTS"

           "MONOM-EQUALP"

           "MONOM-ELT"

           "MONOM-TOTAL-DEGREE"

           "MONOM-SUGRAR"

           "MONOM-MULTIPLY-BY"

           "MONOM-DIVIDE-BY"

           "MONOM-COPY-INSTANCE"

           "MONOM-MULTIPLY-2"

           "MONOM-MULTIPLY"

           "MONOM-DIVIDES-P"

           "MONOM-DIVIDES-LCM-P"

           "MONOM-LCM-DIVIDES-LCM-P"

           "MONOM-LCM-EQUAL-LCM-P"

           "MONOM-DIVISIBLE-BY-P"

           "MONOM-REL-PRIME-P"

           "MONOM-LCM"

           "MONOM-GCD"

           "MONOM-DEPENDS-P"

           "MONOM-LEFT-TENSOR-PRODUCT-BY"

           "MONOM-RIGHT-TENSOR-PRODUCT-BY"

           "MONOM-LEFT-CONTRACT"

           "MAKE-MONOM-VARIABLE"

           "MONOM->LIST")



  (: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 ()

  ((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 ((exponents monom-exponents))

        self

      (format stream "EXPONENTS=~A"

              exponents))))



(defmethod initialize-instance :after ((self monom)

                                       &key 

                                         (dimension 0 dimension-supplied-p)

                                         (exponents nil exponents-supplied-p)

                                         (exponent  0)

                                       &allow-other-keys

                                       )

  "The following INITIALIZE-INSTANCE method allows instance initialization

of a MONOM in a style similar to MAKE-ARRAY, e.g.:



 (MAKE-INSTANCE :EXPONENTS '(1 2 3))      --> #<MONOM EXPONENTS=#(1 2 3)>

 (MAKE-INSTANCE :DIMENSION 3)             --> #<MONOM EXPONENTS=#(0 0 0)>

 (MAKE-INSTANCE :DIMENSION 3 :EXPONENT 7) --> #<MONOM EXPONENTS=#(7 7 7)>



If both DIMENSION and EXPONENTS are supplied, they must be compatible,

i.e. the length of EXPONENTS must be equal DIMENSION. If EXPONENTS

is not supplied, a monom with repeated value EXPONENT is created.

By default EXPONENT is 0, which results in a constant monomial.

"

  (cond 

    (exponents-supplied-p

     (when (and dimension-supplied-p

                (/= dimension (length exponents)))

       (error "EXPONENTS (~A) must have supplied length DIMENSION (~A)"

              exponents dimension))

     (let ((dim (length exponents)))

       (setf (slot-value self 'exponents) (make-array dim :initial-contents exponents))))

    (dimension-supplied-p

     ;; when all exponents are to be identical

     (setf (slot-value self 'exponents) (make-array (list dimension) 

                                                    :initial-element exponent

                                                    :element-type 'exponent)))

    (t  

     (error "Initarg DIMENSION or EXPONENTS must be supplied."))))



(defgeneric monom-dimension (m)

  (:method ((m monom))

    (length (monom-exponents m))))



(defgeneric monom-equalp (m1 m2)

  (:documentation "Returns T iff monomials M1 and M2 have identical EXPONENTS.")

  (:method ((m1 monom) (m2 monom))

  `(equalp (monom-exponents ,m1) (monom-exponents ,m2))))



(defgeneric monom-elt (m index)

  (:documentation 

   "Return the power in the monomial M of variable number INDEX.")

  (:method ((m monom) index)

    (with-slots (exponents)

        m

      (elt exponents index))))



(defgeneric (setf monom-elt) (new-value m index)

  (:documentation "Return the power in the monomial M of variable number INDEX.")

  (:method (new-value (m monom) index)

    (with-slots (exponents)

        m

      (setf (elt exponents index) new-value))))



(defgeneric monom-total-degree (m &optional start end)

  (:documentation "Return the todal degree of a monomoal M. Optinally, a range

of variables may be specified with arguments START and END.")

  (:method ((m monom) &optional (start 0) (end (monom-dimension m)))

    (declare (type fixnum start end))

    (with-slots (exponents)

        m

      (reduce #'+ exponents :start start :end end))))



(defgeneric monom-sugar (m &optional start end)

  (:documentation "Return the sugar of a monomial M. Optinally, a range

of variables may be specified with arguments START and END.")

  (:method ((m monom)  &optional (start 0) (end (monom-dimension m)))

    (declare (type fixnum start end))

    (monom-total-degree m start end)))



(defgeneric monom-multiply-by (self other)

  (:method ((self monom) (other monom))

    (with-slots ((exponents1 exponents))

        self

      (with-slots ((exponents2 exponents))

          other

        (unless (= (length exponents1) (length exponents2))

          (error "Incompatible dimensions"))

        (map-into exponents1 #'+ exponents1 exponents2)))

  self))



(defgeneric monom-divide-by (self other)

  (:method ((self monom) (other monom))

    (with-slots ((exponents1 exponents))

        self

      (with-slots ((exponents2 exponents))

          other

        (unless (= (length exponents1) (length exponents2))

          (error "divide-by: Incompatible dimensions."))

        (unless (every #'>= exponents1 exponents2)

          (error "divide-by: Negative power would result."))

        (map-into exponents1 #'- exponents1 exponents2)))

  self))



(defmethod copy-instance :around ((object monom)  &rest initargs &key &allow-other-keys)

  "An :AROUND method of COPY-INSTANCE. It replaces

exponents with a fresh copy of the sequence."

    (declare (ignore object initargs))

    (let ((copy (call-next-method)))

      (setf (monom-exponents copy) (copy-seq (monom-exponents copy)))

      copy))



(defmethod monom-multiply-2 ((m1 monom) (m2 monom))

  "Non-destructively multiply monomial M1 by M2."

  (monom-multiply-by (copy-instance m1) (copy-instance m2)))



(defmethod monom-multiply ((numerator monom) &rest denominators)

  "Non-destructively divide monomial NUMERATOR by product of DENOMINATORS."

  (monom-divide-by (copy-instance numerator) (reduce #'monom-multiply-2 denominators)))



(defmethod monom-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 monom-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 monom-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 monom-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 monom-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 monom-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 monom-lcm ((m1 monom) (m2 monom)) 

  "Returns least common multiple of monomials M1 and M2."

  (with-slots ((exponents1 exponents))

      m1

    (with-slots ((exponents2 exponents))

        m2

      (let* ((exponents (copy-seq exponents1)))

        (map-into exponents #'max exponents1 exponents2)

        (make-instance 'monom :exponents exponents)))))





(defmethod monom-gcd ((m1 monom) (m2 monom))

  "Returns greatest common divisor of monomials M1 and M2."

  (with-slots ((exponents1 exponents))

      m1

    (with-slots ((exponents2 exponents))

        m2

      (let* ((exponents (copy-seq exponents1)))

        (map-into exponents #'min exponents1 exponents2)

        (make-instance 'monom :exponents exponents)))))



(defmethod monom-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 monom-left-tensor-product-by ((self monom) (other monom))

  (with-slots ((exponents1 exponents))

      self

    (with-slots ((exponents2 exponents))

        other

      (setf exponents1 (concatenate 'vector exponents2 exponents1))))

  self)



(defmethod monom-right-tensor-product-by ((self monom) (other monom))

  (with-slots ((exponents1 exponents))

      self

    (with-slots ((exponents2 exponents))

        other

      (setf exponents1 (concatenate 'vector exponents1 exponents2))))

  self)



(defmethod monom-left-contract ((self monom) k)

  "Drop the first K variables in monomial M."

  (declare (fixnum k))

  (with-slots (exponents) 

      self

    (setf 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 monom->list ((m monom))

  "A human-readable representation of a monomial M as a list of exponents."  

  (coerce (monom-exponents m) 'list))