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

Last change on this file since 1957 was 1954, checked in by Marek Rychlik, 10 years ago

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