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