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

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

;;;                                                                              

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



(defpackage "PAIR-QUEUE"

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

  (:export "CRITICAL-PAIR"

           "CRITICAL-PAIR-FIRST"

           "CRITICAL-PAIR-SECOND"

           "CRITICAL-PAIR-QUEUE"

           "SELECTION-STRATEGY"

           "MIN-TOTAL-DEGREE-STRATEGY"

           "MIN-COMBINED-LENGTH-STRATEGY"

           "MAKE-CRITICAL-PAIR-QUEUE"

           )

  (:documentation "Critical pair queue implementation. The pair queue is a list of critical

pairs, ordered by some partial order. Pair queue is a kind of priority queue.")

  )

           

(in-package :pair-queue)



(defclass critical-pair ()

  ((first :initform nil  :initarg :first :accessor critical-pair-first :type poly)

   (second :initform nil :initarg :second :accessor critical-pair-second :type poly))

  (:documentation "Represents a critical pair, i.e. a pair of two polynomials. The derived

classes may add extra data used in computing the order of critical pairs."))



(defmethod print-object ((self critical-pair) stream)

  (print-unreadable-object (self stream :type t :identity t)

    (with-accessors ((first critical-pair-first)

                     (second critical-pair-second))

        self

      (format stream "FIRST=~A SECOND=~A" 

              first second))))



(defclass selection-strategy ()

  ((pair-key-fn :initform #'(lambda (p q) (universal-lcm (leading-monomial p) (leading-monomial q))) 

                :initarg :pair-key-fn 

                :accessor pair-key-fn)

   (pair-order-fn :initform #'lex> 

                  :initarg :pair-order-fn 

                  :accessor pair-order-fn))

  (:documentation "Represents the normal critical pair selection

strategy.  The two ingredients of a strategy is a function

PAIR-KEY-FUNCTION which computes a key from the critical pair, which

can be any type of data, and a function PAIR-ORDER-FN used to compaire

the calculated keys to determine which pair is more promising and

should be considered first.  The normal selection strategy for a given

monomial order PAIR-ORDER-FN consists in selecting the pair with the

minimal LCM of leading monomials first."))



(defmethod print-object ((self selection-strategy) stream)

  (print-unreadable-object (self stream :type t :identity t)

    (with-accessors ((pair-key-fn pair-key-fn)

                     (pair-order-fn pair-order-fn))

        self

      (format stream "PAIR-KEY-FN=~A PAIR-ORDER-FN=~A" 

              pair-key-fn pair-order-fn))))



(defclass min-total-degree-strategy (selection-strategy)

  ((pair-key-fn :initform #'(lambda (p q) (total-degree (universal-lcm (leading-monomial p) (leading-monomial q)))))

   (pair-order-fn :initform #'<))

  (:documentation "Make a selection strategy where a pair with a

minimum total degree of LCM of leading monomials is selected."))



(defclass min-combined-length-strategy (selection-strategy)

  ((pair-key-fn :initform #'(lambda (p q) (+ (poly-length p) (poly-length q))))

   (pair-order-fn :initform #'<))

  (:documentation "Make a selection strategy where a pair with the minimum combined length of both

polynomials is selected."))



(defun make-critical-pair-queue (&key pair-key-fn pair-order-fn (poly-list nil) (start 1)

                                 &aux (pq (make-priority-queue

                                           :element-type 'critical-pair

                                           :element-key #'(lambda (pair) (funcall pair-key-fn 

                                                                                  (critical-pair-first pair)

                                                                                  (critical-pair-second pair)))

                                           :test pair-order-fn)))

  "Makes a priority queue for critical pairs. The argument POLY-LIST should the initial list of polynomials.

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

partial Grobner basis, i.e. satisfy the Buchberger criterion."

    ;; Add critical pairs for polynomials in POLY-LIST

  (let* ((s (1- (length poly-list)))

         (b (nconc (makelist (make-instance 'critical-pair :first (elt poly-list i) :second (elt poly-list j))

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

                   (makelist (make-instance 'critical-pair :first (elt poly-list i) :second (elt poly-list j))

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

    (dolist (pair b pq)

      (priority-queue-insert pq pair))))