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

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

* empty log message *

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