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

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

* empty log message *

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