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

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

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