[1201] | 1 | ;;; -*- Mode: Lisp -*-
|
---|
[76] | 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 3 | ;;;
|
---|
| 4 | ;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
|
---|
| 5 | ;;;
|
---|
| 6 | ;;; This program is free software; you can redistribute it and/or modify
|
---|
| 7 | ;;; it under the terms of the GNU General Public License as published by
|
---|
| 8 | ;;; the Free Software Foundation; either version 2 of the License, or
|
---|
| 9 | ;;; (at your option) any later version.
|
---|
| 10 | ;;;
|
---|
| 11 | ;;; This program is distributed in the hope that it will be useful,
|
---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
---|
| 14 | ;;; GNU General Public License for more details.
|
---|
| 15 | ;;;
|
---|
| 16 | ;;; You should have received a copy of the GNU General Public License
|
---|
| 17 | ;;; along with this program; if not, write to the Free Software
|
---|
| 18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
---|
| 19 | ;;;
|
---|
| 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 21 |
|
---|
[449] | 22 | (defpackage "PAIR-QUEUE"
|
---|
[3910] | 23 | (:use :cl :priority-queue :monom :polynomial :utils)
|
---|
[3918] | 24 | (:export "PAIR"
|
---|
[490] | 25 | "MAKE-PAIR"
|
---|
[449] | 26 | "PAIR-FIRST"
|
---|
| 27 | "PAIR-SECOND"
|
---|
| 28 | "PAIR-DIVISION-DATA"
|
---|
| 29 | "*PAIR-KEY-FUNCTION*"
|
---|
| 30 | "*PAIR-ORDER*"
|
---|
| 31 | "MAKE-PAIR-QUEUE"
|
---|
| 32 | "PAIR-QUEUE-INITIALIZE"
|
---|
| 33 | "PAIR-QUEUE-INSERT"
|
---|
| 34 | "PAIR-QUEUE-REMOVE"
|
---|
| 35 | "PAIR-QUEUE-SIZE"
|
---|
| 36 | "PAIR-QUEUE-EMPTY-P"
|
---|
| 37 | "SET-PAIR-HEURISTIC"
|
---|
[3918] | 38 | )
|
---|
| 39 | (:documentation "Critical pair queue implementation. The pair queue is a list of critical
|
---|
| 40 | pairs, ordered by some partial order. Pair queue is a kind of priority queue.")
|
---|
| 41 | )
|
---|
[449] | 42 |
|
---|
| 43 |
|
---|
[450] | 44 | (in-package :pair-queue)
|
---|
| 45 |
|
---|
[3919] | 46 | (defclass critical-pair ()
|
---|
| 47 | ((first :initform nil :initarg :first)
|
---|
| 48 | (second :initform nil :initarg :second))
|
---|
| 49 | (:documentation "Represents a critical pair."))
|
---|
| 50 |
|
---|
[60] | 51 |
|
---|
[3918] | 52 | (defvar *pair-key-function* nil
|
---|
[60] | 53 | "Function that, given two polynomials as argument, computed the key
|
---|
| 54 | in the pair queue.")
|
---|
| 55 |
|
---|
[3918] | 56 | (defvar *pair-order* nil
|
---|
[60] | 57 | "Function that orders the keys of pairs.")
|
---|
| 58 |
|
---|
| 59 | (defun make-pair-queue ()
|
---|
| 60 | "Constructs a priority queue for critical pairs."
|
---|
| 61 | (make-priority-queue
|
---|
| 62 | :element-type 'pair
|
---|
| 63 | :element-key #'(lambda (pair) (funcall *pair-key-function* (pair-first pair) (pair-second pair)))
|
---|
| 64 | :test *pair-order*))
|
---|
| 65 |
|
---|
| 66 | (defun pair-queue-initialize (pq f start
|
---|
| 67 | &aux
|
---|
| 68 | (s (1- (length f)))
|
---|
| 69 | (b (nconc (makelist (make-pair (elt f i) (elt f j))
|
---|
| 70 | (i 0 (1- start)) (j start s))
|
---|
| 71 | (makelist (make-pair (elt f i) (elt f j))
|
---|
| 72 | (i start (1- s)) (j (1+ i) s)))))
|
---|
| 73 | "Initializes the priority for critical pairs. F is the initial list of polynomials.
|
---|
| 74 | START is the first position beyond the elements which form a partial
|
---|
| 75 | grobner basis, i.e. satisfy the Buchberger criterion."
|
---|
| 76 | (declare (type priority-queue pq) (type fixnum start))
|
---|
| 77 | (dolist (pair b pq)
|
---|
| 78 | (priority-queue-insert pq pair)))
|
---|
| 79 |
|
---|
| 80 | (defun pair-queue-insert (b pair)
|
---|
| 81 | (priority-queue-insert b pair))
|
---|
| 82 |
|
---|
| 83 | (defun pair-queue-remove (b)
|
---|
| 84 | (priority-queue-remove b))
|
---|
| 85 |
|
---|
| 86 | (defun pair-queue-size (b)
|
---|
| 87 | (priority-queue-size b))
|
---|
| 88 |
|
---|
| 89 | (defun pair-queue-empty-p (b)
|
---|
| 90 | (priority-queue-empty-p b))
|
---|
[162] | 91 |
|
---|
| 92 | (defun set-pair-heuristic (method)
|
---|
| 93 | "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used
|
---|
| 94 | to determine the priority of critical pairs in the priority queue."
|
---|
| 95 | (ecase method
|
---|
| 96 | ((minimal-lcm :minimal-lcm $minimal_lcm)
|
---|
| 97 | (setf *pair-key-function* #'(lambda (p q)
|
---|
[3910] | 98 | (universal-lcm (leading-monomial p) (leading-monomial q)))
|
---|
[162] | 99 | *pair-order* #'reverse-monomial-order))
|
---|
| 100 | ((minimal-total-degree :minimal-total-degree $minimal_total_degree)
|
---|
| 101 | (setf *pair-key-function* #'(lambda (p q)
|
---|
[3911] | 102 | (total-degree
|
---|
[3910] | 103 | (universal-lcm (leading-monomial p) (leading-monomial q))))
|
---|
[162] | 104 | *pair-order* #'<))
|
---|
| 105 | ((minimal-length :minimal-length $minimal_length)
|
---|
| 106 | (setf *pair-key-function* #'(lambda (p q)
|
---|
| 107 | (+ (poly-length p) (poly-length q)))
|
---|
| 108 | *pair-order* #'<))))
|
---|
| 109 |
|
---|