[1201] | 1 | ;;; -*- Mode: Lisp -*-
|
---|
[80] | 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 |
|
---|
[444] | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 23 | ;;
|
---|
| 24 | ;; Implementations of various admissible monomial orders
|
---|
[923] | 25 | ;; Implementation of order-making functions/closures.
|
---|
[444] | 26 | ;;
|
---|
| 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 28 |
|
---|
[412] | 29 | (defpackage "ORDER"
|
---|
[2425] | 30 | (:use :cl :ring :monom)
|
---|
[412] | 31 | (:export "LEX>"
|
---|
| 32 | "GRLEX>"
|
---|
| 33 | "REVLEX>"
|
---|
| 34 | "GREVLEX>"
|
---|
[440] | 35 | "INVLEX>"
|
---|
| 36 | "REVERSE-MONOMIAL-ORDER"
|
---|
[933] | 37 | "MAKE-ELIMINATION-ORDER-FACTORY"))
|
---|
[80] | 38 |
|
---|
[417] | 39 | (in-package :order)
|
---|
| 40 |
|
---|
[1934] | 41 | (proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
|
---|
| 42 |
|
---|
[49] | 43 | ;; pure lexicographic
|
---|
[2432] | 44 | (defgeneric lex> (p q &optional start end)
|
---|
[2433] | 45 | (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
|
---|
[2432] | 46 | "Return T if P>Q with respect to lexicographic order, otherwise NIL.
|
---|
[49] | 47 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
[2432] | 48 | (declare (type fixnum start end))
|
---|
| 49 | (do ((i start (1+ i)))
|
---|
| 50 | ((>= i end) (values nil t))
|
---|
| 51 | (cond
|
---|
| 52 | ((> (r-elt p i) (r-elt q i))
|
---|
| 53 | (return-from lex> (values t nil)))
|
---|
| 54 | ((< (r-elt p i) (r-elt q i))
|
---|
| 55 | (return-from lex> (values nil nil)))))))
|
---|
[49] | 56 |
|
---|
| 57 | ;; total degree order , ties broken by lexicographic
|
---|
[2432] | 58 | (defgeneric grlex> (p q &optional start end)
|
---|
[2433] | 59 | (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
|
---|
[2432] | 60 | "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
|
---|
[49] | 61 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
[2432] | 62 | (declare (type monom p q) (type fixnum start end))
|
---|
| 63 | (let ((d1 (r-total-degree p start end))
|
---|
| 64 | (d2 (r-total-degree q start end)))
|
---|
| 65 | (declare (type fixnum d1 d2))
|
---|
| 66 | (cond
|
---|
| 67 | ((> d1 d2) (values t nil))
|
---|
| 68 | ((< d1 d2) (values nil nil))
|
---|
| 69 | (t
|
---|
| 70 | (lex> p q start end))))))
|
---|
[49] | 71 |
|
---|
| 72 |
|
---|
| 73 | ;; reverse lexicographic
|
---|
[2433] | 74 | (defgeneric revlex> ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
|
---|
[49] | 75 | "Return T if P>Q with respect to reverse lexicographic order, NIL
|
---|
| 76 | otherwise. The second returned value is T if P=Q, otherwise it is
|
---|
| 77 | NIL. This is not and admissible monomial order because some sets do
|
---|
| 78 | not have a minimal element. This order is useful in constructing other
|
---|
| 79 | orders."
|
---|
[2426] | 80 | (declare (type fixnum start end))
|
---|
[49] | 81 | (do ((i (1- end) (1- i)))
|
---|
| 82 | ((< i start) (values nil t))
|
---|
[1936] | 83 | (declare (type fixnum i))
|
---|
[49] | 84 | (cond
|
---|
[2425] | 85 | ((< (r-elt p i) (r-elt q i))
|
---|
[49] | 86 | (return-from revlex> (values t nil)))
|
---|
[2425] | 87 | ((> (r-elt p i) (r-elt q i))
|
---|
[49] | 88 | (return-from revlex> (values nil nil))))))
|
---|
| 89 |
|
---|
| 90 |
|
---|
[426] | 91 | ;; total degree, ties broken by reverse lexicographic
|
---|
[2433] | 92 | (defmethod grevlex> ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
|
---|
[426] | 93 | "Return T if P>Q with respect to graded reverse lexicographic order,
|
---|
| 94 | NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
|
---|
[2430] | 95 | (declare (type fixnum start end))
|
---|
[2427] | 96 | (let ((d1 (r-total-degree p start end))
|
---|
| 97 | (d2 (r-total-degree q start end)))
|
---|
[1937] | 98 | (declare (type fixnum d1 d2))
|
---|
[426] | 99 | (cond
|
---|
| 100 | ((> d1 d2) (values t nil))
|
---|
| 101 | ((< d1 d2) (values nil nil))
|
---|
| 102 | (t
|
---|
| 103 | (revlex> p q start end)))))
|
---|
| 104 |
|
---|
[2433] | 105 | (defmethod invlex> ((p monom) (q monom) &optional (start 0) (end (r-dimension p)))
|
---|
[49] | 106 | "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
|
---|
| 107 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
[2429] | 108 | (declare (type fixnum start end))
|
---|
[49] | 109 | (do ((i (1- end) (1- i)))
|
---|
| 110 | ((< i start) (values nil t))
|
---|
[1938] | 111 | (declare (type fixnum i))
|
---|
| 112 | (cond
|
---|
[2425] | 113 | ((> (r-elt p i) (r-elt q i))
|
---|
[1938] | 114 | (return-from invlex> (values t nil)))
|
---|
[2425] | 115 | ((< (r-elt p i) (r-elt q i))
|
---|
[1938] | 116 | (return-from invlex> (values nil nil))))))
|
---|
[439] | 117 |
|
---|
| 118 |
|
---|
[910] | 119 | (defun reverse-monomial-order (order)
|
---|
| 120 | "Create the inverse monomial order to the given monomial order ORDER."
|
---|
[2433] | 121 | #'(lambda (p q &optional (start 0) (end (r-dimension q)))
|
---|
[1931] | 122 | (declare (type monom p q) (type fixnum start end))
|
---|
[924] | 123 | (funcall order q p start end)))
|
---|
[439] | 124 |
|
---|
| 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 126 | ;;
|
---|
| 127 | ;; Order making functions
|
---|
| 128 | ;;
|
---|
| 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 130 |
|
---|
[922] | 131 | ;; This returns a closure with the same signature
|
---|
| 132 | ;; as all orders such as #'LEX>.
|
---|
[946] | 133 | (defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
|
---|
[917] | 134 | "It constructs an elimination order used for the 1-st elimination ideal,
|
---|
| 135 | i.e. for eliminating the first variable. Thus, the order compares the degrees of the
|
---|
| 136 | first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
|
---|
[2433] | 137 | #'(lambda (p q &optional (start 0) (end (r-dimension p)))
|
---|
[1932] | 138 | (declare (type monom p q) (type fixnum start end))
|
---|
[914] | 139 | (cond
|
---|
[2425] | 140 | ((> (r-elt p start) (r-elt q start))
|
---|
[920] | 141 | (values t nil))
|
---|
[2425] | 142 | ((< (r-elt p start) (r-elt q start))
|
---|
[920] | 143 | (values nil nil))
|
---|
| 144 | (t
|
---|
| 145 | (funcall secondary-elimination-order p q (1+ start) end)))))
|
---|
[914] | 146 |
|
---|
[922] | 147 | ;; This returns a closure which is called with an integer argument.
|
---|
[932] | 148 | ;; The result is *another closure* with the same signature as all
|
---|
| 149 | ;; orders such as #'LEX>.
|
---|
[945] | 150 | (defun make-elimination-order-factory (&optional
|
---|
| 151 | (primary-elimination-order #'lex>)
|
---|
| 152 | (secondary-elimination-order #'lex>))
|
---|
[910] | 153 | "Return a function with a single integer argument K. This should be
|
---|
| 154 | the number of initial K variables X[0],X[1],...,X[K-1], which precede
|
---|
| 155 | remaining variables. The call to the closure creates a predicate
|
---|
| 156 | which compares monomials according to the K-th elimination order. The
|
---|
| 157 | monomial orders PRIMARY-ELIMINATION-ORDER and
|
---|
| 158 | SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
|
---|
| 159 | remaining variables, respectively, with ties broken by lexicographical
|
---|
| 160 | order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
|
---|
| 161 | which indicates that the first K variables appear with identical
|
---|
| 162 | powers, then the result is that of a call to
|
---|
| 163 | SECONDARY-ELIMINATION-ORDER applied to the remaining variables
|
---|
| 164 | X[K],X[K+1],..."
|
---|
| 165 | #'(lambda (k)
|
---|
[914] | 166 | (cond
|
---|
[919] | 167 | ((<= k 0)
|
---|
| 168 | (error "K must be at least 1"))
|
---|
[914] | 169 | ((= k 1)
|
---|
[930] | 170 | (make-elimination-order-factory-1 secondary-elimination-order))
|
---|
[914] | 171 | (t
|
---|
[2433] | 172 | #'(lambda (p q &optional (start 0) (end (r-dimension p)))
|
---|
[1933] | 173 | (declare (type monom p q) (type fixnum start end))
|
---|
[914] | 174 | (multiple-value-bind (primary equal)
|
---|
| 175 | (funcall primary-elimination-order p q start k)
|
---|
| 176 | (if equal
|
---|
| 177 | (funcall secondary-elimination-order p q k end)
|
---|
| 178 | (values primary nil))))))))
|
---|
[439] | 179 |
|
---|