Changeset 69 for branches

Timestamp:

2015-06-05T11:30:24-07:00 (10 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/grobner.lisp (modified) (2 diffs)

branches/f4grobner/grobner.lisp

@@ -373 +373 @@
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Operations in ideal theory
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Does the term depend on variable K?
-(defun term-depends-p (term k)
-  "Return T if the term TERM depends on variable number K."
-  (monom-depends-p (term-monom term) k))
-
-;; Does the polynomial P depend on variable K?
-(defun poly-depends-p (p k)
-  "Return T if the term polynomial P depends on variable number K."
-  (some #'(lambda (term) (term-depends-p term k)) (poly-termlist p)))
-
-(defun ring-intersection (plist k)
-  "This function assumes that polynomial list PLIST is a Grobner basis
-and it calculates the intersection with the ring R[x[k+1],...,x[n]], i.e.
-it discards polynomials which depend on variables x[0], x[1], ..., x[k]."
-  (dotimes (i k plist)
-    (setf plist
-          (remove-if #'(lambda (p)
-                         (poly-depends-p p i))
-                     plist))))
-
-(defun elimination-ideal (ring flist k
-                          &optional (top-reduction-only $poly_top_reduction_only) (start 0)
-                          &aux (*monomial-order*
-                                (or *elimination-order*
-                                    (elimination-order k))))
-  (ring-intersection (reduced-grobner ring flist start top-reduction-only) k))
-
-(defun colon-ideal (ring f g &optional (top-reduction-only $poly_top_reduction_only))
-  "Returns the reduced Grobner basis of the colon ideal Id(F):Id(G),
-where F and G are two lists of polynomials. The colon ideal I:J is
-defined as the set of polynomials H such that for all polynomials W in
-J the polynomial W*H belongs to I."
-  (cond
-    ((endp g)
-     ;;Id(G) consists of 0 only so W*0=0 belongs to Id(F)
-     (if (every #'poly-zerop f)
-         (error "First ideal must be non-zero.")
-         (list (make-poly
-                (list (make-term
-                       (make-monom (monom-dimension (poly-lm (find-if-not #'poly-zerop f)))
-                                   :initial-element 0)
-                       (funcall (ring-unit ring))))))))
-    ((endp (cdr g))
-     (colon-ideal-1 ring f (car g) top-reduction-only))
-    (t
-     (ideal-intersection ring
-                         (colon-ideal-1 ring f (car g) top-reduction-only)
-                         (colon-ideal ring f (rest g) top-reduction-only)
-                         top-reduction-only))))
-
-(defun colon-ideal-1 (ring f g &optional (top-reduction-only $poly_top_reduction_only))
-  "Returns the reduced Grobner basis of the colon ideal Id(F):Id({G}), where
-F is a list of polynomials and G is a polynomial."
-  (mapcar #'(lambda (x) (poly-exact-divide ring x g)) (ideal-intersection ring f (list g) top-reduction-only)))
-
-
-(defun ideal-intersection (ring f g &optional (top-reduction-only $poly_top_reduction_only)
-                           &aux (*monomial-order* (or *elimination-order*
-                                                      #'elimination-order-1)))
-  (mapcar #'poly-contract
-          (ring-intersection
-           (reduced-grobner
-            ring
-            (append (mapcar #'(lambda (p) (poly-extend p (make-monom 1 :initial-element 1))) f)
-                    (mapcar #'(lambda (p)
-                                (poly-append (poly-extend (poly-uminus ring p)
-                                                          (make-monom 1 :initial-element 1))
-                                             (poly-extend p)))
-                            g))
-            0
-            top-reduction-only)
-           1)))
-
-(defun poly-lcm (ring f g)
-  "Return LCM (least common multiple) of two polynomials F and G.
-The polynomials must be ordered according to monomial order PRED
-and their coefficients must be compatible with the RING structure
-defined in the COEFFICIENT-RING package."
-  (cond
-    ((poly-zerop f) f)
-    ((poly-zerop g) g)
-    ((and (endp (cdr (poly-termlist f))) (endp (cdr (poly-termlist g))))
-     (let ((m (monom-lcm (poly-lm f) (poly-lm g))))
-       (make-poly-from-termlist (list (make-term m (funcall (ring-lcm ring) (poly-lc f) (poly-lc g)))))))
-    (t
-     (multiple-value-bind (f f-cont)
-         (poly-primitive-part ring f)
-       (multiple-value-bind (g g-cont)
-           (poly-primitive-part ring g)
-         (scalar-times-poly
-          ring
-          (funcall (ring-lcm ring) f-cont g-cont)
-          (poly-primitive-part ring (car (ideal-intersection ring (list f) (list g) nil)))))))))
-
-;; Do two Grobner bases yield the same ideal?
-(defun grobner-equal (ring g1 g2)
-  "Returns T if two lists of polynomials G1 and G2, assumed to be Grobner bases,
-generate  the same ideal, and NIL otherwise."
-  (and (grobner-subsetp ring g1 g2) (grobner-subsetp ring g2 g1)))
-
-(defun grobner-subsetp (ring g1 g2)
-  "Returns T if a list of polynomials G1 generates
-an ideal contained in the ideal generated by a polynomial list G2,
-both G1 and G2 assumed to be Grobner bases. Returns NIL otherwise."
-  (every #'(lambda (p) (grobner-member ring p g2)) g1))
-
-(defun grobner-member (ring p g)
-  "Returns T if a polynomial P belongs to the ideal generated by the
-polynomial list G, which is assumed to be a Grobner basis. Returns NIL otherwise."
-  (poly-zerop (normal-form ring p g nil)))
-
-;; Calculate F : p^inf
-(defun ideal-saturation-1 (ring f p start &optional (top-reduction-only $poly_top_reduction_only)
-                           &aux (*monomial-order* (or *elimination-order*
-                                                      #'elimination-order-1)))
-  "Returns the reduced Grobner basis of the saturation of the ideal
-generated by a polynomial list F in the ideal generated by a single
-polynomial P. The saturation ideal is defined as the set of
-polynomials H such for some natural number n (* (EXPT P N) H) is in the ideal
-F. Geometrically, over an algebraically closed field, this is the set
-of polynomials in the ideal generated by F which do not identically
-vanish on the variety of P."
-  (mapcar
-   #'poly-contract
-   (ring-intersection
-    (reduced-grobner
-     ring
-     (saturation-extension-1 ring f p)
-     start top-reduction-only)
-    1)))
-
-
-
-;; Calculate F : p1^inf : p2^inf : ... : ps^inf
-(defun ideal-polysaturation-1 (ring f plist start &optional (top-reduction-only $poly_top_reduction_only))
-  "Returns the reduced Grobner basis of the ideal obtained by a
-sequence of successive saturations in the polynomials
-of the polynomial list PLIST of the ideal generated by the
-polynomial list F."
-  (cond
-   ((endp plist) (reduced-grobner ring f start top-reduction-only))
-   (t (let ((g (ideal-saturation-1 ring f (car plist) start top-reduction-only)))
-        (ideal-polysaturation-1 ring g (rest plist) (length g) top-reduction-only)))))
-
-(defun ideal-saturation (ring f g start &optional (top-reduction-only $poly_top_reduction_only)
-                         &aux
-                         (k (length g))
-                         (*monomial-order* (or *elimination-order*
-                                               (elimination-order k))))
-  "Returns the reduced Grobner basis of the saturation of the ideal
-generated by a polynomial list F in the ideal generated a polynomial
-list G. The saturation ideal is defined as the set of polynomials H
-such for some natural number n and some P in the ideal generated by G
-the polynomial P**N * H is in the ideal spanned by F.  Geometrically,
-over an algebraically closed field, this is the set of polynomials in
-the ideal generated by F which do not identically vanish on the
-variety of G."
-  (mapcar
-   #'(lambda (q) (poly-contract q k))
-   (ring-intersection
-    (reduced-grobner ring
-                     (polysaturation-extension ring f g)
-                     start
-                     top-reduction-only)
-    k)))
-
-(defun ideal-polysaturation (ring f ideal-list start &optional (top-reduction-only $poly_top_reduction_only))
-    "Returns the reduced Grobner basis of the ideal obtained by a
-successive applications of IDEAL-SATURATION to F and lists of
-polynomials in the list IDEAL-LIST."
-  (cond
-   ((endp ideal-list) f)
-   (t (let ((h (ideal-saturation ring f (car ideal-list) start top-reduction-only)))
-        (ideal-polysaturation ring h (rest ideal-list) (length h) top-reduction-only)))))
-
-
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -640 +458 @@
   "The ring of coefficients, over which all polynomials 
 are assumed to be defined.")
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Maxima expression parsing
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun equal-test-p (expr1 expr2)
-  (alike1 expr1 expr2))
-
-(defun coerce-maxima-list (expr)
-  "convert a maxima list to lisp list."
-  (cond
-   ((and (consp (car expr)) (eql (caar expr) 'mlist)) (cdr expr))
-   (t expr)))
-
-(defun free-of-vars (expr vars) (apply #'$freeof `(,@vars ,expr)))
-
-(defun parse-poly (expr vars &aux (vars (coerce-maxima-list vars)))
-  "Convert a maxima polynomial expression EXPR in variables VARS to internal form."
-  (labels ((parse (arg) (parse-poly arg vars))
-           (parse-list (args) (mapcar #'parse args)))
-    (cond
-     ((eql expr 0) (make-poly-zero))
-     ((member expr vars :test #'equal-test-p)
-      (let ((pos (position expr vars :test #'equal-test-p)))
-        (make-variable *maxima-ring* (length vars) pos)))
-     ((free-of-vars expr vars)
-      ;;This means that variable-free CRE and Poisson forms will be converted
-      ;;to coefficients intact
-      (coerce-coeff *maxima-ring* expr vars))
-     (t
-      (case (caar expr)
-        (mplus (reduce #'(lambda (x y) (poly-add *maxima-ring* x y)) (parse-list (cdr expr))))
-        (mminus (poly-uminus *maxima-ring* (parse (cadr expr))))
-        (mtimes
-         (if (endp (cddr expr))         ;unary
-             (parse (cdr expr))
-           (reduce #'(lambda (p q) (poly-mul *maxima-ring* p q)) (parse-list (cdr expr)))))
-        (mexpt
-         (cond
-          ((member (cadr expr) vars :test #'equal-test-p)
-           ;;Special handling of (expt var pow)
-           (let ((pos (position (cadr expr) vars :test #'equal-test-p)))
-             (make-variable *maxima-ring* (length vars) pos (caddr expr))))
-          ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
-           ;; Negative power means division in coefficient ring
-           ;; Non-integer power means non-polynomial coefficient
-           (mtell "~%Warning: Expression ~%~M~%contains power which is not a positive integer. Parsing as coefficient.~%"
-                  expr)
-           (coerce-coeff *maxima-ring* expr vars))
-          (t (poly-expt *maxima-ring* (parse (cadr expr)) (caddr expr)))))
-        (mrat (parse ($ratdisrep expr)))
-        (mpois (parse ($outofpois expr)))
-        (otherwise
-         (coerce-coeff *maxima-ring* expr vars)))))))
-
-(defun parse-poly-list (expr vars)
-  (case (caar expr)
-    (mlist (mapcar #'(lambda (p) (parse-poly p vars)) (cdr expr)))
-    (t (merror "Expression ~M is not a list of polynomials in variables ~M."
-               expr vars))))
-(defun parse-poly-list-list (poly-list-list vars)
-  (mapcar #'(lambda (g) (parse-poly-list g vars)) (coerce-maxima-list poly-list-list)))
-