Changeset 4205
- Timestamp:
- 2016-06-04T11:30:39-07:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/buchberger.lisp
r4194 r4205 84 84 (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair)) b-done) 85 85 t))))) 86 87 (defun parallel-buchberger (f88 &optional89 (start 0)90 (top-reduction-only $poly_top_reduction_only))91 "An implementation of the Buchberger algorithm. Return Grobner basis92 of the ideal generated by the polynomial list F. Polynomials 0 to93 START-1 are assumed to be a Grobner basis already, so that certain94 critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top95 reduction will be preformed."96 (declare (ignore top-reduction-only)97 (type fixnum start))98 (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs99 (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 pairs104 (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-polynomial122 (critical-pair-first pair)123 (critical-pair-second pair))124 coeff-zero125 coeff-unit126 0)))127 (cond128 ((criterion-1 pair) nil)129 ((criterion-2 pair b-done f) nil)130 (t131 (let* ((dd (critical-pair-data pair))132 (p (first dd))133 (sp (second dd))134 (c (third dd))135 (division-count (fourth dd)))136 (cond137 ((universal-zerop p) ;normal form completed138 (debug-cgb "~&~3T~d reduction~:p" division-count)139 (cond140 ((universal-zerop sp)141 (debug-cgb " ---> 0")142 nil)143 (t144 (setf sp (poly-primitive-part sp)145 f (nconc f (list sp)))146 ;; Add new critical pairs147 (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 complete155 (do ()156 ((cond157 ((universal-zerop p)158 (debug-cgb ".")159 t)160 (t nil))161 (setf (first dd) p162 (second dd) sp163 (third dd) c164 (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 TracChangeset
for help on using the changeset viewer.