Changeset 3472 for branches

Timestamp:

2015-09-05T10:13:39-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/monom.lisp (modified) (2 diffs)

branches/f4grobner/monom.lisp

@@ -48 +48 @@
            "MONOM-LEFT-CONTRACT"
            "MAKE-MONOM-VARIABLE"
-           "MONOM->LIST")
+           "MONOM->LIST"
+           "LEX>"
+           "GRLEX>"
+           "REVLEX>"
+           "GREVLEX>"
+           "INVLEX>"
+           "REVERSE-MONOMIAL-ORDER"
+           "MAKE-ELIMINATION-ORDER-FACTORY"))
 
   (:documentation
@@ -325 +332 @@
   "A human-readable representation of a monomial M as a list of exponents."  
   (coerce (monom-exponents m) 'list))
+
+
+(in-package :order)
+
+(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
+
+;; pure lexicographic
+(defgeneric lex> (p q &optional start end)
+  (:documentation "Return T if P>Q with respect to lexicographic
+order, otherwise NIL.  The second returned value is T if P=Q,
+otherwise it is NIL.")
+  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
+    (declare (type fixnum start end))
+    (do ((i start (1+ i)))
+        ((>= i end) (values nil t))
+      (cond
+        ((> (r-elt p i) (r-elt q i))
+         (return-from lex> (values t nil)))
+        ((< (r-elt p i) (r-elt q i))
+         (return-from lex> (values nil nil)))))))
+
+;; total degree order , ties broken by lexicographic
+(defgeneric grlex> (p q &optional start end)
+  (:documentation "Return T if P>Q with respect to graded
+lexicographic order, otherwise NIL.  The second returned value is T if
+P=Q, otherwise it is NIL.")
+  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
+    (declare (type monom p q) (type fixnum start end))
+    (let ((d1 (r-total-degree p start end))
+          (d2 (r-total-degree q start end)))
+      (declare (type fixnum d1 d2))
+      (cond
+        ((> d1 d2) (values t nil))
+        ((< d1 d2) (values nil nil))
+        (t
+         (lex> p q start end))))))
+
+
+;; reverse lexicographic
+(defgeneric revlex> (p q &optional start end)
+  (:documentation "Return T if P>Q with respect to reverse
+lexicographic order, NIL otherwise.  The second returned value is T if
+P=Q, otherwise it is NIL. This is not and admissible monomial order
+because some sets do not have a minimal element. This order is useful
+in constructing other orders.")
+  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
+    (declare (type fixnum start end))
+    (do ((i (1- end) (1- i)))
+        ((< i start) (values nil t))
+      (declare (type fixnum i))
+      (cond
+        ((< (r-elt p i) (r-elt q i))
+         (return-from revlex> (values t nil)))
+        ((> (r-elt p i) (r-elt q i))
+         (return-from revlex> (values nil nil)))))))
+
+
+;; total degree, ties broken by reverse lexicographic
+(defgeneric grevlex> (p q &optional start end)
+  (:documentation "Return T if P>Q with respect to graded reverse
+lexicographic order, NIL otherwise. The second returned value is T if
+P=Q, otherwise it is NIL.")
+  (:method  ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
+    (declare (type fixnum start end))
+    (let ((d1 (r-total-degree p start end))
+          (d2 (r-total-degree q start end)))
+      (declare (type fixnum d1 d2))
+      (cond
+        ((> d1 d2) (values t nil))
+        ((< d1 d2) (values nil nil))
+        (t
+         (revlex> p q start end))))))
+
+(defgeneric invlex> (p q &optional start end)
+  (:documentation "Return T if P>Q with respect to inverse
+lexicographic order, NIL otherwise The second returned value is T if
+P=Q, otherwise it is NIL.")
+  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
+    (declare  (type fixnum start end))
+    (do ((i (1- end) (1- i)))
+        ((< i start) (values nil t))
+      (declare (type fixnum i))
+      (cond
+        ((> (r-elt p i) (r-elt q i))
+         (return-from invlex> (values t nil)))
+        ((< (r-elt p i) (r-elt q i))
+         (return-from invlex> (values nil nil)))))))
+
+(defun reverse-monomial-order (order)
+  "Create the inverse monomial order to the given monomial order ORDER."
+  #'(lambda (p q &optional (start 0) (end (r-dimension q))) 
+      (declare (type monom p q) (type fixnum start end))
+      (funcall order q p start end)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Order making functions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This returns a closure with the same signature
+;; as all orders such as #'LEX>.
+(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
+  "It constructs an elimination order used for the 1-st elimination ideal,
+i.e. for eliminating the first variable. Thus, the order compares the degrees of the
+first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
+  #'(lambda (p q &optional (start 0) (end (r-dimension p)))
+      (declare (type monom p q) (type fixnum start end))
+      (cond
+        ((> (r-elt p start) (r-elt q start))
+         (values t nil))
+        ((< (r-elt p start) (r-elt q start))
+         (values nil nil))
+        (t 
+         (funcall secondary-elimination-order p q (1+ start) end)))))
+
+;; This returns a closure which is called with an integer argument.
+;; The result is *another closure* with the same signature as all
+;; orders such as #'LEX>.
+(defun make-elimination-order-factory (&optional 
+                                         (primary-elimination-order #'lex>)
+                                         (secondary-elimination-order #'lex>))
+  "Return a function with a single integer argument K. This should be
+the number of initial K variables X[0],X[1],...,X[K-1], which precede
+remaining variables.  The call to the closure creates a predicate
+which compares monomials according to the K-th elimination order. The
+monomial orders PRIMARY-ELIMINATION-ORDER and
+SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
+remaining variables, respectively, with ties broken by lexicographical
+order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
+which indicates that the first K variables appear with identical
+powers, then the result is that of a call to
+SECONDARY-ELIMINATION-ORDER applied to the remaining variables
+X[K],X[K+1],..."
+  #'(lambda (k) 
+      (cond 
+        ((<= k 0) 
+         (error "K must be at least 1"))
+        ((= k 1)
+         (make-elimination-order-factory-1 secondary-elimination-order))
+        (t
+         #'(lambda (p q &optional (start 0) (end (r-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))))))))
+