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