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