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

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

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