source: branches/f4grobner/pair-queue.lisp@ 1699

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

;;;                                                                              

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; Critical pair queue implementation

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defpackage "PAIR-QUEUE"

  (:use :cl :priority-queue :monom :order :polynomial :utils)

  (:export "SUGAR-PAIR-KEY"

           "PAIR"

           "MAKE-PAIR"

           "PAIR-FIRST"

           "PAIR-SECOND"

           "PAIR-SUGAR"

           "PAIR-DIVISION-DATA"

           "SUGAR-ORDER"

           "*PAIR-KEY-FUNCTION*"

           "*PAIR-ORDER*"

           "MAKE-PAIR-QUEUE"

           "PAIR-QUEUE-INITIALIZE"

           "PAIR-QUEUE-INSERT"

           "PAIR-QUEUE-REMOVE"

           "PAIR-QUEUE-SIZE"

           "PAIR-QUEUE-EMPTY-P"

           "SET-PAIR-HEURISTIC"

           ))

           



(in-package :pair-queue)



(defun sugar-pair-key (p q &aux (lcm (monom-lcm (poly-lm p) (poly-lm q)))

                                (d (monom-sugar lcm)))

  "Returns list (S LCM-TOTAL-DEGREE) where S is the sugar of the S-polynomial of

polynomials P and Q, and LCM-TOTAL-DEGREE is the degree of LCM(LM(P),LM(Q))."

  (declare (type poly p q) (type monom lcm) (type fixnum d))

  (cons (max 

         (+  (- d (monom-sugar (poly-lm p))) (poly-sugar p))

         (+  (- d (monom-sugar (poly-lm q))) (poly-sugar q)))

        lcm))



(defstruct (pair

            (:constructor make-pair (first second

                                           &aux

                                           (sugar (car (sugar-pair-key first second)))

                                           (division-data nil))))

  (first nil :type poly)

  (second nil :type poly)

  (sugar 0 :type fixnum)

  (division-data nil :type list))

  

;;(defun pair-sugar (pair &aux (p (pair-first pair)) (q (pair-second pair)))

;;  (car (sugar-pair-key p q)))



(defun sugar-order (x y)

  "Pair order based on sugar, ties broken by normal strategy."

  (declare (type cons x y))

  (or (< (car x) (car y))

      (and (= (car x) (car y))

           (< (monom-total-degree (cdr x))

              (monom-total-degree (cdr y))))))



(defvar *pair-key-function* #'sugar-pair-key

  "Function that, given two polynomials as argument, computed the key

in the pair queue.")



(defvar *pair-order* #'sugar-order

  "Function that orders the keys of pairs.")



(defun make-pair-queue ()

  "Constructs a priority queue for critical pairs."

  (make-priority-queue

   :element-type 'pair

   :element-key #'(lambda (pair) (funcall *pair-key-function* (pair-first pair) (pair-second pair)))

   :test *pair-order*))



(defun pair-queue-initialize (pq f start

                              &aux

                              (s (1- (length f)))

                              (b (nconc (makelist (make-pair (elt f i) (elt f j))

                                                 (i 0 (1- start)) (j start s))

                                        (makelist (make-pair (elt f i) (elt f j))

                                                 (i start (1- s)) (j (1+ i) s)))))

  "Initializes the priority for critical pairs. F is the initial list of polynomials.

START is the first position beyond the elements which form a partial

grobner basis, i.e. satisfy the Buchberger criterion."

  (declare (type priority-queue pq) (type fixnum start))

  (dolist (pair b pq)

    (priority-queue-insert pq pair)))



(defun pair-queue-insert (b pair)

  (priority-queue-insert b pair))



(defun pair-queue-remove (b)

  (priority-queue-remove b))



(defun pair-queue-size (b)

  (priority-queue-size b))



(defun pair-queue-empty-p (b)

  (priority-queue-empty-p b))



(defun set-pair-heuristic (method)

  "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used

to determine the priority of critical pairs in the priority queue."

  (ecase method

    ((sugar :sugar $sugar)

     (setf *pair-key-function* #'sugar-pair-key

           *pair-order* #'sugar-order))

;     ((minimal-mock-spoly :minimal-mock-spoly $minimal_mock_spoly)

;      (setf *pair-key-function* #'mock-spoly

;          *pair-order* #'mock-spoly-order))

    ((minimal-lcm :minimal-lcm $minimal_lcm)

     (setf *pair-key-function* #'(lambda (p q)

                                   (monom-lcm (poly-lm p) (poly-lm q)))

           *pair-order* #'reverse-monomial-order))

    ((minimal-total-degree :minimal-total-degree $minimal_total_degree)

     (setf *pair-key-function* #'(lambda (p q)

                                   (monom-total-degree

                                    (monom-lcm (poly-lm p) (poly-lm q))))

           *pair-order* #'<))

    ((minimal-length :minimal-length $minimal_length)

     (setf *pair-key-function* #'(lambda (p q)

                                   (+ (poly-length p) (poly-length q)))

           *pair-order* #'<))))