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

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

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