;;; -*-  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.	 
;;;										 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "ORDER-MK"
  (:use :cl :order)
  (:export "MONOMIAL-ORDER"
	   "REVERSE-MONOMIAL-ORDER"
	   "*PRIMARY-ELIMINATION-ORDER*"
	   "*SECONDARY-ELIMINATION-ORDER*"
	   "*ELIMINATION-ORDER*"
	   "ELIMINATION-ORDER"
	   "ELIMINATION-ORDER-1"))

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