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

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

* empty log message *

File size: 7.7 KB
RevLine 
[148]1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
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
[459]22(defpackage "DIVISION"
[471]23 (:use :cl :utils :ring :monomial :polynomial :grobner-debug :term)
[470]24 (:export "$POLY_TOP_REDUCTION_ONLY"
25 "POLY-PSEUDO-DIVIDE"
[459]26 "POLY-EXACT-DIVIDE"
[491]27 "NORMAL-FORM-STEP"
[459]28 "NORMAL-FORM"
29 "POLY-NORMALIZE"
[472]30 "POLY-NORMALIZE-LIST"
[473]31 "BUCHBERGER-CRITERION"
[459]32 ))
[148]33
[460]34(in-package :division)
35
[469]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
[59]40;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41;;
42;; An implementation of the division algorithm
43;;
44;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45
46(defun grobner-op (ring c1 c2 m f g)
47 "Returns C2*F-C1*M*G, where F and G are polynomials M is a monomial.
48Assume that the leading terms will cancel."
49 #+grobner-check(funcall (ring-zerop ring)
50 (funcall (ring-sub ring)
51 (funcall (ring-mul ring) c2 (poly-lc f))
52 (funcall (ring-mul ring) c1 (poly-lc g))))
53 #+grobner-check(monom-equal-p (poly-lm f) (monom-mul m (poly-lm g)))
54 ;; Note that we can drop the leading terms of f ang g
55 (poly-sub ring
56 (scalar-times-poly-1 ring c2 f)
57 (scalar-times-poly-1 ring c1 (monom-times-poly m g))))
58
59(defun poly-pseudo-divide (ring f fl)
60 "Pseudo-divide a polynomial F by the list of polynomials FL. Return
61multiple values. The first value is a list of quotients A. The second
62value is the remainder R. The third argument is a scalar coefficient
63C, such that C*F can be divided by FL within the ring of coefficients,
64which is not necessarily a field. Finally, the fourth value is an
65integer count of the number of reductions performed. The resulting
66objects satisfy the equation: C*F= sum A[i]*FL[i] + R."
67 (declare (type poly f) (list fl))
68 (do ((r (make-poly-zero))
69 (c (funcall (ring-unit ring)))
70 (a (make-list (length fl) :initial-element (make-poly-zero)))
71 (division-count 0)
72 (p f))
73 ((poly-zerop p)
74 (debug-cgb "~&~3T~d reduction~:p" division-count)
75 (when (poly-zerop r) (debug-cgb " ---> 0"))
76 (values (mapcar #'poly-nreverse a) (poly-nreverse r) c division-count))
77 (declare (fixnum division-count))
78 (do ((fl fl (rest fl)) ;scan list of divisors
79 (b a (rest b)))
80 ((cond
81 ((endp fl) ;no division occurred
82 (push (poly-lt p) (poly-termlist r)) ;move lt(p) to remainder
83 (setf (poly-sugar r) (max (poly-sugar r) (term-sugar (poly-lt p))))
84 (pop (poly-termlist p)) ;remove lt(p) from p
85 t)
86 ((monom-divides-p (poly-lm (car fl)) (poly-lm p)) ;division occurred
87 (incf division-count)
88 (multiple-value-bind (gcd c1 c2)
89 (funcall (ring-ezgcd ring) (poly-lc (car fl)) (poly-lc p))
90 (declare (ignore gcd))
91 (let ((m (monom-div (poly-lm p) (poly-lm (car fl)))))
92 ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
93 (mapl #'(lambda (x)
94 (setf (car x) (scalar-times-poly ring c1 (car x))))
95 a)
96 (setf r (scalar-times-poly ring c1 r)
97 c (funcall (ring-mul ring) c c1)
98 p (grobner-op ring c2 c1 m p (car fl)))
99 (push (make-term m c2) (poly-termlist (car b))))
100 t)))))))
101
102(defun poly-exact-divide (ring f g)
103 "Divide a polynomial F by another polynomial G. Assume that exact division
104with no remainder is possible. Returns the quotient."
105 (declare (type poly f g))
106 (multiple-value-bind (quot rem coeff division-count)
107 (poly-pseudo-divide ring f (list g))
108 (declare (ignore division-count coeff)
109 (list quot)
110 (type poly rem)
111 (type fixnum division-count))
112 (unless (poly-zerop rem) (error "Exact division failed."))
113 (car quot)))
114
115
116
117;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
118;;
119;; An implementation of the normal form
120;;
121;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122
123(defun normal-form-step (ring fl p r c division-count
124 &aux (g (find (poly-lm p) fl
125 :test #'monom-divisible-by-p
126 :key #'poly-lm)))
127 (cond
128 (g ;division possible
129 (incf division-count)
130 (multiple-value-bind (gcd cg cp)
131 (funcall (ring-ezgcd ring) (poly-lc g) (poly-lc p))
132 (declare (ignore gcd))
133 (let ((m (monom-div (poly-lm p) (poly-lm g))))
134 ;; Multiply the equation c*f=sum ai*fi+r+p by cg.
135 (setf r (scalar-times-poly ring cg r)
136 c (funcall (ring-mul ring) c cg)
137 ;; p := cg*p-cp*m*g
138 p (grobner-op ring cp cg m p g))))
139 (debug-cgb "/"))
140 (t ;no division possible
141 (push (poly-lt p) (poly-termlist r)) ;move lt(p) to remainder
142 (setf (poly-sugar r) (max (poly-sugar r) (term-sugar (poly-lt p))))
143 (pop (poly-termlist p)) ;remove lt(p) from p
144 (debug-cgb "+")))
145 (values p r c division-count))
146
147;; Merge it sometime with poly-pseudo-divide
148(defun normal-form (ring f fl &optional (top-reduction-only $poly_top_reduction_only))
149 ;; Loop invariant: c*f0=sum ai*fi+r+f, where f0 is the initial value of f
150 #+grobner-check(when (null fl) (warn "normal-form: empty divisor list."))
151 (do ((r (make-poly-zero))
152 (c (funcall (ring-unit ring)))
153 (division-count 0))
154 ((or (poly-zerop f)
155 ;;(endp fl)
156 (and top-reduction-only (not (poly-zerop r))))
157 (progn
158 (debug-cgb "~&~3T~d reduction~:p" division-count)
159 (when (poly-zerop r)
160 (debug-cgb " ---> 0")))
161 (setf (poly-termlist f) (nreconc (poly-termlist r) (poly-termlist f)))
162 (values f c division-count))
163 (declare (fixnum division-count)
164 (type poly r))
165 (multiple-value-setq (f r c division-count)
166 (normal-form-step ring fl f r c division-count))))
167
168(defun buchberger-criterion (ring g)
169 "Returns T if G is a Grobner basis, by using the Buchberger
170criterion: for every two polynomials h1 and h2 in G the S-polynomial
171S(h1,h2) reduces to 0 modulo G."
172 (every
173 #'poly-zerop
174 (makelist (normal-form ring (spoly ring (elt g i) (elt g j)) g nil)
175 (i 0 (- (length g) 2))
176 (j (1+ i) (1- (length g))))))
[64]177
178
179(defun poly-normalize (ring p &aux (c (poly-lc p)))
180 "Divide a polynomial by its leading coefficient. It assumes
181that the division is possible, which may not always be the
182case in rings which are not fields. The exact division operator
183is assumed to be provided by the RING structure of the
184COEFFICIENT-RING package."
185 (mapc #'(lambda (term)
186 (setf (term-coeff term) (funcall (ring-div ring) (term-coeff term) c)))
187 (poly-termlist p))
188 p)
189
190(defun poly-normalize-list (ring plist)
191 "Divide every polynomial in a list PLIST by its leading coefficient. "
192 (mapcar #'(lambda (x) (poly-normalize ring x)) plist))
Note: See TracBrowser for help on using the repository browser.