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

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

* empty log message *

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