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@ 2667

Last change on this file since 2667 was 1607, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 5.2 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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; Critical pair queue implementation
25;;
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(defpackage "PAIR-QUEUE"
29 (:use :cl :priority-queue :monom :order :polynomial :utils)
30 (:export "SUGAR-PAIR-KEY"
31 "PAIR"
32 "MAKE-PAIR"
33 "PAIR-FIRST"
34 "PAIR-SECOND"
35 "PAIR-SUGAR"
36 "PAIR-DIVISION-DATA"
37 "SUGAR-ORDER"
38 "*PAIR-KEY-FUNCTION*"
39 "*PAIR-ORDER*"
40 "MAKE-PAIR-QUEUE"
41 "PAIR-QUEUE-INITIALIZE"
42 "PAIR-QUEUE-INSERT"
43 "PAIR-QUEUE-REMOVE"
44 "PAIR-QUEUE-SIZE"
45 "PAIR-QUEUE-EMPTY-P"
46 "SET-PAIR-HEURISTIC"
47 ))
48
49
50(in-package :pair-queue)
51
52(defun sugar-pair-key (p q &aux (lcm (monom-lcm (poly-lm p) (poly-lm q)))
53 (d (monom-sugar lcm)))
54 "Returns list (S LCM-TOTAL-DEGREE) where S is the sugar of the S-polynomial of
55polynomials P and Q, and LCM-TOTAL-DEGREE is the degree of LCM(LM(P),LM(Q))."
56 (declare (type poly p q) (type monom lcm) (type fixnum d))
57 (cons (max
58 (+ (- d (monom-sugar (poly-lm p))) (poly-sugar p))
59 (+ (- d (monom-sugar (poly-lm q))) (poly-sugar q)))
60 lcm))
61
62(defstruct (pair
63 (:constructor make-pair (first second
64 &aux
65 (sugar (car (sugar-pair-key first second)))
66 (division-data nil))))
67 (first nil :type poly)
68 (second nil :type poly)
69 (sugar 0 :type fixnum)
70 (division-data nil :type list))
71
72;;(defun pair-sugar (pair &aux (p (pair-first pair)) (q (pair-second pair)))
73;; (car (sugar-pair-key p q)))
74
75(defun sugar-order (x y)
76 "Pair order based on sugar, ties broken by normal strategy."
77 (declare (type cons x y))
78 (or (< (car x) (car y))
79 (and (= (car x) (car y))
80 (< (monom-total-degree (cdr x))
81 (monom-total-degree (cdr y))))))
82
83(defvar *pair-key-function* #'sugar-pair-key
84 "Function that, given two polynomials as argument, computed the key
85in the pair queue.")
86
87(defvar *pair-order* #'sugar-order
88 "Function that orders the keys of pairs.")
89
90(defun make-pair-queue ()
91 "Constructs a priority queue for critical pairs."
92 (make-priority-queue
93 :element-type 'pair
94 :element-key #'(lambda (pair) (funcall *pair-key-function* (pair-first pair) (pair-second pair)))
95 :test *pair-order*))
96
97(defun pair-queue-initialize (pq f start
98 &aux
99 (s (1- (length f)))
100 (b (nconc (makelist (make-pair (elt f i) (elt f j))
101 (i 0 (1- start)) (j start s))
102 (makelist (make-pair (elt f i) (elt f j))
103 (i start (1- s)) (j (1+ i) s)))))
104 "Initializes the priority for critical pairs. F is the initial list of polynomials.
105START is the first position beyond the elements which form a partial
106grobner basis, i.e. satisfy the Buchberger criterion."
107 (declare (type priority-queue pq) (type fixnum start))
108 (dolist (pair b pq)
109 (priority-queue-insert pq pair)))
110
111(defun pair-queue-insert (b pair)
112 (priority-queue-insert b pair))
113
114(defun pair-queue-remove (b)
115 (priority-queue-remove b))
116
117(defun pair-queue-size (b)
118 (priority-queue-size b))
119
120(defun pair-queue-empty-p (b)
121 (priority-queue-empty-p b))
122
123(defun set-pair-heuristic (method)
124 "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used
125to determine the priority of critical pairs in the priority queue."
126 (ecase method
127 ((sugar :sugar $sugar)
128 (setf *pair-key-function* #'sugar-pair-key
129 *pair-order* #'sugar-order))
130; ((minimal-mock-spoly :minimal-mock-spoly $minimal_mock_spoly)
131; (setf *pair-key-function* #'mock-spoly
132; *pair-order* #'mock-spoly-order))
133 ((minimal-lcm :minimal-lcm $minimal_lcm)
134 (setf *pair-key-function* #'(lambda (p q)
135 (monom-lcm (poly-lm p) (poly-lm q)))
136 *pair-order* #'reverse-monomial-order))
137 ((minimal-total-degree :minimal-total-degree $minimal_total_degree)
138 (setf *pair-key-function* #'(lambda (p q)
139 (monom-total-degree
140 (monom-lcm (poly-lm p) (poly-lm q))))
141 *pair-order* #'<))
142 ((minimal-length :minimal-length $minimal_length)
143 (setf *pair-key-function* #'(lambda (p q)
144 (+ (poly-length p) (poly-length q)))
145 *pair-order* #'<))))
146
Note: See TracBrowser for help on using the repository browser.