Changeset 439 for branches/f4grobner

Timestamp:

2015-06-06T19:57:37-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/order.lisp (modified) (1 diff)

branches/f4grobner/order.lisp

@@ -107 +107 @@
          ((< (monom-elt p i) (monom-elt q i))
           (return-from invlex> (values nil nil))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Some globally-defined variables holding monomial orders
+;; and related macros/functions.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *monomial-order* #'lex>
+  "Default order for monomial comparisons. This global variable holds
+the order which is in effect when performing polynomial
+arithmetic. The global order is called by the macro MONOMIAL-ORDER,
+which is somewhat more elegant than FUNCALL.")
+
+(defmacro monomial-order (x y)
+  "Calls the global monomial order function, held by *MONOMIAL-ORDER*."
+  `(funcall *monomial-order* ,x ,y))
+
+(defmacro reverse-monomial-order (x y)
+  "Calls the inverse monomial order to the global monomial order function,
+held by *MONOMIAL-ORDER*."
+  `(monomial-order ,y ,x))
+
+(defvar *primary-elimination-order* #'lex>)
+
+(defvar *secondary-elimination-order* #'lex>)
+
+(defvar *elimination-order* nil
+  "Default elimination order used in elimination-based functions.
+If not NIL, it is assumed to be a proper elimination order. If NIL,
+we will construct an elimination order using the values of
+*PRIMARY-ELIMINATION-ORDER* and *SECONDARY-ELIMINATION-ORDER*.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Order making functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun elimination-order (k)
+  "Return a predicate which compares monomials according to the
+K-th elimination order. Two variables *PRIMARY-ELIMINATION-ORDER*
+and *SECONDARY-ELIMINATION-ORDER* control the behavior on the first K
+and the remaining variables, respectively."
+  (declare (type fixnum k))
+  #'(lambda (p q &optional (start 0) (end (monom-dimension  p)))
+      (declare (type monom p q) (type fixnum start end))
+      (multiple-value-bind (primary equal)
+           (funcall *primary-elimination-order* p q start k)
+         (if equal
+             (funcall *secondary-elimination-order* p q k end)
+           (values primary nil)))))
+
+(defun elimination-order-1 (p q &optional (start 0) (end (monom-dimension  p)))
+  "Equivalent to the function returned by the call to (ELIMINATION-ORDER 1)."
+  (declare (type monom p q) (type fixnum start end))
+  (cond
+   ((> (monom-elt p start) (monom-elt q start)) (values t nil))
+   ((< (monom-elt p start) (monom-elt q start)) (values nil nil))
+   (t (funcall *secondary-elimination-order* p q (1+ start) end))))