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@ 1956

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

* empty log message *
File size: 5.2 KB
Line 
1;;; -*- Mode: Lisp -*-
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;
4;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19;;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; An implementation of the algorithm of Gebauer and Moeller, as
25;; described in the book of Becker-Weispfenning, p. 232
26;;
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(defpackage "GEBAUER-MOELLER"
30 (:use :cl :grobner-debug
31 :division :ring :monom :polynomial :order :ring-and-order
32 :pair-queue :priority-queue
33 )
34 (:export "GEBAUER-MOELLER"))
35
36(in-package :gebauer-moeller)
37
38(defun gebauer-moeller (ring-and-order f
39 &optional
40 (start 0)
41 (top-reduction-only $poly_top_reduction_only)
42 &aux
43 (ring (ro-ring ring-and-order)))
44 "Compute Grobner basis by using the algorithm of Gebauer and
45Moeller. This algorithm is described as BUCHBERGERNEW2 in the book by
46Becker-Weispfenning entitled ``Grobner Bases''. This function assumes
47that all polynomials in F are non-zero."
48 (declare (ignore top-reduction-only)
49 (type fixnum start)
50 (type ring-and-order ring-and-order))
51 (cond
52 ((endp f) (return-from gebauer-moeller nil))
53 ((endp (cdr f))
54 (return-from gebauer-moeller (list (poly-primitive-part ring (car f))))))
55 (debug-cgb "~&GROBNER BASIS - GEBAUER MOELLER ALGORITHM")
56 (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
57 #+grobner-check (when (plusp start)
58 (grobner-test ring-and-order (subseq f 0 start) (subseq f 0 start)))
59 (let ((b (make-pair-queue))
60 (g (subseq f 0 start))
61 (f1 (subseq f start)))
62 (declare (dynamic-extent b))
63 (do () ((endp f1))
64 (multiple-value-setq (g b)
65 (gebauer-moeller-update g b (poly-primitive-part ring (pop f1)))))
66 (do () ((pair-queue-empty-p b))
67 (let* ((pair (pair-queue-remove b))
68 (g1 (pair-first pair))
69 (g2 (pair-second pair))
70 (h (normal-form ring-and-order (spoly ring-and-order g1 g2)
71 g
72 nil #| Always fully reduce! |#
73 )))
74 (unless (poly-zerop h)
75 (setf h (poly-primitive-part ring h))
76 (multiple-value-setq (g b)
77 (gebauer-moeller-update g b h))
78 (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d~%"
79 (pair-sugar pair) (length g) (pair-queue-size b))
80 )))
81 #+grobner-check(grobner-test ring-and-order g f)
82 (debug-cgb "~&GROBNER END")
83 g))
84
85(defun gebauer-moeller-update (g b h
86 &aux
87 c d e
88 (b-new (make-pair-queue))
89 g-new)
90 "An implementation of the auxillary UPDATE algorithm used by the
91Gebauer-Moeller algorithm. G is a list of polynomials, B is a list of
92critical pairs and H is a new polynomial which possibly will be added
93to G. The naming conventions used are very close to the one used in
94the book of Becker-Weispfenning."
95 (declare
96 #+allegro (dynamic-extent b)
97 (type poly h)
98 (type priority-queue b))
99 (setf c g d nil)
100 (do () ((endp c))
101 (let ((g1 (pop c)))
102 (declare (type poly g1))
103 (when (or (monom-rel-prime-p (poly-lm h) (poly-lm g1))
104 (and
105 (notany #'(lambda (g2) (monom-lcm-divides-monom-lcm-p
106 (poly-lm h) (poly-lm g2)
107 (poly-lm h) (poly-lm g1)))
108 c)
109 (notany #'(lambda (g2) (monom-lcm-divides-monom-lcm-p
110 (poly-lm h) (poly-lm g2)
111 (poly-lm h) (poly-lm g1)))
112 d)))
113 (push g1 d))))
114 (setf e nil)
115 (do () ((endp d))
116 (let ((g1 (pop d)))
117 (declare (type poly g1))
118 (unless (monom-rel-prime-p (poly-lm h) (poly-lm g1))
119 (push g1 e))))
120 (do () ((pair-queue-empty-p b))
121 (let* ((pair (pair-queue-remove b))
122 (g1 (pair-first pair))
123 (g2 (pair-second pair)))
124 (declare (type pair pair)
125 (type poly g1 g2))
126 (when (or (not (monom-divides-monom-lcm-p
127 (poly-lm h)
128 (poly-lm g1) (poly-lm g2)))
129 (monom-lcm-equal-monom-lcm-p
130 (poly-lm g1) (poly-lm h)
131 (poly-lm g1) (poly-lm g2))
132 (monom-lcm-equal-monom-lcm-p
133 (poly-lm h) (poly-lm g2)
134 (poly-lm g1) (poly-lm g2)))
135 (pair-queue-insert b-new (make-pair g1 g2)))))
136 (dolist (g3 e)
137 (pair-queue-insert b-new (make-pair h g3)))
138 (setf g-new nil)
139 (do () ((endp g))
140 (let ((g1 (pop g)))
141 (declare (type poly g1))
142 (unless (monom-divides-p (poly-lm h) (poly-lm g1))
143 (push g1 g-new))))
144 (push h g-new)
145 (values g-new b-new))
Note: See TracBrowser for help on using the repository browser.