;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik ;;; ;;; 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" "PAIR-QUEUE-INSERT" "PAIR-QUEUE-REMOVE" "PAIR-QUEUE-SIZE" "PAIR-QUEUE-EMPTY-P" "SET-PAIR-HEURISTIC" ) (: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 minimal-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.")) (defclass critical-pair-queue (selection-strategy) ((pq :initform nil :initarg :pq :accessor pq :type priority-queue))) (defmethod initialize-instance :after ((self critical-pair-queue) &key (f nil) (start 1)) "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." (with-accessors ((pair-key-fn pair-key-fn) (pair-order-fn pair-order-fn) (pq pq)) self (setf 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)) (let* ((s (1- (length f))) (b (nconc (makelist (make-instance 'critical-pair :first (elt f i) :second (elt f j)) (i 0 (1- start)) (j start s)) (makelist (make-instance 'critical-pair :first (elt f i) :second (elt f j)) (i start (1- s)) (j (1+ i) s))))) (dolist (pair b pq) (priority-queue-insert pq pair))) )) (defmethod print-object ((self critical-pair-queue) stream) (print-unreadable-object (self stream :type t :identity t) (with-accessors ((pair-key-fn pair-key-fn) (pair-order-fn pair-order-fn) (pq pq)) self (format stream "PAIR-KEY-FN=~A PAIR-ORDER-FN=~A PQ=~A" pair-key-fn pair-order-fn pq)))) (defun pair-queue-initialize (pq f start &aux (s (1- (length f))) (b (nconc (makelist (make-instance 'critical-pair :first (elt f i) :second (elt f j)) (i 0 (1- start)) (j start s)) (makelist (make-instance 'critical-pair :first (elt f i) :second (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))