source: branches/f4grobner/order.lisp@ 2320

;;; -*-  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.  

;;;                                                                              

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; Implementations of various admissible monomial orders

;; Implementation of order-making functions/closures.

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defpackage "ORDER"

  (:use :cl :monom)

  (:export "LEX>"

           "GRLEX>"

           "REVLEX>"

           "GREVLEX>"

           "INVLEX>"

           "REVERSE-MONOMIAL-ORDER"

           "MAKE-ELIMINATION-ORDER-FACTORY"))



(in-package :order)



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



;; pure lexicographic

(defun lex> (p q &optional (start 0) (end (monom-dimension  p)))

  "Return T if P>Q with respect to lexicographic order, otherwise NIL.

The second returned value is T if P=Q, otherwise it is NIL."

  (declare (type monom p q) (type fixnum start end))

  (do ((i start (1+ i)))

      ((>= i end) (values nil t))

    (cond

     ((> (monom-elt p i) (monom-elt q i))

      (return-from lex> (values t nil)))

     ((< (monom-elt p i) (monom-elt q i))

      (return-from lex> (values nil nil))))))



;; total degree order , ties broken by lexicographic

(defun grlex> (p q &optional (start 0) (end (monom-dimension  p)))

  "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.

The second returned value is T if P=Q, otherwise it is NIL."

  (declare (type monom p q) (type fixnum start end))

  (let ((d1 (monom-total-degree p start end))

        (d2 (monom-total-degree q start end)))

    (declare (type fixnum d1 d2))

    (cond

      ((> d1 d2) (values t nil))

      ((< d1 d2) (values nil nil))

      (t

        (lex> p q start end)))))





;; reverse lexicographic

(defun revlex> (p q &optional (start 0) (end (monom-dimension  p)))

  "Return T if P>Q with respect to reverse lexicographic order, NIL

otherwise.  The second returned value is T if P=Q, otherwise it is

NIL. This is not and admissible monomial order because some sets do

not have a minimal element. This order is useful in constructing other

orders."

  (declare (type monom p q) (type fixnum start end))

  (do ((i (1- end) (1- i)))

      ((< i start) (values nil t))

    (declare (type fixnum i))

    (cond

     ((< (monom-elt p i) (monom-elt q i))

      (return-from revlex> (values t nil)))

     ((> (monom-elt p i) (monom-elt q i))

      (return-from revlex> (values nil nil))))))





;; total degree, ties broken by reverse lexicographic

(defun grevlex> (p q &optional (start 0) (end (monom-dimension  p)))

  "Return T if P>Q with respect to graded reverse lexicographic order,

NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."

  (declare (type monom p q) (type fixnum start end))

  (let ((d1 (monom-total-degree p start end))

        (d2 (monom-total-degree q start end)))

    (declare (type fixnum d1 d2))

    (cond

     ((> d1 d2) (values t nil))

     ((< d1 d2) (values nil nil))

     (t

      (revlex> p q start end)))))



(defun invlex> (p q &optional (start 0) (end (monom-dimension  p)))

  "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise

The second returned value is T if P=Q, otherwise it is NIL."

  (declare (type monom p q) (type fixnum start end))

  (do ((i (1- end) (1- i)))

      ((< i start) (values nil t))

    (declare (type fixnum i))

    (cond

      ((> (monom-elt p i) (monom-elt q i))

       (return-from invlex> (values t nil)))

      ((< (monom-elt p i) (monom-elt q i))

       (return-from invlex> (values nil nil))))))





(defun reverse-monomial-order (order)

  "Create the inverse monomial order to the given monomial order ORDER."

  #'(lambda (p q &optional (start 0) (end (monom-dimension q))) 

      (declare (type monom p q) (type fixnum start end))

      (funcall order q p start end)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; Order making functions

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;; This returns a closure with the same signature

;; as all orders such as #'LEX>.

(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))

  "It constructs an elimination order used for the 1-st elimination ideal,

i.e. for eliminating the first variable. Thus, the order compares the degrees of the

first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."

  #'(lambda (p q &optional (start 0) (end (monom-dimension p)))

      (declare (type monom p q) (type fixnum start end))

      (cond

        ((> (monom-elt p start) (monom-elt q start))

         (values t nil))

        ((< (monom-elt p start) (monom-elt q start))

         (values nil nil))

        (t 

         (funcall secondary-elimination-order p q (1+ start) end)))))



;; This returns a closure which is called with an integer argument.

;; The result is *another closure* with the same signature as all

;; orders such as #'LEX>.

(defun make-elimination-order-factory (&optional 

                                         (primary-elimination-order #'lex>)

                                         (secondary-elimination-order #'lex>))

  "Return a function with a single integer argument K. This should be

the number of initial K variables X[0],X[1],...,X[K-1], which precede

remaining variables.  The call to the closure creates a predicate

which compares monomials according to the K-th elimination order. The

monomial orders PRIMARY-ELIMINATION-ORDER and

SECONDARY-ELIMINATION-ORDER are used to compare the first K and the

remaining variables, respectively, with ties broken by lexicographical

order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),

which indicates that the first K variables appear with identical

powers, then the result is that of a call to

SECONDARY-ELIMINATION-ORDER applied to the remaining variables

X[K],X[K+1],..."

  #'(lambda (k) 

      (cond 

        ((<= k 0) 

         (error "K must be at least 1"))

        ((= k 1)

         (make-elimination-order-factory-1 secondary-elimination-order))

        (t

         #'(lambda (p q &optional (start 0) (end (monom-dimension  p)))

             (declare (type monom p q) (type fixnum start end))

             (multiple-value-bind (primary equal)

                 (funcall primary-elimination-order p q start k)

               (if equal

                   (funcall secondary-elimination-order p q k end)

                   (values primary nil))))))))