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/buchberger.lisp@ 4131

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

* empty log message *
File size: 6.5 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 "BUCHBERGER"
23 (:use :cl :grobner-debug
24 :ring :polynomial :order :ring-and-order :division
25 :criterion :pair-queue :priority-queue
26 )
27 (:export "BUCHBERGER" "PARALLEL-BUCHBERGER")
28 (:documentation "Buchberger Algorithm Implementation."))
29
30(in-package :buchberger)
31
32
33(defun buchberger (f
34 &optional
35 (start 0)
36 (top-reduction-only $poly_top_reduction_only)
37 &aux
38 (ring (ro-ring ring-and-order)))
39 "An implementation of the Buchberger algorithm. Return Grobner basis
40of the ideal generated by the polynomial list F. Polynomials 0 to
41START-1 are assumed to be a Grobner basis already, so that certain
42critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
43reduction will be preformed. This function assumes that all polynomials
44in F are non-zero."
45 (declare (type fixnum start))
46 (when (endp f) (return-from buchberger f)) ;cut startup costs
47 (debug-cgb "~&GROBNER BASIS - BUCHBERGER ALGORITHM")
48 (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
49 #+grobner-check (when (plusp start)
50 (grobner-test (subseq f 0 start) (subseq f 0 start)))
51 ;;Initialize critical pairs
52 (let ((b (make-critical-pair-queue f start))
53 (b-done (make-hash-table :test #'equal)))
54 (declare (type priority-queue b) (type hash-table b-done))
55 (dotimes (i (1- start))
56 (do ((j (1+ i) (1+ j))) ((>= j start))
57 (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
58 (do ()
59 ((pair-queue-empty-p b)
60 #+grobner-check(grobner-test ring-and-order f f)
61 (debug-cgb "~&GROBNER END")
62 f)
63 (let ((pair (pair-queue-remove b)))
64 (declare (type pair pair))
65 (cond
66 ((criterion-1 pair) nil)
67 ((criterion-2 pair b-done f) nil)
68 (t
69 (let ((sp (normal-form ring-and-order
70 (spoly ring-and-order
71 (pair-first pair)
72 (pair-second pair))
73 f top-reduction-only)))
74 (declare (type poly sp))
75 (cond
76 ((poly-zerop sp)
77 nil)
78 (t
79 (setf sp (poly-primitive-part ring sp)
80 f (nconc f (list sp)))
81 ;; Add new critical pairs
82 (dolist (h f)
83 (pair-queue-insert b (make-pair h sp)))
84 (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
85 (pair-sugar pair) (length f) (pair-queue-size b)
86 (hash-table-count b-done)))))))
87 (setf (gethash (list (pair-first pair) (pair-second pair)) b-done)
88 t)))))
89
90(defun parallel-buchberger (ring-and-order f
91 &optional
92 (start 0)
93 (top-reduction-only $poly_top_reduction_only)
94 &aux
95 (ring (ro-ring ring-and-order)))
96 "An implementation of the Buchberger algorithm. Return Grobner basis
97of the ideal generated by the polynomial list F. Polynomials 0 to
98START-1 are assumed to be a Grobner basis already, so that certain
99critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
100reduction will be preformed."
101 (declare (type ring-and-order ring-and-order)
102 (ignore top-reduction-only)
103 (type fixnum start))
104 (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs
105 (debug-cgb "~&GROBNER BASIS - PARALLEL-BUCHBERGER ALGORITHM")
106 (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
107 #+grobner-check (when (plusp start)
108 (grobner-test ring-and-order (subseq f 0 start) (subseq f 0 start)))
109 ;;Initialize critical pairs
110 (let ((b (pair-queue-initialize (make-pair-queue) f start))
111 (b-done (make-hash-table :test #'equal)))
112 (declare (type priority-queue b)
113 (type hash-table b-done))
114 (dotimes (i (1- start))
115 (do ((j (1+ i) (1+ j))) ((>= j start))
116 (declare (type fixnum j))
117 (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
118 (do ()
119 ((pair-queue-empty-p b)
120 #+grobner-check(grobner-test ring-and-order f f)
121 (debug-cgb "~&GROBNER END")
122 f)
123 (let ((pair (pair-queue-remove b)))
124 (when (null (pair-division-data pair))
125 (setf (pair-division-data pair) (list (spoly ring-and-order
126 (pair-first pair)
127 (pair-second pair))
128 (make-poly-zero)
129 (funcall (ring-unit ring))
130 0)))
131 (cond
132 ((criterion-1 pair) nil)
133 ((criterion-2 pair b-done f) nil)
134 (t
135 (let* ((dd (pair-division-data pair))
136 (p (first dd))
137 (sp (second dd))
138 (c (third dd))
139 (division-count (fourth dd)))
140 (cond
141 ((poly-zerop p) ;normal form completed
142 (debug-cgb "~&~3T~d reduction~:p" division-count)
143 (cond
144 ((poly-zerop sp)
145 (debug-cgb " ---> 0")
146 nil)
147 (t
148 (setf sp (poly-nreverse sp)
149 sp (poly-primitive-part ring sp)
150 f (nconc f (list sp)))
151 ;; Add new critical pairs
152 (dolist (h f)
153 (pair-queue-insert b (make-pair h sp)))
154 (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
155 (pair-sugar pair) (length f) (pair-queue-size b)
156 (hash-table-count b-done))))
157 (setf (gethash (list (pair-first pair) (pair-second pair))
158 b-done) t))
159 (t ;normal form not complete
160 (do ()
161 ((cond
162 ((> (poly-sugar sp) (pair-sugar pair))
163 (debug-cgb "(~a)?" (poly-sugar sp))
164 t)
165 ((poly-zerop p)
166 (debug-cgb ".")
167 t)
168 (t nil))
169 (setf (first dd) p
170 (second dd) sp
171 (third dd) c
172 (fourth dd) division-count
173 (pair-sugar pair) (poly-sugar sp))
174 (pair-queue-insert b pair))
175 (multiple-value-setq (p sp c division-count)
176 (normal-form-step ring-and-order f p sp c division-count))))))))))))
Note: See TracBrowser for help on using the repository browser.