source: CGBLisp/src/DEAD_CODE/sugar.lisp@ 1

;;------------------------------------------------------------------------------------------------
;;
;; A different implementation of the sugar strategy
;;
;;------------------------------------------------------------------------------------------------

(defvar *default-sugar-limit* 4 
  "The default sugar level which triggers aborting S-polynomial calculation.")

(defun grobner-sugar (F-no-sugar pred start top-reduction-only ring
                                 &optional (sugar-limit *default-sugar-limit*)
                                 &aux (s (1- (length F-no-sugar))) B M F)
  (declare (fixnum s))
  (unless (plusp s) (return-from grobner-sugar F-no-sugar)) ;cut startup costs
  #+debug (debug-cgb "~&GROBNER BASIS - SUGER LIMIT:~d" sugar-limit)
  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
  #+grobner-check  (when (plusp start)
                     (grobner-test (subseq F-no-sugar 0 start)
                                   (subseq F-no-sugar 0 start) pred ring))
  (setf F (mapcar #'(lambda (x) (poly-add-sugar x ring)) F-no-sugar)
        B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
                 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
        M (make-hash-table :test #'equal)
        B (grobner-sugar-sort-pairs B F pred ring))
  ;;Initialize treated pairs
  (dotimes (i (1- start))
    (do ((j (1+ i) (1+ j))) ((>= j start))
      (setf (gethash (list i j) M) t)))
  (do ((G F) pair)
      ((endp B)
       (setf G (mapcar #'poly-with-sugar-poly G))
       #+grobner-check(grobner-test G F-no-sugar pred ring)
       #+debug(debug-cgb "~&GROBNER ENDED WITH SUGAR: ~d" sugar-limit)
       G)
    ;;Find a pair with sugar < sugar-limit
    ;;If no pair found, increase sugar limit and repeat
    (loop
     (setf pair (find sugar-limit B :test #'>
                      :key #'(lambda (p) (spoly-sugar (elt G (first p)) (elt G (second p)) ring))))
     (cond
      ((null pair)
       (incf sugar-limit)
       #+debug(debug-cgb "~&RAISED SUGAR LEVEL: ~d" sugar-limit))
      (t
       (setf B (delete pair B))
       (return))))
    (cond
     ((Criterion-1-with-sugar pair G)
      #+debug(debug-cgb "[B1]"))
     ((Criterion-2-with-sugar pair G M)
      #+debug(debug-cgb "[B2]"))
     (t
      (let ((SP  (normal-form-with-sugar (spoly-with-sugar (elt G (first pair))
                                                           (elt G (second pair)) pred ring)
                                         G pred top-reduction-only ring
                                         sugar-limit)))
        (cond
         ((poly-with-sugar-zerop SP))
         (t
          #+debug
          (when (>= (poly-with-sugar-sugar SP) sugar-limit)
            (debug-cgb "*"))
          (setf s (1+ s)
                (poly-with-sugar-poly SP) (grobner-primitive-part (poly-with-sugar-poly SP) ring)
                G (nconc G (list SP))
                B (grobner-sugar-merge-pairs B (makelist (list i s)
                                                         (i 0 (1- s)))
                                             G pred ring))
          #+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d;"
                             (length G) (length B)
                             (hash-table-count M)))))
      (setf (gethash pair M) t)))))


(defun grobner-sugar-merge-pairs (B C G pred ring)
  (declare (ignore G pred ring))
  "Merges lists of critical pairs. It simply nconcs the lists at this time."
  (nconc B C))

(defun grobner-sugar-sort-pairs (C G pred ring)
  (grobner-sugar-merge-pairs nil C G pred ring))