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@ 1756

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

* empty log message *

File size: 6.5 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 :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;; pure lexicographic
42(defun lex> (p q &optional (start 0) (end (monom-dimension p)))
43 "Return T if P>Q with respect to lexicographic order, otherwise NIL.
44The second returned value is T if P=Q, otherwise it is NIL."
45 (do ((i start (1+ i)))
46 ((>= i end) (values nil t))
47 (cond
48 ((> (monom-elt p i) (monom-elt q i))
49 (return-from lex> (values t nil)))
50 ((< (monom-elt p i) (monom-elt q i))
51 (return-from lex> (values nil nil))))))
52
53;; total degree order , ties broken by lexicographic
54(defun grlex> (p q &optional (start 0) (end (monom-dimension p)))
55 "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
56The second returned value is T if P=Q, otherwise it is NIL."
57 (let ((d1 (monom-total-degree p start end))
58 (d2 (monom-total-degree q start end)))
59 (cond
60 ((> d1 d2) (values t nil))
61 ((< d1 d2) (values nil nil))
62 (t
63 (lex> p q start end)))))
64
65
66;; reverse lexicographic
67(defun revlex> (p q &optional (start 0) (end (monom-dimension p)))
68 "Return T if P>Q with respect to reverse lexicographic order, NIL
69otherwise. The second returned value is T if P=Q, otherwise it is
70NIL. This is not and admissible monomial order because some sets do
71not have a minimal element. This order is useful in constructing other
72orders."
73 (do ((i (1- end) (1- i)))
74 ((< i start) (values nil t))
75 (cond
76 ((< (monom-elt p i) (monom-elt q i))
77 (return-from revlex> (values t nil)))
78 ((> (monom-elt p i) (monom-elt q i))
79 (return-from revlex> (values nil nil))))))
80
81
82;; total degree, ties broken by reverse lexicographic
83(defun grevlex> (p q &optional (start 0) (end (monom-dimension p)))
84 "Return T if P>Q with respect to graded reverse lexicographic order,
85NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
86 (let ((d1 (monom-total-degree p start end))
87 (d2 (monom-total-degree q start end)))
88 (cond
89 ((> d1 d2) (values t nil))
90 ((< d1 d2) (values nil nil))
91 (t
92 (revlex> p q start end)))))
93
94(defun invlex> (p q &optional (start 0) (end (monom-dimension p)))
95 "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
96The 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 ((> (monom-elt p i) (monom-elt q i))
101 (return-from invlex> (values t nil)))
102 ((< (monom-elt p i) (monom-elt q i))
103 (return-from invlex> (values nil nil))))))
104
105
106(defun reverse-monomial-order (order)
107 "Create the inverse monomial order to the given monomial order ORDER."
108 #'(lambda (p q &optional (start 0) (end (monom-dimension q)))
109 (funcall order q p start end)))
110
111;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112;;
113;; Order making functions
114;;
115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
116
117;; This returns a closure with the same signature
118;; as all orders such as #'LEX>.
119(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
120 "It constructs an elimination order used for the 1-st elimination ideal,
121i.e. for eliminating the first variable. Thus, the order compares the degrees of the
122first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
123 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
124 (cond
125 ((> (monom-elt p start) (monom-elt q start))
126 (values t nil))
127 ((< (monom-elt p start) (monom-elt q start))
128 (values nil nil))
129 (t
130 (funcall secondary-elimination-order p q (1+ start) end)))))
131
132;; This returns a closure which is called with an integer argument.
133;; The result is *another closure* with the same signature as all
134;; orders such as #'LEX>.
135(defun make-elimination-order-factory (&optional
136 (primary-elimination-order #'lex>)
137 (secondary-elimination-order #'lex>))
138 "Return a function with a single integer argument K. This should be
139the number of initial K variables X[0],X[1],...,X[K-1], which precede
140remaining variables. The call to the closure creates a predicate
141which compares monomials according to the K-th elimination order. The
142monomial orders PRIMARY-ELIMINATION-ORDER and
143SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
144remaining variables, respectively, with ties broken by lexicographical
145order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
146which indicates that the first K variables appear with identical
147powers, then the result is that of a call to
148SECONDARY-ELIMINATION-ORDER applied to the remaining variables
149X[K],X[K+1],..."
150 #'(lambda (k)
151 (cond
152 ((<= k 0)
153 (error "K must be at least 1"))
154 ((= k 1)
155 (make-elimination-order-factory-1 secondary-elimination-order))
156 (t
157 #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
158 (multiple-value-bind (primary equal)
159 (funcall primary-elimination-order p q start k)
160 (if equal
161 (funcall secondary-elimination-order p q k end)
162 (values primary nil))))))))
163
Note: See TracBrowser for help on using the repository browser.