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/division.lisp@ 4099

Last change on this file since 4099 was 4089, checked in by Marek Rychlik, 8 years ago

* empty log message *

File size: 10.6 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(defpackage "DIVISION"
23 (:use :cl :copy :utils :monom :polynomial :grobner-debug :symbolic-polynomial)
24 (:export "$POLY_TOP_REDUCTION_ONLY"
25 "POLY-PSEUDO-DIVIDE"
26 "POLY-EXACT-DIVIDE"
27 "NORMAL-FORM-STEP"
28 "NORMAL-FORM"
29 "POLY-NORMALIZE"
30 "POLY-NORMALIZE-LIST"
31 "BUCHBERGER-CRITERION"
32 "GROBNER-TEST"
33 )
34 (:documentation
35 "An implementation of the division algorithm in the polynomial ring."))
36
37(in-package :division)
38
39(defvar $poly_top_reduction_only nil
40 "If not FALSE, use top reduction only whenever possible.
41Top reduction means that division algorithm stops after the first reduction.")
42
43
44(defun grobner-op (c1 c2 m f g)
45 "Returns C2*F-C1*M*G, where F and G are polynomials M is a monomial.
46Assume that the leading terms will cancel."
47 (declare (type monom m)
48 (type poly f g))
49 #+grobner-check(universal-zerop
50 (subtract
51 (multiply c2 (leading-coefficient f))
52 (multiply c1 (leading-coefficient g))))
53 #+grobner-check(universal-equalp (leading-monomial f) (multiply m (leading-monomial g)))
54 ;; Note that below we can drop the leading terms of f ang g for the
55 ;; purpose of polynomial arithmetic.
56 ;;
57 ;; TODO: Make sure that the sugar calculation is correct if leading
58 ;; terms are dropped.
59 (subtract
60 (multiply f c2)
61 (multiply m g c1)))
62
63(defun check-loop-invariant (c f a fl r p
64 &aux
65 (p-zero (make-zero-for f))
66 (a (mapcar #'poly-reverse a))
67 (r (poly-reverse r)))
68 "Check loop invariant of division algorithms, when we divide a
69polynomial F by the list of polynomials FL. The invariant is the
70identity C*F=SUM AI*FI+R+P, where F0 is the initial value of F, A is
71the list of partial quotients, R is the intermediate value of the
72remainder, and P is the intermediate value which eventually becomes
730. A thing to remember is that the terms of polynomials in A and
74the polynomial R have their terms in reversed order. Hence, before
75the arithmetic is performed, we need to fix the order of terms"
76 #|
77 (format t "~&----------------------------------------------------------------~%")
78 (format t "#### Loop invariant check ####:~%C=~A~%F=~A~%A=~A~%FL=~A~%R=~A~%P=~A~%"
79 c f a fl r p)
80 |#
81 (let* ((prod (inner-product a fl add multiply p-zero))
82 (succeeded-p (universal-zerop (subtract (multiply f c) (add prod r p)))))
83 (unless succeeded-p
84 (error "#### Polynomial division Loop invariant failed ####:~%C=~A~%F=~A~%A=~A~%FL=~A~%R=~A~%P=~A~%"
85 c f a fl r p))
86 succeeded-p))
87
88
89(defun poly-pseudo-divide (f fl)
90 "Pseudo-divide a polynomial F by the list of polynomials FL. Return
91multiple values. The first value is a list of quotients A. The second
92value is the remainder R. The third argument is a scalar coefficient
93C, such that C*F can be divided by FL within the ring of coefficients,
94which is not necessarily a field. Finally, the fourth value is an
95integer count of the number of reductions performed. The resulting
96objects satisfy the equation: C*F= sum A[i]*FL[i] + R. The sugar of
97the quotients is initialized to default."
98 (declare (type poly f) (list fl))
99 ;; Loop invariant: c*f=sum ai*fi+r+p, where p must eventually become 0
100 (do ((r (make-zero-for f))
101 (c 1)
102 (a (make-list (length fl) :initial-element (make-zero-for f)))
103 (division-count 0)
104 (p f))
105 ((universal-zerop p)
106 #+grobner-check(check-loop-invariant c f a fl r p)
107 (debug-cgb "~&~3T~d reduction~:p" division-count)
108 (when (universal-zerop r) (debug-cgb " ---> 0"))
109 ;; We obtained the terms in reverse order, so must fix that
110 (setf a (mapcar #'poly-reverse a)
111 r (poly-reverse r))
112 (values a r c division-count))
113 (declare (fixnum division-count))
114 ;; Check the loop invariant here
115 #+grobner-check(check-loop-invariant c f a fl r p)
116 (do ((fl fl (rest fl)) ;scan list of divisors
117 (b a (rest b)))
118 ((cond
119 ((endp fl) ;no division occurred
120 t)
121 ((divides-p (leading-monomial (car fl)) (leading-monomial p)) ;division occurred
122 (incf division-count)
123 (multiple-value-bind (gcd c1 c2)
124 (universal-ezgcd (leading-coefficient (car fl)) (leading-coefficient p))
125 (declare (ignore gcd))
126 (let ((m (divide (leading-monomial p) (leading-monomial (car fl)))))
127 ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
128 (mapl #'(lambda (x)
129 (setf (car x) (multiply (car x) c1)))
130 a)
131 (setf r (multiply r c1)
132 c (multiply c c1)
133 p (grobner-op c2 c1 m p (car fl)))
134 (setf (car b) (add (car b)
135 (change-class m 'term :coeff c2))))
136 t))))
137 )))
138
139(defun poly-exact-divide (f g)
140 "Divide a polynomial F by another polynomial G. Assume that exact division
141with no remainder is possible. Returns the quotient."
142 (declare (type poly f g))
143 (multiple-value-bind (quot rem coeff division-count)
144 (poly-pseudo-divide f (list g))
145 (declare (ignore division-count coeff)
146 (list quot)
147 (type poly rem)
148 (type fixnum division-count))
149 (unless (universal-zerop rem) (error "Exact division failed."))
150 (car quot)))
151
152;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153;;
154;; An implementation of the normal form
155;;
156;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157
158(defun normal-form-step (fl p r c division-count
159 &aux
160 (g (find (leading-monomial p) fl
161 :test #'divisible-by-p
162 :key #'leading-monomial)))
163 (cond
164 (g ;division possible
165 (incf division-count)
166 (multiple-value-bind (gcd cg cp)
167 (universal-ezgcd (leading-coefficient g) (leading-coefficient p))
168 (declare (ignore gcd))
169 (let ((m (divide (leading-monomial p) (leading-monomial g))))
170 ;; Multiply the equation c*f=sum ai*fi+r+p by cg.
171 (setf r (multiply r cg)
172 c (multiply c cg)
173 ;; p := cg*p-cp*m*g
174 p (grobner-op cp cg m p g))))
175 (debug-cgb "/"))
176 (t ;no division possible
177 (push (leading-term p) (poly-termlist r)) ;move lt(p) to remainder
178 ;;(setf (poly-sugar r) (max (poly-sugar r) (term-sugar (poly-lt p))))
179 (pop (poly-termlist p)) ;remove lt(p) from p
180 (debug-cgb "+")))
181 (values p r c division-count))
182
183;;
184;; Merge NORMAL-FORM someday with POLY-PSEUDO-DIVIDE.
185;;
186;; TODO: It is hard to test normal form as there is no loop invariant,
187;; like for POLY-PSEUDO-DIVIDE. Is there a testing strategy? One
188;; method would be to test NORMAL-FORM using POLY-PSEUDO-DIVIDE.
189;;
190(defun normal-form (f fl
191 &optional
192 (top-reduction-only $poly_top_reduction_only))
193 #+grobner-check(when (null fl) (warn "normal-form: empty divisor list."))
194 (do ((r (make-zero-for f))
195 (c 1)
196 (division-count 0))
197 ((or (universal-zerop f)
198 ;;(endp fl)
199 (and top-reduction-only (not (universal-zerop r))))
200 (progn
201 (debug-cgb "~&~3T~D reduction~:P" division-count)
202 (when (universal-zerop r)
203 (debug-cgb " ---> 0")))
204 (setf (poly-termlist f) (nreconc (poly-termlist r) (poly-termlist f)))
205 (values f c division-count))
206 (declare (fixnum division-count)
207 (type poly r))
208 (multiple-value-setq (f r c division-count)
209 (normal-form-step fl f r c division-count))))
210
211(defun spoly (f g)
212 "It yields the S-polynomial of polynomials F and G."
213 (declare (type poly f g))
214 (let* ((lcm (universal-lcm (leading-monomial f) (leading-monomial g)))
215 (mf (divide lcm (leading-monomial f)))
216 (mg (divide lcm (leading-monomial g))))
217 (declare (type monom mf mg))
218 (multiple-value-bind (c cf cg)
219 (universal-ezgcd (leading-coefficient f) (leading-coefficient g))
220 (declare (ignore c))
221 (subtract
222 (multiply (multiply mf f) cg)
223 (multiply (multiply mg g) cf)))))
224
225(defun buchberger-criterion (g)
226 "Returns T if G is a Grobner basis, by using the Buchberger
227criterion: for every two polynomials h1 and h2 in G the S-polynomial
228S(h1,h2) reduces to 0 modulo G."
229 (every #'universal-zerop
230 (makelist (normal-form (spoly (elt g i) (elt g j)) g nil)
231 (i 0 (- (length g) 2))
232 (j (1+ i) (1- (length g))))))
233
234
235(defun poly-normalize (p &aux (c (leading-coefficient p)))
236 "Divide a polynomial by its leading coefficient. It assumes
237that the division is possible, which may not always be the
238case in rings which are not fields. The exact division operator
239is assumed to be provided by the RING structure."
240 (mapc #'(lambda (term)
241 (setf (term-coeff term) (divide (term-coeff term) c)))
242 (poly-termlist p))
243 p)
244
245(defun poly-normalize-list (plist)
246 "Divide every polynomial in a list PLIST by its leading coefficient. "
247 (mapcar #'(lambda (x) (poly-normalize x)) plist))
248
249;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
250;;
251;; The function GROBNER-TEST is provided primarily for debugging purposes. To
252;; enable verification of grobner bases with BUCHBERGER-CRITERION, do
253;; (pushnew :grobner-check *features*) and compile/load this file.
254;; With this feature, the calculations will slow down CONSIDERABLY.
255;;
256;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257
258(defun grobner-test (g f)
259 "Test whether G is a Grobner basis and F is contained in G. Return T
260upon success and NIL otherwise."
261 (debug-cgb "~&GROBNER CHECK: ")
262 (let (($poly_grobner_debug nil)
263 (stat1 (buchberger-criterion g))
264 (stat2
265 (every #'universal-zerop
266 (makelist (normal-form (copy-instance (elt f i)) g nil)
267 (i 0 (1- (length f)))))))
268 (unless stat1 (error "~&Buchberger criterion failed, not a grobner basis: ~A" g))
269 (unless stat2
270 (error "~&Original polynomials not in ideal spanned by Grobner basis: ~A" f)))
271 (debug-cgb "~&GROBNER CHECK END")
272 t)
Note: See TracBrowser for help on using the repository browser.