| [4449] | 1 | ;; PORTING UNFINISHED!
|
|---|
| 2 | ;; A modified buchberger algorithm
|
|---|
| 3 |
|
|---|
| 4 | (defun parallel-buchberger (f
|
|---|
| 5 | &optional
|
|---|
| 6 | (start 0)
|
|---|
| 7 | (top-reduction-only $poly_top_reduction_only))
|
|---|
| 8 | "An implementation of the Buchberger algorithm. Return Grobner basis
|
|---|
| 9 | of the ideal generated by the polynomial list F. Polynomials 0 to
|
|---|
| 10 | START-1 are assumed to be a Grobner basis already, so that certain
|
|---|
| 11 | critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
|
|---|
| 12 | reduction will be preformed."
|
|---|
| 13 | (declare (ignore top-reduction-only)
|
|---|
| 14 | (type fixnum start))
|
|---|
| 15 | (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs
|
|---|
| 16 | (debug-cgb "~&GROBNER BASIS - PARALLEL-BUCHBERGER ALGORITHM")
|
|---|
| 17 | (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
|
|---|
| 18 | #+grobner-check (when (plusp start)
|
|---|
| 19 | (grobner-test (subseq f 0 start) (subseq f 0 start)))
|
|---|
| 20 | ;;Initialize critical pairs
|
|---|
| 21 | (let ((b (make-critical-pair-queue *normal-strategy* f start))
|
|---|
| 22 | (b-done (make-hash-table :test #'equal))
|
|---|
| 23 | (coeff-zero (make-zero-for (leading-coefficient (car f))))
|
|---|
| 24 | (coeff-unit (make-unit-for (leading-coefficient (car f)))))
|
|---|
| 25 | (declare (type priority-queue b)
|
|---|
| 26 | (type hash-table b-done))
|
|---|
| 27 | (dotimes (i (1- start))
|
|---|
| 28 | (do ((j (1+ i) (1+ j))) ((>= j start))
|
|---|
| 29 | (declare (type fixnum j))
|
|---|
| 30 | (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
|
|---|
| 31 | (do ()
|
|---|
| 32 | ((queue-empty-p b)
|
|---|
| 33 | #+grobner-check(grobner-test f f)
|
|---|
| 34 | (debug-cgb "~&GROBNER END")
|
|---|
| 35 | f)
|
|---|
| 36 | (let ((pair (dequeue b)))
|
|---|
| 37 | (when (null (critical-pair-data pair))
|
|---|
| 38 | (setf (critical-pair-data pair) (list (s-polynomial
|
|---|
| 39 | (critical-pair-first pair)
|
|---|
| 40 | (critical-pair-second pair))
|
|---|
| 41 | coeff-zero
|
|---|
| 42 | coeff-unit
|
|---|
| 43 | 0)))
|
|---|
| 44 | (cond
|
|---|
| 45 | ((criterion-1 pair) nil)
|
|---|
| 46 | ((criterion-2 pair b-done f) nil)
|
|---|
| 47 | (t
|
|---|
| 48 | (let* ((dd (critical-pair-data pair))
|
|---|
| 49 | (p (first dd))
|
|---|
| 50 | (sp (second dd))
|
|---|
| 51 | (c (third dd))
|
|---|
| 52 | (division-count (fourth dd)))
|
|---|
| 53 | (cond
|
|---|
| 54 | ((universal-zerop p) ;normal form completed
|
|---|
| 55 | (debug-cgb "~&~3T~d reduction~:p" division-count)
|
|---|
| 56 | (cond
|
|---|
| 57 | ((universal-zerop sp)
|
|---|
| 58 | (debug-cgb " ---> 0")
|
|---|
| 59 | nil)
|
|---|
| 60 | (t
|
|---|
| 61 | (setf sp (poly-primitive-part sp)
|
|---|
| 62 | f (nconc f (list sp)))
|
|---|
| 63 | ;; Add new critical pairs
|
|---|
| 64 | (dolist (h f)
|
|---|
| 65 | (enqueue b (make-instance 'critical-pair :first h :second sp)))
|
|---|
| 66 | (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
|
|---|
| 67 | (length f) (queue-size b)
|
|---|
| 68 | (hash-table-count b-done))))
|
|---|
| 69 | (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair))
|
|---|
| 70 | b-done) t))
|
|---|
| 71 | (t ;normal form not complete
|
|---|
| 72 | (do ()
|
|---|
| 73 | ((cond
|
|---|
| 74 | ((universal-zerop p)
|
|---|
| 75 | (debug-cgb ".")
|
|---|
| 76 | t)
|
|---|
| 77 | (t nil))
|
|---|
| 78 | (setf (first dd) p
|
|---|
| 79 | (second dd) sp
|
|---|
| 80 | (third dd) c
|
|---|
| 81 | (fourth dd) division-count)
|
|---|
| 82 | (enqueue b pair))
|
|---|
| 83 | (multiple-value-setq (p sp c division-count)
|
|---|
| 84 | (normal-form-step f p sp c division-count))))))))))))
|
|---|
