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

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

* empty log message *

File size: 9.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(defpackage "DIVISION"
23 (:use :cl :utils :ring :monomial :polynomial :grobner-debug :term :ring-and-order)
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 ))
33
34(in-package :division)
35
36(defvar $poly_top_reduction_only nil
37 "If not FALSE, use top reduction only whenever possible.
38Top reduction means that division algorithm stops after the first reduction.")
39
40;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41;;
42;; An implementation of the division algorithm
43;;
44;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45
46(defun grobner-op (ring-and-order c1 c2 m f g
47 &aux
48 (ring (ro-ring ring-and-order)))
49 "Returns C2*F-C1*M*G, where F and G are polynomials M is a monomial.
50Assume that the leading terms will cancel."
51 (declare (type ring-and-order ring-and-order))
52 #+grobner-check(funcall (ring-zerop ring)
53 (funcall (ring-sub ring)
54 (funcall (ring-mul ring) c2 (poly-lc f))
55 (funcall (ring-mul ring) c1 (poly-lc g))))
56 #+grobner-check(monom-equal-p (poly-lm f) (monom-mul m (poly-lm g)))
57 ;; Note that below we can drop the leading terms of f ang g for the
58 ;; purpose of polynomial arithmetic.
59 ;;
60 ;; TODO: Make sure that the sugar calculation is correct if leading
61 ;; terms are dropped.
62 (poly-sub ring-and-order
63 (scalar-times-poly-1 ring c2 f)
64 (scalar-times-poly-1 ring c1 (monom-times-poly m g))))
65
66(defun check-loop-invariant (ring-and-order c f0 a fl r p
67 &aux
68 (ring (ro-ring ring-and-order))
69 (p-zero (make-poly-zero)))
70 "Check loop invariant of division algorithms, when we divide a
71polynomial F by the list of polynomials FL. The invariant is the
72identity C*F0=SUM AI*FI+R+F, where F0 is the initial value of F, A is
73the list of partial quotients, R is the intermediate value of the
74remainder, and F is the intermediate value which eventually becomes
750."
76 (flet ((p-add (p q) (poly-add ring-and-order p q))
77 (p-sub (p q) (poly-sub ring-and-order p q))
78 (p-mul (p q) (poly-mul ring-and-order p q)))
79 (poly-zerop
80 (p-sub
81 (scalar-times-poly ring c f0)
82 (reduce #'p-add
83 (list (inner-product a fl p-add p-mul p-zero)
84 r
85 p))))))
86
87
88(defun poly-pseudo-divide (ring-and-order f fl
89 &aux
90 (ring (ro-ring ring-and-order)))
91 "Pseudo-divide a polynomial F by the list of polynomials FL. Return
92multiple values. The first value is a list of quotients A. The second
93value is the remainder R. The third argument is a scalar coefficient
94C, such that C*F can be divided by FL within the ring of coefficients,
95which is not necessarily a field. Finally, the fourth value is an
96integer count of the number of reductions performed. The resulting
97objects satisfy the equation: C*F= sum A[i]*FL[i] + R. The sugar of
98the quotients is initialized to default."
99 (declare (type poly f) (list fl))
100 ;; Loop invariant: c*f=sum ai*fi+r+p, where p must eventually become 0
101 (do ((r (make-poly-zero))
102 (c (funcall (ring-unit ring)))
103 (a (make-list (length fl) :initial-element (make-poly-zero)))
104 (division-count 0)
105 (p f))
106 ((poly-zerop p)
107 (debug-cgb "~&~3T~d reduction~:p" division-count)
108 (when (poly-zerop r) (debug-cgb " ---> 0"))
109 ;; We obtained the terms in reverse order, so must fix that
110 (setf a (mapcar #'poly-nreverse a)
111 r (poly-nreverse r))
112 ;; Initialize the sugar of the quotients
113 (mapc #'poly-reset-sugar a)
114 (values a r c division-count))
115 (declare (fixnum division-count))
116 (do ((fl fl (rest fl)) ;scan list of divisors
117 (b a (rest b)))
118 ((cond
119 ((endp fl) ;no division occurred
120 (push (poly-lt p) (poly-termlist r)) ;move lt(p) to remainder
121 (setf (poly-sugar r) (max (poly-sugar r) (term-sugar (poly-lt p))))
122 (pop (poly-termlist p)) ;remove lt(p) from p
123 ;; Run the check here
124 (assert (check-loop-invariant ring-and-order c f a fl r p))
125 t)
126 ((monom-divides-p (poly-lm (car fl)) (poly-lm p)) ;division occurred
127 (incf division-count)
128 (multiple-value-bind (gcd c1 c2)
129 (funcall (ring-ezgcd ring) (poly-lc (car fl)) (poly-lc p))
130 (declare (ignore gcd))
131 (let ((m (monom-div (poly-lm p) (poly-lm (car fl)))))
132 ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
133 (mapl #'(lambda (x)
134 (setf (car x) (scalar-times-poly ring c1 (car x))))
135 a)
136 (setf r (scalar-times-poly ring c1 r)
137 c (funcall (ring-mul ring) c c1)
138 p (grobner-op ring-and-order c2 c1 m p (car fl)))
139 (push (make-term m c2) (poly-termlist (car b))))
140 t)))))))
141
142(defun poly-exact-divide (ring f g)
143 "Divide a polynomial F by another polynomial G. Assume that exact division
144with no remainder is possible. Returns the quotient."
145 (declare (type poly f g))
146 (multiple-value-bind (quot rem coeff division-count)
147 (poly-pseudo-divide ring f (list g))
148 (declare (ignore division-count coeff)
149 (list quot)
150 (type poly rem)
151 (type fixnum division-count))
152 (unless (poly-zerop rem) (error "Exact division failed."))
153 (car quot)))
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;;
157;; An implementation of the normal form
158;;
159;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
160
161(defun normal-form-step (ring-and-order fl p r c division-count
162 &aux
163 (ring (ro-ring ring-and-order))
164 (g (find (poly-lm p) fl
165 :test #'monom-divisible-by-p
166 :key #'poly-lm)))
167 (cond
168 (g ;division possible
169 (incf division-count)
170 (multiple-value-bind (gcd cg cp)
171 (funcall (ring-ezgcd ring) (poly-lc g) (poly-lc p))
172 (declare (ignore gcd))
173 (let ((m (monom-div (poly-lm p) (poly-lm g))))
174 ;; Multiply the equation c*f=sum ai*fi+r+p by cg.
175 (setf r (scalar-times-poly ring cg r)
176 c (funcall (ring-mul ring) c cg)
177 ;; p := cg*p-cp*m*g
178 p (grobner-op ring-and-order cp cg m p g))))
179 (debug-cgb "/"))
180 (t ;no division possible
181 (push (poly-lt p) (poly-termlist r)) ;move lt(p) to remainder
182 (setf (poly-sugar r) (max (poly-sugar r) (term-sugar (poly-lt p))))
183 (pop (poly-termlist p)) ;remove lt(p) from p
184 (debug-cgb "+")))
185 (values p r c division-count))
186
187;; Merge it sometime with poly-pseudo-divide
188(defun normal-form (ring-and-order f fl
189 &optional
190 (top-reduction-only $poly_top_reduction_only)
191 (ring (ro-ring ring-and-order)))
192 #+grobner-check(when (null fl) (warn "normal-form: empty divisor list."))
193 (do ((r (make-poly-zero))
194 (c (funcall (ring-unit ring)))
195 (division-count 0)
196 #+grobner-check(f0 f))
197 ((or (poly-zerop f)
198 ;;(endp fl)
199 (and top-reduction-only (not (poly-zerop r))))
200 (progn
201 (debug-cgb "~&~3T~D reduction~:P" division-count)
202 (when (poly-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 ring-and-order fl f r c division-count))))
210
211(defun buchberger-criterion (ring-and-order g)
212 "Returns T if G is a Grobner basis, by using the Buchberger
213criterion: for every two polynomials h1 and h2 in G the S-polynomial
214S(h1,h2) reduces to 0 modulo G."
215 (every #'poly-zerop
216 (makelist (normal-form ring-and-order (spoly ring-and-order (elt g i) (elt g j)) g nil)
217 (i 0 (- (length g) 2))
218 (j (1+ i) (1- (length g))))))
219
220
221(defun poly-normalize (ring p &aux (c (poly-lc p)))
222 "Divide a polynomial by its leading coefficient. It assumes
223that the division is possible, which may not always be the
224case in rings which are not fields. The exact division operator
225is assumed to be provided by the RING structure."
226 (mapc #'(lambda (term)
227 (setf (term-coeff term) (funcall (ring-div ring) (term-coeff term) c)))
228 (poly-termlist p))
229 p)
230
231(defun poly-normalize-list (ring plist)
232 "Divide every polynomial in a list PLIST by its leading coefficient. "
233 (mapcar #'(lambda (x) (poly-normalize ring x)) plist))
Note: See TracBrowser for help on using the repository browser.