[1] | 1 | #|
|
---|
| 2 | $Id: order.lisp,v 1.4 2009/01/23 10:39:41 marek Exp $
|
---|
| 3 | *--------------------------------------------------------------------------*
|
---|
| 4 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu) |
|
---|
| 5 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
| 6 | | |
|
---|
| 7 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
| 8 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
| 9 | *--------------------------------------------------------------------------*
|
---|
| 10 | |#
|
---|
| 11 | ;; Order relations for vectors of numbers
|
---|
| 12 | ;; Below p, q is a multiindex: p ---> (n1 n2 ... nk), where ni are
|
---|
| 13 | ;; nonnegative integers. The package, though, will work with any
|
---|
| 14 | ;; kind of real numbers.
|
---|
| 15 | ;; These functions have a common interface
|
---|
| 16 | ;; Their arguments are:
|
---|
| 17 | ;; -two monomials P and Q to be compared
|
---|
| 18 | ;; -function KEY which is called before comparing the entries
|
---|
| 19 | ;; -START and END which restrict the index range for comparison
|
---|
| 20 | ;; Each of the functions returs two values
|
---|
| 21 | ;; -T or NIL depending on whether P>Q or not
|
---|
| 22 | ;; -the second value is T if the sequences are equal
|
---|
| 23 |
|
---|
| 24 | (defpackage "ORDER"
|
---|
| 25 | (:use "COMMON-LISP")
|
---|
| 26 | (:export
|
---|
| 27 | lex>
|
---|
| 28 | invlex>
|
---|
| 29 | grlex>
|
---|
| 30 | grevlex>
|
---|
| 31 | elimination-order
|
---|
| 32 | elimination-order-1
|
---|
| 33 | total-degree))
|
---|
| 34 |
|
---|
| 35 | (in-package "ORDER")
|
---|
| 36 |
|
---|
[8] | 37 | (proclaim '(optimize (speed 0) (debug 3)))
|
---|
[1] | 38 |
|
---|
| 39 | ;; pure lexicographic
|
---|
| 40 | (defun lex> (p q &optional (start 0) (end (length p)))
|
---|
| 41 | "Return T if P>Q with respect to lexicographic order, otherwise NIL.
|
---|
| 42 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 43 | (do ((i start (1+ i)))
|
---|
| 44 | ((>= i end) (values NIL T))
|
---|
| 45 | (cond
|
---|
| 46 | ((> (elt p i) (elt q i))
|
---|
| 47 | (return-from lex> (values t nil)))
|
---|
| 48 | ((< (elt p i) (elt q i))
|
---|
| 49 | (return-from lex> (values nil nil))))))
|
---|
| 50 |
|
---|
| 51 | ;; total degree of a multiindex
|
---|
| 52 | (defun total-degree (m &optional (start 0) (end (length m)))
|
---|
| 53 | "Return the todal degree of a monomoal M."
|
---|
| 54 | (reduce #'+ (subseq m start end)))
|
---|
| 55 |
|
---|
| 56 | ;; total degree order , ties broken by lexicographic
|
---|
| 57 | (defun grlex> (p q &optional (start 0) (end (length p)))
|
---|
| 58 | "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
|
---|
| 59 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 60 | (let ((d1 (total-degree p start end))
|
---|
| 61 | (d2 (total-degree q start end)))
|
---|
| 62 | (cond
|
---|
| 63 | ((> d1 d2) (values t nil))
|
---|
| 64 | ((< d1 d2) (values nil nil))
|
---|
| 65 | (t
|
---|
| 66 | (lex> p q start end)))))
|
---|
| 67 |
|
---|
| 68 | ;; reverse lexicographic
|
---|
| 69 | (defun revlex> (p q &optional (start 0) (end (length p)))
|
---|
| 70 | "Return T if P>Q with respect to reverse lexicographic order, NIL
|
---|
| 71 | otherwise. The second returned value is T if P=Q, otherwise it is
|
---|
| 72 | NIL. This is not and admissible monomial order because some sets do
|
---|
| 73 | not have a minimal element. This order is useful in constructing other
|
---|
| 74 | orders."
|
---|
| 75 | (do ((i (1- end) (1- i)))
|
---|
| 76 | ((< i start) (values NIL T))
|
---|
| 77 | (cond
|
---|
| 78 | ((< (elt p i) (elt q i))
|
---|
| 79 | (return-from revlex> (values t nil)))
|
---|
| 80 | ((> (elt p i) (elt q i))
|
---|
| 81 | (return-from revlex> (values nil nil))))))
|
---|
| 82 |
|
---|
| 83 | ;; total degree, ties broken by reverse lexicographic
|
---|
| 84 | (defun grevlex> (p q &optional (start 0) (end (length p)))
|
---|
| 85 | "Return T if P>Q with respect to graded reverse lexicographic order,
|
---|
| 86 | NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 87 | (let ((d1 (total-degree p start end))
|
---|
| 88 | (d2 (total-degree q start end)))
|
---|
| 89 | (cond
|
---|
| 90 | ((> d1 d2) (values t nil))
|
---|
| 91 | ((< d1 d2) (values nil nil))
|
---|
| 92 | (t (revlex> p q start end)))))
|
---|
| 93 |
|
---|
| 94 | (defun invlex> (p q &optional (start 0) (end (length p)))
|
---|
| 95 | "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
|
---|
| 96 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 97 | (do ((i (1- end) (1- i)))
|
---|
| 98 | ((< i start) (values NIL T))
|
---|
| 99 | (cond
|
---|
| 100 | ((> (elt p i) (elt q i))
|
---|
| 101 | (return-from invlex> (values t nil)))
|
---|
| 102 | ((< (elt p i) (elt q i))
|
---|
| 103 | (return-from invlex> (values nil nil))))))
|
---|
| 104 |
|
---|
| 105 |
|
---|
| 106 | ;;----------------------------------------------------------------
|
---|
| 107 | ;; Order making functions
|
---|
| 108 | ;;----------------------------------------------------------------
|
---|
| 109 |
|
---|
| 110 | ;; Make an order which compares the first K variables according to
|
---|
| 111 | ;; PRIMARY-ORDER and the remaining elements according to
|
---|
| 112 | ;; SECONDARY-ORDER
|
---|
| 113 | (defun elimination-order (k &key (primary-order #'lex>)
|
---|
| 114 | (secondary-order #'lex>))
|
---|
| 115 | "Return a predicate which compares monomials according to the
|
---|
| 116 | K-th elimination order. Two optional arguments are PRIMARY-ORDER
|
---|
| 117 | and SECONDARY-ORDER and they should be term orders which are used
|
---|
| 118 | on the first K and the remaining variables."
|
---|
| 119 | #'(lambda (p q &optional (start 0) (end (length p)))
|
---|
| 120 | (multiple-value-bind (primary equal)
|
---|
| 121 | (funcall primary-order p q start k)
|
---|
| 122 | (if equal
|
---|
| 123 | (funcall secondary-order p q k end)
|
---|
| 124 | (values primary nil)))))
|
---|
| 125 |
|
---|
| 126 | (defun elimination-order-1 (order)
|
---|
| 127 | "A special case of the ELIMINATION-ORDER when there is only
|
---|
| 128 | one primary variable."
|
---|
| 129 | #'(lambda (p q
|
---|
| 130 | &optional (start 0)
|
---|
| 131 | (end (length p)))
|
---|
| 132 | (cond
|
---|
| 133 | ((> (elt p start) (elt q start)) (values t nil))
|
---|
| 134 | ((< (elt p start) (elt q start)) (values nil nil))
|
---|
| 135 | (t (funcall order p q (1+ start) end)))))
|
---|
| 136 |
|
---|
| 137 |
|
---|