source: branches/f4grobner/buchberger.lisp@ 74

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Buchberger Algorithm Implementation
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun buchberger (ring f start &optional (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. This function assumes that all polynomials
in F are non-zero."
  (declare (type fixnum start))
  (when (endp f) (return-from buchberger f)) ;cut startup costs
  (debug-cgb "~&GROBNER BASIS - BUCHBERGER ALGORITHM")
  (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
  #+grobner-check  (when (plusp start)
                     (grobner-test ring (subseq f 0 start) (subseq f 0 start)))
  ;;Initialize critical pairs
  (let ((b (pair-queue-initialize (make-pair-queue)
                                  f start))
        (b-done (make-hash-table :test #'equal)))
    (declare (type priority-queue b) (type hash-table b-done))
    (dotimes (i (1- start))
      (do ((j (1+ i) (1+ j))) ((>= j start))
        (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
    (do ()
        ((pair-queue-empty-p b)
         #+grobner-check(grobner-test ring f f)
         (debug-cgb "~&GROBNER END")
         f)
      (let ((pair (pair-queue-remove b)))
        (declare (type pair pair))
        (cond
          ((criterion-1 pair) nil)
          ((criterion-2 pair b-done f) nil)
          (t 
           (let ((sp (normal-form ring (spoly ring (pair-first pair)
                                              (pair-second pair))
                                  f top-reduction-only)))
             (declare (type poly sp))
             (cond
               ((poly-zerop sp)
                nil)
               (t
                (setf sp (poly-primitive-part ring sp)
                      f (nconc f (list sp)))
                ;; Add new critical pairs
                (dolist (h f)
                  (pair-queue-insert b (make-pair h sp)))
                (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
                           (pair-sugar pair) (length f) (pair-queue-size b)
                           (hash-table-count b-done)))))))
        (setf (gethash (list (pair-first pair) (pair-second pair)) b-done)
              t)))))

(defun parallel-buchberger (ring f start &optional (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 ring (subseq f 0 start) (subseq f 0 start)))
  ;;Initialize critical pairs
  (let ((b (pair-queue-initialize (make-pair-queue) f start))
        (b-done (make-hash-table :test #'equal)))
    (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 ()
        ((pair-queue-empty-p b)
         #+grobner-check(grobner-test ring f f)
         (debug-cgb "~&GROBNER END")
         f)
      (let ((pair (pair-queue-remove b)))
        (when (null (pair-division-data pair))
          (setf (pair-division-data pair) (list (spoly ring
                                                       (pair-first pair)
                                                       (pair-second pair))
                                                (make-poly-zero)
                                                (funcall (ring-unit ring))
                                                0)))
        (cond
          ((criterion-1 pair) nil)
          ((criterion-2 pair b-done f) nil)
          (t
           (let* ((dd (pair-division-data pair))
                  (p (first dd))
                  (sp (second dd))
                  (c (third dd))
                  (division-count (fourth dd)))
             (cond
               ((poly-zerop p)          ;normal form completed
                (debug-cgb "~&~3T~d reduction~:p" division-count)
                (cond 
                  ((poly-zerop sp)
                   (debug-cgb " ---> 0")
                   nil)
                  (t
                   (setf sp (poly-nreverse sp)
                         sp (poly-primitive-part ring sp)
                         f (nconc f (list sp)))
                   ;; Add new critical pairs
                   (dolist (h f)
                     (pair-queue-insert b (make-pair h sp)))
                   (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
                              (pair-sugar pair) (length f) (pair-queue-size b)
                              (hash-table-count b-done))))
                (setf (gethash (list (pair-first pair) (pair-second pair))
                               b-done) t))
               (t                               ;normal form not complete
                (do ()
                    ((cond
                       ((> (poly-sugar sp) (pair-sugar pair))
                        (debug-cgb "(~a)?" (poly-sugar sp))
                        t)
                       ((poly-zerop p)
                        (debug-cgb ".")
                        t)
                       (t nil))
                     (setf (first dd) p
                           (second dd) sp
                           (third dd) c
                           (fourth dd) division-count
                           (pair-sugar pair) (poly-sugar sp))
                     (pair-queue-insert b pair))
                  (multiple-value-setq (p sp c division-count)
                    (normal-form-step ring f p sp c division-count))))))))))))