source: branches/f4grobner/buchberger.lisp@ 85

;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;                                                                              

;;;  Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>          

;;;                                                                              

;;;  This program is free software; you can redistribute it and/or modify        

;;;  it under the terms of the GNU General Public License as published by        

;;;  the Free Software Foundation; either version 2 of the License, or           

;;;  (at your option) any later version.                                         

;;;                                                                              

;;;  This program is distributed in the hope that it will be useful,             

;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of              

;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the               

;;;  GNU General Public License for more details.                                

;;;                                                                              

;;;  You should have received a copy of the GNU General Public License           

;;;  along with this program; if not, write to the Free Software                 

;;;  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  

;;;                                                                              

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; 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))))))))))))