Changeset 4205 for branches/f4grobner/buchberger.lisp

Timestamp:

2016-06-04T11:30:39-07:00 (8 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/buchberger.lisp (modified) (1 diff)

branches/f4grobner/buchberger.lisp

@@ -84 +84 @@
         (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair)) b-done)
               t)))))
-
-(defun parallel-buchberger (f 
-                            &optional 
-                              (start 0)
-                              (top-reduction-only $poly_top_reduction_only))
-  "An implementation of the Buchberger algorithm. Return Grobner basis
-of the ideal generated by the polynomial list F.  Polynomials 0 to
-START-1 are assumed to be a Grobner basis already, so that certain
-critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
-reduction will be preformed."
-  (declare (ignore top-reduction-only)
-           (type fixnum start))
-  (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs
-  (debug-cgb "~&GROBNER BASIS - PARALLEL-BUCHBERGER ALGORITHM")
-  (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
-  #+grobner-check  (when (plusp start)
-                     (grobner-test (subseq f 0 start) (subseq f 0 start)))
-  ;;Initialize critical pairs
-  (let ((b (make-critical-pair-queue *normal-strategy* f start))
-        (b-done (make-hash-table :test #'equal))
-        (coeff-zero (make-zero-for (leading-coefficient (car f))))
-        (coeff-unit (make-unit-for (leading-coefficient (car f)))))
-    (declare (type priority-queue b)
-             (type hash-table b-done))
-    (dotimes (i (1- start))
-      (do ((j (1+ i) (1+ j))) ((>= j start))
-        (declare (type fixnum j))
-        (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
-    (do ()
-        ((queue-empty-p b)
-         #+grobner-check(grobner-test f f)
-         (debug-cgb "~&GROBNER END")
-         f)
-      (let ((pair (dequeue b)))
-        (when (null (critical-pair-data pair))
-          (setf (critical-pair-data pair) (list (s-polynomial
-                                                          (critical-pair-first pair)
-                                                          (critical-pair-second pair))
-                                                         coeff-zero
-                                                         coeff-unit
-                                                         0)))
-        (cond
-          ((criterion-1 pair) nil)
-          ((criterion-2 pair b-done f) nil)
-          (t
-           (let* ((dd (critical-pair-data pair))
-                  (p (first dd))
-                  (sp (second dd))
-                  (c (third dd))
-                  (division-count (fourth dd)))
-             (cond
-               ((universal-zerop p)     ;normal form completed
-                (debug-cgb "~&~3T~d reduction~:p" division-count)
-                (cond 
-                  ((universal-zerop sp)
-                   (debug-cgb " ---> 0")
-                   nil)
-                  (t
-                   (setf sp (poly-primitive-part sp)
-                         f (nconc f (list sp)))
-                   ;; Add new critical pairs
-                   (dolist (h f)
-                     (enqueue b (make-instance 'critical-pair :first h :second sp)))
-                   (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
-                              (length f) (queue-size b)
-                              (hash-table-count b-done))))
-                (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair))
-                               b-done) t))
-               (t                               ;normal form not complete
-                (do ()
-                    ((cond
-                       ((universal-zerop p)
-                        (debug-cgb ".")
-                        t)
-                       (t nil))
-                     (setf (first dd) p
-                           (second dd) sp
-                           (third dd) c
-                           (fourth dd) division-count)
-                     (enqueue b pair))
-                  (multiple-value-setq (p sp c division-count)
-                    (normal-form-step f p sp c division-count))))))))))))