;;; -*-  Mode: Lisp -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  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
;; Implementation of order-making functions/closures.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "ORDER"
  (:use :cl :monom)
  (:export "LEX>"
	   "GRLEX>"
	   "REVLEX>"
	   "GREVLEX>"
	   "INVLEX>"
	   "REVERSE-MONOMIAL-ORDER"
	   "MAKE-ELIMINATION-ORDER-FACTORY"))

(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))))))))