[1] | 1 |
|
---|
| 2 |
|
---|
| 3 | ;;------------------------------------------------------------------------------------------------
|
---|
| 4 | ;;
|
---|
| 5 | ;; A different implementation of the sugar strategy
|
---|
| 6 | ;;
|
---|
| 7 | ;;------------------------------------------------------------------------------------------------
|
---|
| 8 |
|
---|
| 9 | (defvar *default-sugar-limit* 4
|
---|
| 10 | "The default sugar level which triggers aborting S-polynomial calculation.")
|
---|
| 11 |
|
---|
| 12 | (defun grobner-sugar (F-no-sugar pred start top-reduction-only ring
|
---|
| 13 | &optional (sugar-limit *default-sugar-limit*)
|
---|
| 14 | &aux (s (1- (length F-no-sugar))) B M F)
|
---|
| 15 | (declare (fixnum s))
|
---|
| 16 | (unless (plusp s) (return-from grobner-sugar F-no-sugar)) ;cut startup costs
|
---|
| 17 | #+debug (debug-cgb "~&GROBNER BASIS - SUGER LIMIT:~d" sugar-limit)
|
---|
| 18 | #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
|
---|
| 19 | #+grobner-check (when (plusp start)
|
---|
| 20 | (grobner-test (subseq F-no-sugar 0 start)
|
---|
| 21 | (subseq F-no-sugar 0 start) pred ring))
|
---|
| 22 | (setf F (mapcar #'(lambda (x) (poly-add-sugar x ring)) F-no-sugar)
|
---|
| 23 | B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
|
---|
| 24 | (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
|
---|
| 25 | M (make-hash-table :test #'equal)
|
---|
| 26 | B (grobner-sugar-sort-pairs B F pred ring))
|
---|
| 27 | ;;Initialize treated pairs
|
---|
| 28 | (dotimes (i (1- start))
|
---|
| 29 | (do ((j (1+ i) (1+ j))) ((>= j start))
|
---|
| 30 | (setf (gethash (list i j) M) t)))
|
---|
| 31 | (do ((G F) pair)
|
---|
| 32 | ((endp B)
|
---|
| 33 | (setf G (mapcar #'poly-with-sugar-poly G))
|
---|
| 34 | #+grobner-check(grobner-test G F-no-sugar pred ring)
|
---|
| 35 | #+debug(debug-cgb "~&GROBNER ENDED WITH SUGAR: ~d" sugar-limit)
|
---|
| 36 | G)
|
---|
| 37 | ;;Find a pair with sugar < sugar-limit
|
---|
| 38 | ;;If no pair found, increase sugar limit and repeat
|
---|
| 39 | (loop
|
---|
| 40 | (setf pair (find sugar-limit B :test #'>
|
---|
| 41 | :key #'(lambda (p) (spoly-sugar (elt G (first p)) (elt G (second p)) ring))))
|
---|
| 42 | (cond
|
---|
| 43 | ((null pair)
|
---|
| 44 | (incf sugar-limit)
|
---|
| 45 | #+debug(debug-cgb "~&RAISED SUGAR LEVEL: ~d" sugar-limit))
|
---|
| 46 | (t
|
---|
| 47 | (setf B (delete pair B))
|
---|
| 48 | (return))))
|
---|
| 49 | (cond
|
---|
| 50 | ((Criterion-1-with-sugar pair G)
|
---|
| 51 | #+debug(debug-cgb "[B1]"))
|
---|
| 52 | ((Criterion-2-with-sugar pair G M)
|
---|
| 53 | #+debug(debug-cgb "[B2]"))
|
---|
| 54 | (t
|
---|
| 55 | (let ((SP (normal-form-with-sugar (spoly-with-sugar (elt G (first pair))
|
---|
| 56 | (elt G (second pair)) pred ring)
|
---|
| 57 | G pred top-reduction-only ring
|
---|
| 58 | sugar-limit)))
|
---|
| 59 | (cond
|
---|
| 60 | ((poly-with-sugar-zerop SP))
|
---|
| 61 | (t
|
---|
| 62 | #+debug
|
---|
| 63 | (when (>= (poly-with-sugar-sugar SP) sugar-limit)
|
---|
| 64 | (debug-cgb "*"))
|
---|
| 65 | (setf s (1+ s)
|
---|
| 66 | (poly-with-sugar-poly SP) (grobner-primitive-part (poly-with-sugar-poly SP) ring)
|
---|
| 67 | G (nconc G (list SP))
|
---|
| 68 | B (grobner-sugar-merge-pairs B (makelist (list i s)
|
---|
| 69 | (i 0 (1- s)))
|
---|
| 70 | G pred ring))
|
---|
| 71 | #+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d;"
|
---|
| 72 | (length G) (length B)
|
---|
| 73 | (hash-table-count M)))))
|
---|
| 74 | (setf (gethash pair M) t)))))
|
---|
| 75 |
|
---|
| 76 |
|
---|
| 77 | (defun grobner-sugar-merge-pairs (B C G pred ring)
|
---|
| 78 | (declare (ignore G pred ring))
|
---|
| 79 | "Merges lists of critical pairs. It simply nconcs the lists at this time."
|
---|
| 80 | (nconc B C))
|
---|
| 81 |
|
---|
| 82 | (defun grobner-sugar-sort-pairs (C G pred ring)
|
---|
| 83 | (grobner-sugar-merge-pairs nil C G pred ring))
|
---|