source: CGBLisp/src/order.lisp@ 8

#|
        $Id: order.lisp,v 1.4 2009/01/23 10:39:41 marek Exp $   
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#
;; Order relations for vectors of numbers
;; Below p, q is a multiindex: p ---> (n1 n2 ... nk), where ni are
;; nonnegative integers. The package, though, will work with any
;; kind of real numbers.
;; These functions have a common interface
;; Their arguments are:
;; -two monomials P and Q to be compared
;; -function KEY which is called before comparing the entries
;; -START and END which restrict the index range for comparison
;; Each of the functions returs two values
;; -T or NIL depending on whether P>Q or not
;; -the second value is T if the sequences are equal

(defpackage "ORDER"
  (:use "COMMON-LISP")
  (:export
   lex>
   invlex>
   grlex>
   grevlex>
   elimination-order
   elimination-order-1
   total-degree))
   
(in-package "ORDER")

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

;; pure lexicographic
(defun lex> (p q &optional (start 0) (end (length 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."
  (do ((i start (1+ i)))
      ((>= i end) (values NIL T))
    (cond
     ((> (elt p i) (elt q i)) 
      (return-from lex> (values t nil)))
     ((< (elt p i) (elt q i))
      (return-from lex> (values nil nil))))))

;; total degree of a multiindex
(defun total-degree (m &optional (start 0) (end (length m)))
  "Return the todal degree of a monomoal M."
  (reduce #'+ (subseq m start end)))

;; total degree order , ties broken by lexicographic
(defun grlex> (p q &optional (start 0) (end (length 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."
  (let ((d1 (total-degree p start end))
        (d2 (total-degree q start end)))
    (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 (length 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."
  (do ((i (1- end) (1- i)))
      ((< i start) (values NIL T))
    (cond
     ((< (elt p i) (elt q i)) 
      (return-from revlex> (values t nil)))
     ((> (elt p i) (elt q i)) 
     (return-from revlex> (values nil nil))))))

;; total degree, ties broken by reverse lexicographic
(defun grevlex> (p q &optional (start 0) (end (length 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."
  (let ((d1 (total-degree p start end))
        (d2 (total-degree q start end)))
    (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 (length 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."
  (do ((i (1- end) (1- i)))
       ((< i start) (values NIL T))
      (cond
        ((> (elt p i) (elt q i)) 
         (return-from invlex> (values t nil)))
        ((< (elt p i) (elt q i)) 
         (return-from invlex> (values nil nil))))))


;;----------------------------------------------------------------
;; Order making functions
;;----------------------------------------------------------------

;; Make an order which compares the first K variables according to
;; PRIMARY-ORDER and the remaining elements according to
;; SECONDARY-ORDER
(defun elimination-order (k &key (primary-order #'lex>)
                            (secondary-order #'lex>))
  "Return a predicate which compares monomials according to the
K-th elimination order. Two optional arguments are PRIMARY-ORDER
and SECONDARY-ORDER and they should be term orders which are used
on the first K and the remaining variables."
  #'(lambda (p q &optional (start 0) (end (length p)))
      (multiple-value-bind (primary equal)
          (funcall primary-order p q start k)
        (if equal
            (funcall secondary-order p q k end)
          (values primary nil)))))

(defun elimination-order-1 (order)
  "A special case of the ELIMINATION-ORDER when there is only
one primary variable."
  #'(lambda (p q
             &optional (start 0)
                       (end (length p)))
      (cond
        ((> (elt p start) (elt q start)) (values t nil))
        ((< (elt p start) (elt q start)) (values nil nil))
        (t (funcall order p q (1+ start) end)))))