1 | head 1.4;
|
---|
2 | access;
|
---|
3 | symbols;
|
---|
4 | locks; strict;
|
---|
5 | comment @;;; @;
|
---|
6 |
|
---|
7 |
|
---|
8 | 1.4
|
---|
9 | date 2009.01.23.10.39.41; author marek; state Exp;
|
---|
10 | branches;
|
---|
11 | next 1.3;
|
---|
12 |
|
---|
13 | 1.3
|
---|
14 | date 2009.01.22.04.04.52; author marek; state Exp;
|
---|
15 | branches;
|
---|
16 | next 1.2;
|
---|
17 |
|
---|
18 | 1.2
|
---|
19 | date 2009.01.19.09.27.32; author marek; state Exp;
|
---|
20 | branches;
|
---|
21 | next 1.1;
|
---|
22 |
|
---|
23 | 1.1
|
---|
24 | date 2009.01.19.07.49.12; author marek; state Exp;
|
---|
25 | branches;
|
---|
26 | next ;
|
---|
27 |
|
---|
28 |
|
---|
29 | desc
|
---|
30 | @@
|
---|
31 |
|
---|
32 |
|
---|
33 | 1.4
|
---|
34 | log
|
---|
35 | @*** empty log message ***
|
---|
36 | @
|
---|
37 | text
|
---|
38 | @#|
|
---|
39 | $Id$
|
---|
40 | *--------------------------------------------------------------------------*
|
---|
41 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu) |
|
---|
42 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
43 | | |
|
---|
44 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
45 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
46 | *--------------------------------------------------------------------------*
|
---|
47 | |#
|
---|
48 | ;; Order relations for vectors of numbers
|
---|
49 | ;; Below p, q is a multiindex: p ---> (n1 n2 ... nk), where ni are
|
---|
50 | ;; nonnegative integers. The package, though, will work with any
|
---|
51 | ;; kind of real numbers.
|
---|
52 | ;; These functions have a common interface
|
---|
53 | ;; Their arguments are:
|
---|
54 | ;; -two monomials P and Q to be compared
|
---|
55 | ;; -function KEY which is called before comparing the entries
|
---|
56 | ;; -START and END which restrict the index range for comparison
|
---|
57 | ;; Each of the functions returs two values
|
---|
58 | ;; -T or NIL depending on whether P>Q or not
|
---|
59 | ;; -the second value is T if the sequences are equal
|
---|
60 |
|
---|
61 | (defpackage "ORDER"
|
---|
62 | (:use "COMMON-LISP")
|
---|
63 | (:export
|
---|
64 | lex>
|
---|
65 | invlex>
|
---|
66 | grlex>
|
---|
67 | grevlex>
|
---|
68 | elimination-order
|
---|
69 | elimination-order-1
|
---|
70 | total-degree))
|
---|
71 |
|
---|
72 | (in-package "ORDER")
|
---|
73 |
|
---|
74 | #+debug(proclaim '(optimize (speed 0) (debug 3)))
|
---|
75 | #-debug(proclaim '(optimize (speed 3) (debug 0)))
|
---|
76 |
|
---|
77 | ;; pure lexicographic
|
---|
78 | (defun lex> (p q &optional (start 0) (end (length p)))
|
---|
79 | "Return T if P>Q with respect to lexicographic order, otherwise NIL.
|
---|
80 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
81 | (do ((i start (1+ i)))
|
---|
82 | ((>= i end) (values NIL T))
|
---|
83 | (cond
|
---|
84 | ((> (elt p i) (elt q i))
|
---|
85 | (return-from lex> (values t nil)))
|
---|
86 | ((< (elt p i) (elt q i))
|
---|
87 | (return-from lex> (values nil nil))))))
|
---|
88 |
|
---|
89 | ;; total degree of a multiindex
|
---|
90 | (defun total-degree (m &optional (start 0) (end (length m)))
|
---|
91 | "Return the todal degree of a monomoal M."
|
---|
92 | (reduce #'+ (subseq m start end)))
|
---|
93 |
|
---|
94 | ;; total degree order , ties broken by lexicographic
|
---|
95 | (defun grlex> (p q &optional (start 0) (end (length p)))
|
---|
96 | "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
|
---|
97 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
98 | (let ((d1 (total-degree p start end))
|
---|
99 | (d2 (total-degree q start end)))
|
---|
100 | (cond
|
---|
101 | ((> d1 d2) (values t nil))
|
---|
102 | ((< d1 d2) (values nil nil))
|
---|
103 | (t
|
---|
104 | (lex> p q start end)))))
|
---|
105 |
|
---|
106 | ;; reverse lexicographic
|
---|
107 | (defun revlex> (p q &optional (start 0) (end (length p)))
|
---|
108 | "Return T if P>Q with respect to reverse lexicographic order, NIL
|
---|
109 | otherwise. The second returned value is T if P=Q, otherwise it is
|
---|
110 | NIL. This is not and admissible monomial order because some sets do
|
---|
111 | not have a minimal element. This order is useful in constructing other
|
---|
112 | orders."
|
---|
113 | (do ((i (1- end) (1- i)))
|
---|
114 | ((< i start) (values NIL T))
|
---|
115 | (cond
|
---|
116 | ((< (elt p i) (elt q i))
|
---|
117 | (return-from revlex> (values t nil)))
|
---|
118 | ((> (elt p i) (elt q i))
|
---|
119 | (return-from revlex> (values nil nil))))))
|
---|
120 |
|
---|
121 | ;; total degree, ties broken by reverse lexicographic
|
---|
122 | (defun grevlex> (p q &optional (start 0) (end (length p)))
|
---|
123 | "Return T if P>Q with respect to graded reverse lexicographic order,
|
---|
124 | NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
|
---|
125 | (let ((d1 (total-degree p start end))
|
---|
126 | (d2 (total-degree q start end)))
|
---|
127 | (cond
|
---|
128 | ((> d1 d2) (values t nil))
|
---|
129 | ((< d1 d2) (values nil nil))
|
---|
130 | (t (revlex> p q start end)))))
|
---|
131 |
|
---|
132 | (defun invlex> (p q &optional (start 0) (end (length p)))
|
---|
133 | "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
|
---|
134 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
135 | (do ((i (1- end) (1- i)))
|
---|
136 | ((< i start) (values NIL T))
|
---|
137 | (cond
|
---|
138 | ((> (elt p i) (elt q i))
|
---|
139 | (return-from invlex> (values t nil)))
|
---|
140 | ((< (elt p i) (elt q i))
|
---|
141 | (return-from invlex> (values nil nil))))))
|
---|
142 |
|
---|
143 |
|
---|
144 | ;;----------------------------------------------------------------
|
---|
145 | ;; Order making functions
|
---|
146 | ;;----------------------------------------------------------------
|
---|
147 |
|
---|
148 | ;; Make an order which compares the first K variables according to
|
---|
149 | ;; PRIMARY-ORDER and the remaining elements according to
|
---|
150 | ;; SECONDARY-ORDER
|
---|
151 | (defun elimination-order (k &key (primary-order #'lex>)
|
---|
152 | (secondary-order #'lex>))
|
---|
153 | "Return a predicate which compares monomials according to the
|
---|
154 | K-th elimination order. Two optional arguments are PRIMARY-ORDER
|
---|
155 | and SECONDARY-ORDER and they should be term orders which are used
|
---|
156 | on the first K and the remaining variables."
|
---|
157 | #'(lambda (p q &optional (start 0) (end (length p)))
|
---|
158 | (multiple-value-bind (primary equal)
|
---|
159 | (funcall primary-order p q start k)
|
---|
160 | (if equal
|
---|
161 | (funcall secondary-order p q k end)
|
---|
162 | (values primary nil)))))
|
---|
163 |
|
---|
164 | (defun elimination-order-1 (order)
|
---|
165 | "A special case of the ELIMINATION-ORDER when there is only
|
---|
166 | one primary variable."
|
---|
167 | #'(lambda (p q
|
---|
168 | &optional (start 0)
|
---|
169 | (end (length p)))
|
---|
170 | (cond
|
---|
171 | ((> (elt p start) (elt q start)) (values t nil))
|
---|
172 | ((< (elt p start) (elt q start)) (values nil nil))
|
---|
173 | (t (funcall order p q (1+ start) end)))))
|
---|
174 |
|
---|
175 |
|
---|
176 | @
|
---|
177 |
|
---|
178 |
|
---|
179 | 1.3
|
---|
180 | log
|
---|
181 | @*** empty log message ***
|
---|
182 | @
|
---|
183 | text
|
---|
184 | @a67 13
|
---|
185 |
|
---|
186 |
|
---|
187 | ;; total degree, ties broken by reverse lexicographic
|
---|
188 | (defun grevlex> (p q &optional (start 0) (end (length p)))
|
---|
189 | "Return T if P>Q with respect to graded reverse lexicographic order,
|
---|
190 | NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
|
---|
191 | (let ((d1 (total-degree p start end))
|
---|
192 | (d2 (total-degree q start end)))
|
---|
193 | (cond
|
---|
194 | ((> d1 d2) (values t nil))
|
---|
195 | ((< d1 d2) (values nil nil))
|
---|
196 | (t (revlex> p q start end)))))
|
---|
197 |
|
---|
198 | d84 10
|
---|
199 | @
|
---|
200 |
|
---|
201 |
|
---|
202 | 1.2
|
---|
203 | log
|
---|
204 | @*** empty log message ***
|
---|
205 | @
|
---|
206 | text
|
---|
207 | @d37 2
|
---|
208 | a38 2
|
---|
209 | ;;(proclaim '(optimize (speed 0) (debug 3)))
|
---|
210 | (proclaim '(optimize (speed 3) (debug 0)))
|
---|
211 | @
|
---|
212 |
|
---|
213 |
|
---|
214 | 1.1
|
---|
215 | log
|
---|
216 | @Initial revision
|
---|
217 | @
|
---|
218 | text
|
---|
219 | @d2 1
|
---|
220 | a2 1
|
---|
221 | $Id: order.lisp,v 1.10 1997/12/22 21:17:49 marek Exp $
|
---|
222 | d37 2
|
---|
223 | a38 1
|
---|
224 | (proclaim '(optimize (speed 0) (debug 3)))
|
---|
225 | @
|
---|