close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

Changeset 3472


Ignore:
Timestamp:
2015-09-05T10:13:39-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/monom.lisp

    r3466 r3472  
    4848           "MONOM-LEFT-CONTRACT"
    4949           "MAKE-MONOM-VARIABLE"
    50            "MONOM->LIST")
     50           "MONOM->LIST"
     51           "LEX>"
     52           "GRLEX>"
     53           "REVLEX>"
     54           "GREVLEX>"
     55           "INVLEX>"
     56           "REVERSE-MONOMIAL-ORDER"
     57           "MAKE-ELIMINATION-ORDER-FACTORY"))
    5158
    5259  (:documentation
     
    325332  "A human-readable representation of a monomial M as a list of exponents." 
    326333  (coerce (monom-exponents m) 'list))
     334
     335
     336(in-package :order)
     337
     338(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
     339
     340;; pure lexicographic
     341(defgeneric lex> (p q &optional start end)
     342  (:documentation "Return T if P>Q with respect to lexicographic
     343order, otherwise NIL.  The second returned value is T if P=Q,
     344otherwise it is NIL.")
     345  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
     346    (declare (type fixnum start end))
     347    (do ((i start (1+ i)))
     348        ((>= i end) (values nil t))
     349      (cond
     350        ((> (r-elt p i) (r-elt q i))
     351         (return-from lex> (values t nil)))
     352        ((< (r-elt p i) (r-elt q i))
     353         (return-from lex> (values nil nil)))))))
     354
     355;; total degree order , ties broken by lexicographic
     356(defgeneric grlex> (p q &optional start end)
     357  (:documentation "Return T if P>Q with respect to graded
     358lexicographic order, otherwise NIL.  The second returned value is T if
     359P=Q, otherwise it is NIL.")
     360  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
     361    (declare (type monom p q) (type fixnum start end))
     362    (let ((d1 (r-total-degree p start end))
     363          (d2 (r-total-degree q start end)))
     364      (declare (type fixnum d1 d2))
     365      (cond
     366        ((> d1 d2) (values t nil))
     367        ((< d1 d2) (values nil nil))
     368        (t
     369         (lex> p q start end))))))
     370
     371
     372;; reverse lexicographic
     373(defgeneric revlex> (p q &optional start end)
     374  (:documentation "Return T if P>Q with respect to reverse
     375lexicographic order, NIL otherwise.  The second returned value is T if
     376P=Q, otherwise it is NIL. This is not and admissible monomial order
     377because some sets do not have a minimal element. This order is useful
     378in constructing other orders.")
     379  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
     380    (declare (type fixnum start end))
     381    (do ((i (1- end) (1- i)))
     382        ((< i start) (values nil t))
     383      (declare (type fixnum i))
     384      (cond
     385        ((< (r-elt p i) (r-elt q i))
     386         (return-from revlex> (values t nil)))
     387        ((> (r-elt p i) (r-elt q i))
     388         (return-from revlex> (values nil nil)))))))
     389
     390
     391;; total degree, ties broken by reverse lexicographic
     392(defgeneric grevlex> (p q &optional start end)
     393  (:documentation "Return T if P>Q with respect to graded reverse
     394lexicographic order, NIL otherwise. The second returned value is T if
     395P=Q, otherwise it is NIL.")
     396  (:method  ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
     397    (declare (type fixnum start end))
     398    (let ((d1 (r-total-degree p start end))
     399          (d2 (r-total-degree q start end)))
     400      (declare (type fixnum d1 d2))
     401      (cond
     402        ((> d1 d2) (values t nil))
     403        ((< d1 d2) (values nil nil))
     404        (t
     405         (revlex> p q start end))))))
     406
     407(defgeneric invlex> (p q &optional start end)
     408  (:documentation "Return T if P>Q with respect to inverse
     409lexicographic order, NIL otherwise The second returned value is T if
     410P=Q, otherwise it is NIL.")
     411  (:method ((p monom) (q monom) &optional (start 0) (end (r-dimension  p)))
     412    (declare  (type fixnum start end))
     413    (do ((i (1- end) (1- i)))
     414        ((< i start) (values nil t))
     415      (declare (type fixnum i))
     416      (cond
     417        ((> (r-elt p i) (r-elt q i))
     418         (return-from invlex> (values t nil)))
     419        ((< (r-elt p i) (r-elt q i))
     420         (return-from invlex> (values nil nil)))))))
     421
     422(defun reverse-monomial-order (order)
     423  "Create the inverse monomial order to the given monomial order ORDER."
     424  #'(lambda (p q &optional (start 0) (end (r-dimension q)))
     425      (declare (type monom p q) (type fixnum start end))
     426      (funcall order q p start end)))
     427
     428;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     429;;
     430;; Order making functions
     431;;
     432;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     433
     434;; This returns a closure with the same signature
     435;; as all orders such as #'LEX>.
     436(defun make-elimination-order-factory-1 (&optional (secondary-elimination-order #'lex>))
     437  "It constructs an elimination order used for the 1-st elimination ideal,
     438i.e. for eliminating the first variable. Thus, the order compares the degrees of the
     439first variable in P and Q first, with ties broken by SECONDARY-ELIMINATION-ORDER."
     440  #'(lambda (p q &optional (start 0) (end (r-dimension p)))
     441      (declare (type monom p q) (type fixnum start end))
     442      (cond
     443        ((> (r-elt p start) (r-elt q start))
     444         (values t nil))
     445        ((< (r-elt p start) (r-elt q start))
     446         (values nil nil))
     447        (t
     448         (funcall secondary-elimination-order p q (1+ start) end)))))
     449
     450;; This returns a closure which is called with an integer argument.
     451;; The result is *another closure* with the same signature as all
     452;; orders such as #'LEX>.
     453(defun make-elimination-order-factory (&optional
     454                                         (primary-elimination-order #'lex>)
     455                                         (secondary-elimination-order #'lex>))
     456  "Return a function with a single integer argument K. This should be
     457the number of initial K variables X[0],X[1],...,X[K-1], which precede
     458remaining variables.  The call to the closure creates a predicate
     459which compares monomials according to the K-th elimination order. The
     460monomial orders PRIMARY-ELIMINATION-ORDER and
     461SECONDARY-ELIMINATION-ORDER are used to compare the first K and the
     462remaining variables, respectively, with ties broken by lexicographical
     463order. That is, if PRIMARY-ELIMINATION-ORDER yields (VALUES NIL T),
     464which indicates that the first K variables appear with identical
     465powers, then the result is that of a call to
     466SECONDARY-ELIMINATION-ORDER applied to the remaining variables
     467X[K],X[K+1],..."
     468  #'(lambda (k)
     469      (cond
     470        ((<= k 0)
     471         (error "K must be at least 1"))
     472        ((= k 1)
     473         (make-elimination-order-factory-1 secondary-elimination-order))
     474        (t
     475         #'(lambda (p q &optional (start 0) (end (r-dimension  p)))
     476             (declare (type monom p q) (type fixnum start end))
     477             (multiple-value-bind (primary equal)
     478                 (funcall primary-elimination-order p q start k)
     479               (if equal
     480                   (funcall secondary-elimination-order p q k end)
     481                   (values primary nil))))))))
     482
Note: See TracChangeset for help on using the changeset viewer.