close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/order.lisp@ 2898

Last change on this file since 2898 was 2711, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 7.3 KB
Line 
1;;; -*- Mode: Lisp -*-
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;
4;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19;;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; Implementations of various admissible monomial orders
25;; Implementation of order-making functions/closures.
26;;
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(defpackage "ORDER"
30 (:use :cl :ring :monom)
31 (:export "LEX>"
32 "GRLEX>"
33 "REVLEX>"
34 "GREVLEX>"
35 "INVLEX>"
36 "REVERSE-MONOMIAL-ORDER"
37 "MAKE-ELIMINATION-ORDER-FACTORY"))
38
39(in-package :order)
40
41(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
42
43;; pure lexicographic
44(defgeneric lex> (p q &optional start end)
45 (:documentation "Return T if P>Q with respect to lexicographic
46order, otherwise NIL. The second returned value is T if P=Q,
47otherwise it is NIL.")
48 (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
49 (declare (type fixnum start end))
50 (do ((i start (1+ i)))
51 ((>= i end) (values nil t))
52 (cond
53 ((> (r-elt p i) (r-elt q i))
54 (return-from lex> (values t nil)))
55 ((< (r-elt p i) (r-elt q i))
56 (return-from lex> (values nil nil)))))))
57
58;; total degree order , ties broken by lexicographic
59(defgeneric grlex> (p q &optional start end)
60 (:documentation "Return T if P>Q with respect to graded
61lexicographic order, otherwise NIL. The second returned value is T if
62P=Q, otherwise it is NIL.")
63 (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
64 (declare (type monom p q) (type fixnum start end))
65 (let ((d1 (r-total-degree p start end))
66 (d2 (r-total-degree q start end)))
67 (declare (type fixnum d1 d2))
68 (cond
69 ((> d1 d2) (values t nil))
70 ((< d1 d2) (values nil nil))
71 (t
72 (lex> p q start end))))))
73
74
75;; reverse lexicographic
76(defgeneric revlex> (p q &optional start end)
77 (:documentation "Return T if P>Q with respect to reverse
78lexicographic order, NIL otherwise. The second returned value is T if
79P=Q, otherwise it is NIL. This is not and admissible monomial order
80because some sets do not have a minimal element. This order is useful
81in constructing other orders.")
82 (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
83 (declare (type fixnum start end))
84 (do ((i (1- end) (1- i)))
85 ((< i start) (values nil t))
86 (declare (type fixnum i))
87 (cond
88 ((< (r-elt p i) (r-elt q i))
89 (return-from revlex> (values t nil)))
90 ((> (r-elt p i) (r-elt q i))
91 (return-from revlex> (values nil nil)))))))
92
93
94;; total degree, ties broken by reverse lexicographic
95(defgeneric grevlex> (p q &optional start end)
96 (:documentation "Return T if P>Q with respect to graded reverse
97lexicographic order, NIL otherwise. The second returned value is T if
98P=Q, otherwise it is NIL.")
99 (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
100 (declare (type fixnum start end))
101 (let ((d1 (r-total-degree p start end))
102 (d2 (r-total-degree q start end)))
103 (declare (type fixnum d1 d2))
104 (cond
105 ((> d1 d2) (values t nil))
106 ((< d1 d2) (values nil nil))
107 (t
108 (revlex> p q start end))))))
109
110(defgeneric invlex> (p q &optional start end)
111 (:documentation "Return T if P>Q with respect to inverse
112lexicographic order, NIL otherwise The second returned value is T if
113P=Q, otherwise it is NIL.")
114 (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
115 (declare (type fixnum start end))
116 (do ((i (1- end) (1- i)))
117 ((< i start) (values nil t))
118 (declare (type fixnum i))
119 (cond
120 ((> (r-elt p i) (r-elt q i))
121 (return-from invlex> (values t nil)))
122 ((< (r-elt p i) (r-elt q i))
123 (return-from invlex> (values nil nil)))))))
124
125(defun reverse-monomial-order (order)
126 "Create the inverse monomial order to the given monomial order ORDER."
127 #'(lambda (p q &optional (start 0) (end (r-dimension q)))
128 (declare (type monom p q) (type fixnum start end))
129 (funcall order q p start end)))
130
131;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
132;;
133;; Order making functions
134;;
135;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136
137;; This returns a closure with the same signature
138;; as all orders such as #'LEX>.
139(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
140 "It constructs an elimination order used for the 1-st elimination ideal,
141i.e. for eliminating the first variable. Thus, the order compares the degrees of the
142first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
143 #'(lambda (p q &optional (start 0) (end (r-dimension p)))
144 (declare (type monom p q) (type fixnum start end))
145 (cond
146 ((> (r-elt p start) (r-elt q start))
147 (values t nil))
148 ((< (r-elt p start) (r-elt q start))
149 (values nil nil))
150 (t
151 (funcall secondary-elimination-order p q (1+ start) end)))))
152
153;; This returns a closure which is called with an integer argument.
154;; The result is *another closure* with the same signature as all
155;; orders such as #'LEX>.
156(defun make-elimination-order-factory (&optional
157 (primary-elimination-order #'lex>)
158 (secondary-elimination-order #'lex>))
159 "Return a function with a single integer argument K. This should be
160the number of initial K variables X[0],X[1],...,X[K-1], which precede
161remaining variables. The call to the closure creates a predicate
162which compares monomials according to the K-th elimination order. The
163monomial orders PRIMARY-ELIMINATION-ORDER and
164SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
165remaining variables, respectively, with ties broken by lexicographical
166order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
167which indicates that the first K variables appear with identical
168powers, then the result is that of a call to
169SECONDARY-ELIMINATION-ORDER applied to the remaining variables
170X[K],X[K+1],..."
171 #'(lambda (k)
172 (cond
173 ((<= k 0)
174 (error "K must be at least 1"))
175 ((= k 1)
176 (make-elimination-order-factory-1 secondary-elimination-order))
177 (t
178 #'(lambda (p q &optional (start 0) (end (r-dimension p)))
179 (declare (type monom p q) (type fixnum start end))
180 (multiple-value-bind (primary equal)
181 (funcall primary-elimination-order p q start k)
182 (if equal
183 (funcall secondary-elimination-order p q k end)
184 (values primary nil))))))))
185
Note: See TracBrowser for help on using the repository browser.