close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/gebauer-moeller.lisp@ 122

Last change on this file since 122 was 63, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 3.6 KB
Line 
1
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; An implementation of the algorithm of Gebauer and Moeller, as
6;; described in the book of Becker-Weispfenning, p. 232
7;;
8;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9
10(defun gebauer-moeller (ring f start &optional (top-reduction-only $poly_top_reduction_only))
11 "Compute Grobner basis by using the algorithm of Gebauer and
12Moeller. This algorithm is described as BUCHBERGERNEW2 in the book by
13Becker-Weispfenning entitled ``Grobner Bases''. This function assumes
14that all polynomials in F are non-zero."
15 (declare (ignore top-reduction-only)
16 (type fixnum start))
17 (cond
18 ((endp f) (return-from gebauer-moeller nil))
19 ((endp (cdr f))
20 (return-from gebauer-moeller (list (poly-primitive-part ring (car f))))))
21 (debug-cgb "~&GROBNER BASIS - GEBAUER MOELLER ALGORITHM")
22 (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
23 #+grobner-check (when (plusp start)
24 (grobner-test ring (subseq f 0 start) (subseq f 0 start)))
25 (let ((b (make-pair-queue))
26 (g (subseq f 0 start))
27 (f1 (subseq f start)))
28 (do () ((endp f1))
29 (multiple-value-setq (g b)
30 (gebauer-moeller-update g b (poly-primitive-part ring (pop f1)))))
31 (do () ((pair-queue-empty-p b))
32 (let* ((pair (pair-queue-remove b))
33 (g1 (pair-first pair))
34 (g2 (pair-second pair))
35 (h (normal-form ring (spoly ring g1 g2)
36 g
37 nil #| Always fully reduce! |#
38 )))
39 (unless (poly-zerop h)
40 (setf h (poly-primitive-part ring h))
41 (multiple-value-setq (g b)
42 (gebauer-moeller-update g b h))
43 (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d~%"
44 (pair-sugar pair) (length g) (pair-queue-size b))
45 )))
46 #+grobner-check(grobner-test ring g f)
47 (debug-cgb "~&GROBNER END")
48 g))
49
50(defun gebauer-moeller-update (g b h
51 &aux
52 c d e
53 (b-new (make-pair-queue))
54 g-new)
55 "An implementation of the auxillary UPDATE algorithm used by the
56Gebauer-Moeller algorithm. G is a list of polynomials, B is a list of
57critical pairs and H is a new polynomial which possibly will be added
58to G. The naming conventions used are very close to the one used in
59the book of Becker-Weispfenning."
60 (declare
61 #+allegro (dynamic-extent b)
62 (type poly h)
63 (type priority-queue b))
64 (setf c g d nil)
65 (do () ((endp c))
66 (let ((g1 (pop c)))
67 (declare (type poly g1))
68 (when (or (monom-rel-prime-p (poly-lm h) (poly-lm g1))
69 (and
70 (notany #'(lambda (g2) (monom-lcm-divides-monom-lcm-p
71 (poly-lm h) (poly-lm g2)
72 (poly-lm h) (poly-lm g1)))
73 c)
74 (notany #'(lambda (g2) (monom-lcm-divides-monom-lcm-p
75 (poly-lm h) (poly-lm g2)
76 (poly-lm h) (poly-lm g1)))
77 d)))
78 (push g1 d))))
79 (setf e nil)
80 (do () ((endp d))
81 (let ((g1 (pop d)))
82 (declare (type poly g1))
83 (unless (monom-rel-prime-p (poly-lm h) (poly-lm g1))
84 (push g1 e))))
85 (do () ((pair-queue-empty-p b))
86 (let* ((pair (pair-queue-remove b))
87 (g1 (pair-first pair))
88 (g2 (pair-second pair)))
89 (declare (type pair pair)
90 (type poly g1 g2))
91 (when (or (not (monom-divides-monom-lcm-p
92 (poly-lm h)
93 (poly-lm g1) (poly-lm g2)))
94 (monom-lcm-equal-monom-lcm-p
95 (poly-lm g1) (poly-lm h)
96 (poly-lm g1) (poly-lm g2))
97 (monom-lcm-equal-monom-lcm-p
98 (poly-lm h) (poly-lm g2)
99 (poly-lm g1) (poly-lm g2)))
100 (pair-queue-insert b-new (make-pair g1 g2)))))
101 (dolist (g3 e)
102 (pair-queue-insert b-new (make-pair h g3)))
103 (setf g-new nil)
104 (do () ((endp g))
105 (let ((g1 (pop g)))
106 (declare (type poly g1))
107 (unless (monom-divides-p (poly-lm h) (poly-lm g1))
108 (push g1 g-new))))
109 (push h g-new)
110 (values g-new b-new))
Note: See TracBrowser for help on using the repository browser.