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 2001


Ignore:
Timestamp:
2015-06-16T15:24:48-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/pol.lisp

    r2000 r2001  
    206206  (poly-lc (poly-eval expr nil ring order)))
    207207
    208 (defun spoly (ring-and-order f g
    209               &aux
    210                 (ring (ro-ring ring-and-order)))
    211   "It yields the S-polynomial of polynomials F and G."
    212   (declare (type ring-and-order ring-and-order) (type poly f g))
    213   (let* ((lcm (monom-lcm (poly-lm f) (poly-lm g)))
    214           (mf (monom-div lcm (poly-lm f)))
    215           (mg (monom-div lcm (poly-lm g))))
    216     (declare (type monom mf mg))
    217     (multiple-value-bind (c cf cg)
    218         (funcall (ring-ezgcd ring) (poly-lc f) (poly-lc g))
    219       (declare (ignore c))
    220       (poly-sub
    221        ring-and-order
    222        (scalar-times-poly ring cg (monom-times-poly mf f))
    223        (scalar-times-poly ring cf (monom-times-poly mg g))))))
    224 
    225 
    226 (defun poly-primitive-part (ring p)
    227   "Divide polynomial P with integer coefficients by gcd of its
    228 coefficients and return the result."
    229   (declare (type ring ring) (type poly p))
    230   (if (poly-zerop p)
    231       (values p 1)
    232     (let ((c (poly-content ring p)))
    233       (values (make-poly-from-termlist
    234                (mapcar
    235                 #'(lambda (x)
    236                     (make-term :monom (term-monom x)
    237                                :coeff (funcall (ring-div ring) (term-coeff x) c)))
    238                 (poly-termlist p))
    239                (poly-sugar p))
    240               c))))
    241 
    242 (defun poly-content (ring p)
    243   "Greatest common divisor of the coefficients of the polynomial P. Use the RING structure
    244 to compute the greatest common divisor."
    245   (declare (type ring ring) (type poly p))
    246   (reduce (ring-gcd ring) (mapcar #'term-coeff (rest (poly-termlist p))) :initial-value (poly-lc p)))
    247 
    248 (defun read-infix-form (&key (stream t))
    249   "Parser of infix expressions with integer/rational coefficients
    250 The parser will recognize two kinds of polynomial expressions:
    251 
    252 - polynomials in fully expanded forms with coefficients
    253   written in front of symbolic expressions; constants can be optionally
    254   enclosed in (); for example, the infix form
    255         X^2-Y^2+(-4/3)*U^2*W^3-5
    256   parses to
    257         (+ (- (EXPT X 2) (EXPT Y 2)) (* (- (/ 4 3)) (EXPT U 2) (EXPT W 3)) (- 5))
    258 
    259 - lists of polynomials; for example
    260         [X-Y, X^2+3*Z]         
    261   parses to
    262           (:[ (- X Y) (+ (EXPT X 2) (* 3 Z)))
    263   where the first symbol [ marks a list of polynomials.
    264 
    265 -other infix expressions, for example
    266         [(X-Y)*(X+Y)/Z,(X+1)^2]
    267 parses to:
    268         (:[ (/ (* (- X Y) (+ X Y)) Z) (EXPT (+ X 1) 2))
    269 Currently this function is implemented using M. Kantrowitz's INFIX package."
    270   (read-from-string
    271    (concatenate 'string
    272      "#I("
    273      (with-output-to-string (s)
    274        (loop
    275          (multiple-value-bind (line eof)
    276              (read-line stream t)
    277            (format s "~A" line)
    278            (when eof (return)))))
    279      ")")))
     208
    280209       
    281 (defun read-poly (vars &key
    282                          (stream t)
    283                          (ring +ring-of-integers+)
    284                          (order #'lex>))
    285   "Reads an expression in prefix form from a stream STREAM.
    286 The expression read from the strem should represent a polynomial or a
    287 list of polynomials in variables VARS, over the ring RING.  The
    288 polynomial or list of polynomials is returned, with terms in each
    289 polynomial ordered according to monomial order ORDER."
    290   (poly-eval (read-infix-form :stream stream) vars ring order))
    291 
    292 (defun string->poly (str vars
    293                      &optional
    294                        (ring +ring-of-integers+)
    295                        (order #'lex>))
    296   "Converts a string STR to a polynomial in variables VARS."
    297   (with-input-from-string (s str)
    298     (read-poly vars :stream s :ring ring :order order)))
    299 
    300 (defun poly->alist (p)
    301   "Convert a polynomial P to an association list. Thus, the format of the
    302 returned value is  ((MONOM[0] . COEFF[0]) (MONOM[1] . COEFF[1]) ...), where
    303 MONOM[I] is a list of exponents in the monomial and COEFF[I] is the
    304 corresponding coefficient in the ring."
    305   (cond
    306     ((poly-p p)
    307      (mapcar #'term->cons (poly-termlist p)))
    308     ((and (consp p) (eq (car p) :[))
    309      (cons :[ (mapcar #'poly->alist (cdr p))))))
    310 
    311 (defun string->alist (str vars
    312                      &optional
    313                        (ring +ring-of-integers+)
    314                        (order #'lex>))
    315   "Convert a string STR representing a polynomial or polynomial list to
    316 an association list (... (MONOM . COEFF) ...)."
    317   (poly->alist (string->poly str vars ring order)))
    318 
    319 (defun poly-equal-no-sugar-p (p q)
    320   "Compare polynomials for equality, ignoring sugar."
    321   (declare (type poly p q))
    322   (equalp (poly-termlist p) (poly-termlist q)))
    323 
    324 (defun poly-set-equal-no-sugar-p (p q)
    325   "Compare polynomial sets P and Q for equality, ignoring sugar."
    326   (null (set-exclusive-or  p q :test #'poly-equal-no-sugar-p )))
    327 
    328 (defun poly-list-equal-no-sugar-p (p q)
    329   "Compare polynomial lists P and Q for equality, ignoring sugar."
    330   (every #'poly-equal-no-sugar-p p q))
    331 
    332 
     210
Note: See TracChangeset for help on using the changeset viewer.