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.

Changeset 4051 for branches/f4grobner


Ignore:
Timestamp:
2016-05-31T17:52:08-07:00 (8 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/division.lisp

    r4050 r4051  
    4848  "Returns C2*F-C1*M*G, where F and G are polynomials M is a monomial.
    4949Assume that the leading terms will cancel."
    50   (declare (type ring-and-order ring-and-order)
    51            (type monom m)
     50  (declare (type monom m)
    5251           (type poly f g))
    5352  #+grobner-check(universal-zerop
     
    171170                         &aux
    172171                           (g (find (leading-monomial p) fl
    173                                     :test #'monom-divisible-by-p
     172                                    :test #'divisible-by-p
    174173                                    :key #'leading-monomial)))
    175174  (cond
     
    221220      (normal-form-step fl f r c division-count))))
    222221
     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
    223237(defun buchberger-criterion (g)
    224238  "Returns T if G is a Grobner basis, by using the Buchberger
    225239criterion: for every two polynomials h1 and h2 in G the S-polynomial
    226240S(h1,h2) reduces to 0 modulo G."
    227   (every #'poly-zerop
    228          (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)
    229243                   (i 0 (- (length g) 2))
    230244                   (j (1+ i) (1- (length g))))))
    231245
    232246
    233 (defun poly-normalize (ring p &aux (c (poly-lc p)))
     247(defun poly-normalize (p &aux (c (leading-coefficient p)))
    234248  "Divide a polynomial by its leading coefficient. It assumes
    235249that the division is possible, which may not always be the
     
    237251is assumed to be provided by the RING structure."
    238252  (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)))
    240254        (poly-termlist p))
    241255  p)
    242256
    243 (defun poly-normalize-list (ring plist)
     257(defun poly-normalize-list (plist)
    244258  "Divide every polynomial in a list PLIST by its leading coefficient. "
    245   (mapcar #'(lambda (x) (poly-normalize ring x)) plist))
     259  (mapcar #'(lambda (x) (poly-normalize x)) plist))
    246260
    247261;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    254268;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    255269
    256 (defun grobner-test (ring-and-order g f)
     270(defun grobner-test (g f)
    257271  "Test whether G is a Grobner basis and F is contained in G. Return T
    258272upon success and NIL otherwise."
    259273  (debug-cgb "~&GROBNER CHECK: ")
    260274  (let (($poly_grobner_debug nil)
    261         (stat1 (buchberger-criterion ring-and-order g))
     275        (stat1 (buchberger-criterion g))
    262276        (stat2
    263           (every #'poly-zerop
    264                  (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)
    265279                           (i 0 (1- (length f)))))))
    266280    (unless stat1 (error "~&Buchberger criterion failed, not a grobner basis: ~A" g))
Note: See TracChangeset for help on using the changeset viewer.