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

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

* empty log message *
File size: 6.2 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 :polynomial :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 "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."
43 (declare (type fixnum start))
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))
47 #+grobner-check (when (plusp start)
48 (grobner-test (subseq f 0 start) (subseq f 0 start)))
49 ;;Initialize critical pairs
50 (let ((b (make-critical-pair-queue *normal-strategy* f start))
51 (b-done (make-hash-table :test #'equal)))
52 (declare (type critical-pair-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 ((queue-empty-p b)
58 #+grobner-check(grobner-test f f)
59 (debug-cgb "~&GROBNER END")
60 f)
61 (let ((pair (dequeue b)))
62 (declare (type critical-pair pair))
63 (cond
64 ((criterion-1 pair) nil)
65 ((criterion-2 pair b-done f) nil)
66 (t
67 (let ((sp (normal-form (s-polynomial
68 (critical-pair-first pair)
69 (critical-pair-second pair))
70 f top-reduction-only)))
71 (declare (type poly sp))
72 (cond
73 ((universal-zerop sp)
74 nil)
75 (t
76 (setf sp (poly-primitive-part sp)
77 f (nconc f (list sp)))
78 ;; Add new critical pairs
79 (dolist (h f)
80 (enqueue b (make-instance 'critical-pair :first h :second sp)))
81 (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
82 (length f) (queue-size b)
83 (hash-table-count b-done)))))))
84 (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair)) b-done)
85 t)))))
86
87(defun parallel-buchberger (f
88 &optional
89 (start 0)
90 (top-reduction-only $poly_top_reduction_only))
91 "An implementation of the Buchberger algorithm. Return Grobner basis
92of the ideal generated by the polynomial list F. Polynomials 0 to
93START-1 are assumed to be a Grobner basis already, so that certain
94critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
95reduction will be preformed."
96 (declare (ignore top-reduction-only)
97 (type fixnum start))
98 (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs
99 (debug-cgb "~&GROBNER BASIS - PARALLEL-BUCHBERGER ALGORITHM")
100 (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
101 #+grobner-check (when (plusp start)
102 (grobner-test (subseq f 0 start) (subseq f 0 start)))
103 ;;Initialize critical pairs
104 (let ((b (make-critical-pair-queue *normal-strategy* f start))
105 (b-done (make-hash-table :test #'equal))
106 (coeff-zero (make-zero-for (leading-coefficient (car f))))
107 (coeff-unit (make-unit-for (leading-coefficient (car f)))))
108 (declare (type priority-queue b)
109 (type hash-table b-done))
110 (dotimes (i (1- start))
111 (do ((j (1+ i) (1+ j))) ((>= j start))
112 (declare (type fixnum j))
113 (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
114 (do ()
115 ((queue-empty-p b)
116 #+grobner-check(grobner-test f f)
117 (debug-cgb "~&GROBNER END")
118 f)
119 (let ((pair (dequeue b)))
120 (when (null (critical-pair-data pair))
121 (setf (critical-pair-data pair) (list (s-polynomial
122 (critical-pair-first pair)
123 (critical-pair-second pair))
124 coeff-zero
125 coeff-unit
126 0)))
127 (cond
128 ((criterion-1 pair) nil)
129 ((criterion-2 pair b-done f) nil)
130 (t
131 (let* ((dd (critical-pair-data pair))
132 (p (first dd))
133 (sp (second dd))
134 (c (third dd))
135 (division-count (fourth dd)))
136 (cond
137 ((universal-zerop p) ;normal form completed
138 (debug-cgb "~&~3T~d reduction~:p" division-count)
139 (cond
140 ((universal-zerop sp)
141 (debug-cgb " ---> 0")
142 nil)
143 (t
144 (setf sp (poly-primitive-part sp)
145 f (nconc f (list sp)))
146 ;; Add new critical pairs
147 (dolist (h f)
148 (enqueue b (make-instance 'critical-pair :first h :second sp)))
149 (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
150 (length f) (queue-size b)
151 (hash-table-count b-done))))
152 (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair))
153 b-done) t))
154 (t ;normal form not complete
155 (do ()
156 ((cond
157 ((universal-zerop p)
158 (debug-cgb ".")
159 t)
160 (t nil))
161 (setf (first dd) p
162 (second dd) sp
163 (third dd) c
164 (fourth dd) division-count)
165 (enqueue b pair))
166 (multiple-value-setq (p sp c division-count)
167 (normal-form-step f p sp c division-count))))))))))))
Note: See TracBrowser for help on using the repository browser.