- Timestamp:
- 2016-05-31T17:52:08-07:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/division.lisp
r4050 r4051 48 48 "Returns C2*F-C1*M*G, where F and G are polynomials M is a monomial. 49 49 Assume that the leading terms will cancel." 50 (declare (type ring-and-order ring-and-order) 51 (type monom m) 50 (declare (type monom m) 52 51 (type poly f g)) 53 52 #+grobner-check(universal-zerop … … 171 170 &aux 172 171 (g (find (leading-monomial p) fl 173 :test #' monom-divisible-by-p172 :test #'divisible-by-p 174 173 :key #'leading-monomial))) 175 174 (cond … … 221 220 (normal-form-step fl f r c division-count)))) 222 221 222 (defun spoly (f g) 223 "It yields the S-polynomial of polynomials F and G." 224 (declare (type poly f g)) 225 (let* ((lcm (universal-lcm (leading-monomial f) (leading-monomial g))) 226 (mf (divide lcm (leading-monomial f))) 227 (mg (divide lcm (leading-monomial g)))) 228 (declare (type monom mf mg)) 229 (multiple-value-bind (c cf cg) 230 (universal-ezgcd (leading-coefficient f) (leading-coefficient g)) 231 (declare (ignore c)) 232 (poly-sub 233 ring 234 (scalar-times-poly ring cg (monom-times-poly mf f)) 235 (scalar-times-poly ring cf (monom-times-poly mg g)))))) 236 223 237 (defun buchberger-criterion (g) 224 238 "Returns T if G is a Grobner basis, by using the Buchberger 225 239 criterion: for every two polynomials h1 and h2 in G the S-polynomial 226 240 S(h1,h2) reduces to 0 modulo G." 227 (every #' poly-zerop228 (makelist (normal-form ring-and-order (spoly ring-and-order(elt g i) (elt g j)) g nil)241 (every #'universal-zerop 242 (makelist (normal-form (spoly (elt g i) (elt g j)) g nil) 229 243 (i 0 (- (length g) 2)) 230 244 (j (1+ i) (1- (length g)))))) 231 245 232 246 233 (defun poly-normalize ( ring p &aux (c (poly-lcp)))247 (defun poly-normalize (p &aux (c (leading-coefficient p))) 234 248 "Divide a polynomial by its leading coefficient. It assumes 235 249 that the division is possible, which may not always be the … … 237 251 is assumed to be provided by the RING structure." 238 252 (mapc #'(lambda (term) 239 (setf (term-coeff term) ( funcall (ring-div ring)(term-coeff term) c)))253 (setf (term-coeff term) (divide (term-coeff term) c))) 240 254 (poly-termlist p)) 241 255 p) 242 256 243 (defun poly-normalize-list ( ringplist)257 (defun poly-normalize-list (plist) 244 258 "Divide every polynomial in a list PLIST by its leading coefficient. " 245 (mapcar #'(lambda (x) (poly-normalize ringx)) plist))259 (mapcar #'(lambda (x) (poly-normalize x)) plist)) 246 260 247 261 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 254 268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 255 269 256 (defun grobner-test ( ring-and-orderg f)270 (defun grobner-test (g f) 257 271 "Test whether G is a Grobner basis and F is contained in G. Return T 258 272 upon success and NIL otherwise." 259 273 (debug-cgb "~&GROBNER CHECK: ") 260 274 (let (($poly_grobner_debug nil) 261 (stat1 (buchberger-criterion ring-and-orderg))275 (stat1 (buchberger-criterion g)) 262 276 (stat2 263 (every #' poly-zerop264 (makelist (normal-form ring-and-order(copy-tree (elt f i)) g nil)277 (every #'universal-zerop 278 (makelist (normal-form (copy-tree (elt f i)) g nil) 265 279 (i 0 (1- (length f))))))) 266 280 (unless stat1 (error "~&Buchberger criterion failed, not a grobner basis: ~A" g))
Note:
See TracChangeset
for help on using the changeset viewer.