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 |
|
---|
37 | (proclaim '(optimize (speed 0) (debug 3)))
|
---|
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 |
|
---|