close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

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

Last change on this file since 3920 was 3920, checked in by Marek Rychlik, 8 years ago

* empty log message *

File size: 4.0 KB
Line 
1;;; -*- Mode: Lisp -*-
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
22(defpackage "PAIR-QUEUE"
23 (:use :cl :priority-queue :monom :polynomial :utils)
24 (:export "CRITICAL-PAIR"
25 "CRITICAL-PAIR-FIRST"
26 "CRITICAL-PAIR-SECOND"
27 "MAKE-PAIR-QUEUE"
28 "PAIR-QUEUE-INITIALIZE"
29 "PAIR-QUEUE-INSERT"
30 "PAIR-QUEUE-REMOVE"
31 "PAIR-QUEUE-SIZE"
32 "PAIR-QUEUE-EMPTY-P"
33 "SET-PAIR-HEURISTIC"
34 )
35 (:documentation "Critical pair queue implementation. The pair queue is a list of critical
36pairs, ordered by some partial order. Pair queue is a kind of priority queue.")
37 )
38
39
40(in-package :pair-queue)
41
42(defclass critical-pair ()
43 ((first :initform nil :initarg :first :accessor critical-pair-first)
44 (second :initform nil :initarg :second :accessor critical-pair-second))
45 (:documentation "Represents a critical pair."))
46
47(defmethod print-object ((self poly) stream)
48 (print-unreadable-object (self stream :type t :identity t)
49 (with-accessors ((first critical-pair-first)
50 (second critical-pair-second))
51 self
52 (format stream "FIRST=~A SECOND=~A"
53 first second))))
54
55
56(defun make-pair-queue ()
57 "Constructs a priority queue for critical pairs."
58 (make-priority-queue
59 :element-type 'pair
60 :element-key #'(lambda (pair) (funcall *pair-key-function* (pair-first pair) (pair-second pair)))
61 :test *pair-order*))
62
63(defun pair-queue-initialize (pq f start
64 &aux
65 (s (1- (length f)))
66 (b (nconc (makelist (make-pair (elt f i) (elt f j))
67 (i 0 (1- start)) (j start s))
68 (makelist (make-pair (elt f i) (elt f j))
69 (i start (1- s)) (j (1+ i) s)))))
70 "Initializes the priority for critical pairs. F is the initial list of polynomials.
71START is the first position beyond the elements which form a partial
72grobner basis, i.e. satisfy the Buchberger criterion."
73 (declare (type priority-queue pq) (type fixnum start))
74 (dolist (pair b pq)
75 (priority-queue-insert pq pair)))
76
77(defun pair-queue-insert (b pair)
78 (priority-queue-insert b pair))
79
80(defun pair-queue-remove (b)
81 (priority-queue-remove b))
82
83(defun pair-queue-size (b)
84 (priority-queue-size b))
85
86(defun pair-queue-empty-p (b)
87 (priority-queue-empty-p b))
88
89(defun set-pair-heuristic (method)
90 "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used
91to determine the priority of critical pairs in the priority queue."
92 (ecase method
93 ((minimal-lcm :minimal-lcm $minimal_lcm)
94 (setf *pair-key-function* #'(lambda (p q)
95 (universal-lcm (leading-monomial p) (leading-monomial q)))
96 *pair-order* #'reverse-monomial-order))
97 ((minimal-total-degree :minimal-total-degree $minimal_total_degree)
98 (setf *pair-key-function* #'(lambda (p q)
99 (total-degree
100 (universal-lcm (leading-monomial p) (leading-monomial q))))
101 *pair-order* #'<))
102 ((minimal-length :minimal-length $minimal_length)
103 (setf *pair-key-function* #'(lambda (p q)
104 (+ (poly-length p) (poly-length q)))
105 *pair-order* #'<))))
106
Note: See TracBrowser for help on using the repository browser.