[80] | 1 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
|
---|
| 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
|
---|
| 25 | ;;
|
---|
| 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 27 |
|
---|
[412] | 28 | (defpackage "ORDER"
|
---|
| 29 | (:use :cl :monomial)
|
---|
| 30 | (:export "LEX>"
|
---|
| 31 | "GRLEX>"
|
---|
| 32 | "REVLEX>"
|
---|
| 33 | "GREVLEX>"
|
---|
[440] | 34 | "INVLEX>"
|
---|
| 35 | "MONOMIAL-ORDER"
|
---|
| 36 | "REVERSE-MONOMIAL-ORDER"
|
---|
| 37 | "*PRIMARY-ELIMINATION-ORDER*"
|
---|
| 38 | "*SECONDARY-ELIMINATION-ORDER*"
|
---|
| 39 | "*ELIMINATION-ORDER*"
|
---|
| 40 | "ELIMINATION-ORDER"
|
---|
| 41 | "ELIMINATION-ORDER-1"))
|
---|
[80] | 42 |
|
---|
[417] | 43 | (in-package :order)
|
---|
| 44 |
|
---|
[49] | 45 | ;; pure lexicographic
|
---|
| 46 | (defun lex> (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 47 | "Return T if P>Q with respect to lexicographic order, otherwise NIL.
|
---|
| 48 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 49 | (declare (type monom p q) (type fixnum start end))
|
---|
| 50 | (do ((i start (1+ i)))
|
---|
| 51 | ((>= i end) (values nil t))
|
---|
| 52 | (declare (type fixnum i))
|
---|
| 53 | (cond
|
---|
| 54 | ((> (monom-elt p i) (monom-elt q i))
|
---|
| 55 | (return-from lex> (values t nil)))
|
---|
| 56 | ((< (monom-elt p i) (monom-elt q i))
|
---|
| 57 | (return-from lex> (values nil nil))))))
|
---|
| 58 |
|
---|
| 59 | ;; total degree order , ties broken by lexicographic
|
---|
| 60 | (defun grlex> (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 61 | "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
|
---|
| 62 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 63 | (declare (type monom p q) (type fixnum start end))
|
---|
| 64 | (let ((d1 (monom-total-degree p start end))
|
---|
| 65 | (d2 (monom-total-degree q start end)))
|
---|
| 66 | (cond
|
---|
| 67 | ((> d1 d2) (values t nil))
|
---|
| 68 | ((< d1 d2) (values nil nil))
|
---|
| 69 | (t
|
---|
| 70 | (lex> p q start end)))))
|
---|
| 71 |
|
---|
| 72 |
|
---|
| 73 | ;; reverse lexicographic
|
---|
| 74 | (defun revlex> (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 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."
|
---|
| 80 | (declare (type monom p q) (type fixnum start end))
|
---|
| 81 | (do ((i (1- end) (1- i)))
|
---|
| 82 | ((< i start) (values nil t))
|
---|
| 83 | (declare (type fixnum i))
|
---|
| 84 | (cond
|
---|
| 85 | ((< (monom-elt p i) (monom-elt q i))
|
---|
| 86 | (return-from revlex> (values t nil)))
|
---|
| 87 | ((> (monom-elt p i) (monom-elt q i))
|
---|
| 88 | (return-from revlex> (values nil nil))))))
|
---|
| 89 |
|
---|
| 90 |
|
---|
[426] | 91 | ;; total degree, ties broken by reverse lexicographic
|
---|
| 92 | (defun grevlex> (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 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."
|
---|
| 95 | (declare (type monom p q) (type fixnum start end))
|
---|
| 96 | (let ((d1 (monom-total-degree p start end))
|
---|
| 97 | (d2 (monom-total-degree q start end)))
|
---|
| 98 | (cond
|
---|
| 99 | ((> d1 d2) (values t nil))
|
---|
| 100 | ((< d1 d2) (values nil nil))
|
---|
| 101 | (t
|
---|
| 102 | (revlex> p q start end)))))
|
---|
| 103 |
|
---|
[49] | 104 | (defun invlex> (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 105 | "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
|
---|
| 106 | The second returned value is T if P=Q, otherwise it is NIL."
|
---|
| 107 | (declare (type monom p q) (type fixnum start end))
|
---|
| 108 | (do ((i (1- end) (1- i)))
|
---|
| 109 | ((< i start) (values nil t))
|
---|
| 110 | (declare (type fixnum i))
|
---|
| 111 | (cond
|
---|
| 112 | ((> (monom-elt p i) (monom-elt q i))
|
---|
| 113 | (return-from invlex> (values t nil)))
|
---|
| 114 | ((< (monom-elt p i) (monom-elt q i))
|
---|
| 115 | (return-from invlex> (values nil nil))))))
|
---|
[439] | 116 |
|
---|
| 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 118 | ;;
|
---|
| 119 | ;; Some globally-defined variables holding monomial orders
|
---|
| 120 | ;; and related macros/functions.
|
---|
| 121 | ;;
|
---|
| 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 123 |
|
---|
| 124 | (defvar *monomial-order* #'lex>
|
---|
| 125 | "Default order for monomial comparisons. This global variable holds
|
---|
| 126 | the order which is in effect when performing polynomial
|
---|
| 127 | arithmetic. The global order is called by the macro MONOMIAL-ORDER,
|
---|
| 128 | which is somewhat more elegant than FUNCALL.")
|
---|
| 129 |
|
---|
| 130 | (defmacro monomial-order (x y)
|
---|
| 131 | "Calls the global monomial order function, held by *MONOMIAL-ORDER*."
|
---|
| 132 | `(funcall *monomial-order* ,x ,y))
|
---|
| 133 |
|
---|
| 134 | (defmacro reverse-monomial-order (x y)
|
---|
| 135 | "Calls the inverse monomial order to the global monomial order function,
|
---|
| 136 | held by *MONOMIAL-ORDER*."
|
---|
| 137 | `(monomial-order ,y ,x))
|
---|
| 138 |
|
---|
| 139 | (defvar *primary-elimination-order* #'lex>)
|
---|
| 140 |
|
---|
| 141 | (defvar *secondary-elimination-order* #'lex>)
|
---|
| 142 |
|
---|
| 143 | (defvar *elimination-order* nil
|
---|
| 144 | "Default elimination order used in elimination-based functions.
|
---|
| 145 | If not NIL, it is assumed to be a proper elimination order. If NIL,
|
---|
| 146 | we will construct an elimination order using the values of
|
---|
| 147 | *PRIMARY-ELIMINATION-ORDER* and *SECONDARY-ELIMINATION-ORDER*.")
|
---|
| 148 |
|
---|
| 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 150 | ;;
|
---|
| 151 | ;; Order making functions
|
---|
| 152 | ;;
|
---|
| 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 154 |
|
---|
| 155 | (defun elimination-order (k)
|
---|
| 156 | "Return a predicate which compares monomials according to the
|
---|
| 157 | K-th elimination order. Two variables *PRIMARY-ELIMINATION-ORDER*
|
---|
| 158 | and *SECONDARY-ELIMINATION-ORDER* control the behavior on the first K
|
---|
| 159 | and the remaining variables, respectively."
|
---|
| 160 | (declare (type fixnum k))
|
---|
| 161 | #'(lambda (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 162 | (declare (type monom p q) (type fixnum start end))
|
---|
| 163 | (multiple-value-bind (primary equal)
|
---|
| 164 | (funcall *primary-elimination-order* p q start k)
|
---|
| 165 | (if equal
|
---|
| 166 | (funcall *secondary-elimination-order* p q k end)
|
---|
| 167 | (values primary nil)))))
|
---|
| 168 |
|
---|
| 169 | (defun elimination-order-1 (p q &optional (start 0) (end (monom-dimension p)))
|
---|
| 170 | "Equivalent to the function returned by the call to (ELIMINATION-ORDER 1)."
|
---|
| 171 | (declare (type monom p q) (type fixnum start end))
|
---|
| 172 | (cond
|
---|
| 173 | ((> (monom-elt p start) (monom-elt q start)) (values t nil))
|
---|
| 174 | ((< (monom-elt p start) (monom-elt q start)) (values nil nil))
|
---|
| 175 | (t (funcall *secondary-elimination-order* p q (1+ start) end))))
|
---|