source: branches/f4grobner/order.lisp@ 910

;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>          
;;;                                                                              
;;;  This program is free software; you can redistribute it and/or modify        
;;;  it under the terms of the GNU General Public License as published by        
;;;  the Free Software Foundation; either version 2 of the License, or           
;;;  (at your option) any later version.                                         
;;;                                                                              
;;;  This program is distributed in the hope that it will be useful,             
;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of              
;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the               
;;;  GNU General Public License for more details.                                
;;;                                                                              
;;;  You should have received a copy of the GNU General Public License           
;;;  along with this program; if not, write to the Free Software                 
;;;  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
;;;                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Implementations of various admissible monomial orders
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "ORDER"
  (:use :cl :monomial)
  (:export "LEX>"
           "GRLEX>"
           "REVLEX>"
           "GREVLEX>"
           "INVLEX>"
           "MONOMIAL-ORDER"
           "*MONOMIAL-ORDER*"
           "REVERSE-MONOMIAL-ORDER"
           "*PRIMARY-ELIMINATION-ORDER*"
           "*SECONDARY-ELIMINATION-ORDER*"
           "*ELIMINATION-ORDER*"
           "ELIMINATION-ORDER"
           "ELIMINATION-ORDER-1"))

(in-package :order)

;; pure lexicographic
(defun lex> (p q &optional (start 0) (end (monom-dimension  p)))
  "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."
  (do ((i start (1+ i)))
      ((>= i end) (values nil t))
    (cond
     ((> (monom-elt p i) (monom-elt q i))
      (return-from lex> (values t nil)))
     ((< (monom-elt p i) (monom-elt q i))
      (return-from lex> (values nil nil))))))

;; total degree order , ties broken by lexicographic
(defun grlex> (p q &optional (start 0) (end (monom-dimension  p)))
  "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."
  (let ((d1 (monom-total-degree p start end))
        (d2 (monom-total-degree q start end)))
    (cond
      ((> d1 d2) (values t nil))
      ((< d1 d2) (values nil nil))
      (t
        (lex> p q start end)))))


;; reverse lexicographic
(defun revlex> (p q &optional (start 0) (end (monom-dimension  p)))
  "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."
  (do ((i (1- end) (1- i)))
      ((< i start) (values nil t))
    (cond
     ((< (monom-elt p i) (monom-elt q i))
      (return-from revlex> (values t nil)))
     ((> (monom-elt p i) (monom-elt q i))
      (return-from revlex> (values nil nil))))))


;; total degree, ties broken by reverse lexicographic
(defun grevlex> (p q &optional (start 0) (end (monom-dimension  p)))
  "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."
  (let ((d1 (monom-total-degree p start end))
        (d2 (monom-total-degree q start end)))
    (cond
     ((> d1 d2) (values t nil))
     ((< d1 d2) (values nil nil))
     (t
      (revlex> p q start end)))))

(defun invlex> (p q &optional (start 0) (end (monom-dimension  p)))
  "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."
  (do ((i (1- end) (1- i)))
      ((< i start) (values nil t))
      (cond
         ((> (monom-elt p i) (monom-elt q i))
          (return-from invlex> (values t nil)))
         ((< (monom-elt p i) (monom-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 (x y) (funcall order y x)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Order making functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-elimination-order-maker (primary-elimination-order secondary-elimination-order)
  "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) 
      #'(lambda (p q &optional (start 0) (end (monom-dimension  p)))
          (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 (secondary-elimination-order q &optional (start 0) (end (monom-dimension  p)))
  "Equivalent to the function returned by the call to (ELIMINATION-ORDER NIL SECONDARY-ELIMINATION-ORDER 1)."
  (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))))