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

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

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