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/ideal.lisp@ 4411

Last change on this file since 4411 was 1841, checked in by Marek Rychlik, 10 years ago

* empty log message *

File size: 10.1 KB
RevLine 
[1201]1;;; -*- Mode: Lisp -*-
[73]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
[67]22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; Operations in ideal theory
25;;
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
[502]28(defpackage "IDEAL"
[1613]29 (:use :cl :ring :monom :order :term :polynomial :division :grobner-wrap :ring-and-order)
[531]30 (:export "POLY-DEPENDS-P"
31 "RING-INTERSECTION"
32 "ELIMINATION-IDEAL"
33 "COLON-IDEAL"
34 "COLON-IDEAL-1"
35 "IDEAL-INTERSECTION"
36 "POLY-LCM"
37 "GROBNER-EQUAL"
38 "GROBNER-SUBSETP"
39 "GROBNER-MEMBER"
40 "IDEAL-SATURATION-1"
41 "IDEAL-SATURATION"
42 "IDEAL-POLYSATURATION-1"
43 "IDEAL-POLYSATURATION"
44 ))
[502]45
46(in-package :ideal)
47
[67]48;; Does the polynomial P depend on variable K?
49(defun poly-depends-p (p k)
50 "Return T if the term polynomial P depends on variable number K."
51 (some #'(lambda (term) (term-depends-p term k)) (poly-termlist p)))
52
53(defun ring-intersection (plist k)
[1596]54 "This function assumes that polynomial list
55PLIST=(P[0],P[1],...,P[J-1]) is a Grobner basis and it calculates the
56intersection of Id({P[0],P[1],...,P[J-1]}) with the ring
57R[X[K],...,X[N-1]], i.e. it discards polynomials which depend on
58variables X[0], X[1], ..., X[K-1]."
[67]59 (dotimes (i k plist)
60 (setf plist
61 (remove-if #'(lambda (p)
62 (poly-depends-p p i))
63 plist))))
64
[1597]65(defun elimination-ideal (ring-and-order flist k
66 &optional
67 (top-reduction-only $poly_top_reduction_only)
68 (start 0))
69 "Given a list of polynomials FLIST, and an integer K, tt finds and
70returns the Groebner basis the elimination ideal of Id({FLIST})
71obtained by eliminating the first K variables. Optional argument
72TOP-REDUCTION-ONLY indicates whether to fully reduce or only
73top-reduce. Optional argument START, defaulting to 0, is used to
74indicate that the first START elements of F form a Groebner basis."
[902]75 (ring-intersection (reduced-grobner ring-and-order flist start top-reduction-only) k))
[67]76
[1380]77(defun colon-ideal (ring-and-order f g
78 &optional
79 (top-reduction-only $poly_top_reduction_only)
80 &aux
81 (ring (ro-ring ring-and-order)))
[67]82 "Returns the reduced Grobner basis of the colon ideal Id(F):Id(G),
83where F and G are two lists of polynomials. The colon ideal I:J is
84defined as the set of polynomials H such that for all polynomials W in
85J the polynomial W*H belongs to I."
[1380]86 (declare (type ring-and-order ring-and-order))
[67]87 (cond
88 ((endp g)
89 ;;Id(G) consists of 0 only so W*0=0 belongs to Id(F)
90 (if (every #'poly-zerop f)
91 (error "First ideal must be non-zero.")
[156]92 (list (make-poly-from-termlist
[67]93 (list (make-term
[1840]94 :monom (make-monom :dimension (monom-dimension (poly-lm (find-if-not #'poly-zerop f))))
95 :coeff (funcall (ring-unit ring))))))))
[67]96 ((endp (cdr g))
[1382]97 (colon-ideal-1 ring-and-order f (car g) top-reduction-only))
[67]98 (t
[1381]99 (ideal-intersection ring-and-order
[1429]100 (colon-ideal-1 ring-and-order f (car g) top-reduction-only)
[1381]101 (colon-ideal ring-and-order f (rest g) top-reduction-only)
[67]102 top-reduction-only))))
103
[1383]104(defun colon-ideal-1 (ring-and-order f g
105 &optional
[1430]106 (top-reduction-only $poly_top_reduction_only))
[67]107 "Returns the reduced Grobner basis of the colon ideal Id(F):Id({G}), where
108F is a list of polynomials and G is a polynomial."
[1427]109 (declare (type ring-and-order ring-and-order))
[1384]110 (mapcar #'(lambda (x)
111 (poly-exact-divide ring-and-order x g))
112 (ideal-intersection ring-and-order f (list g) top-reduction-only)))
[67]113
[1385]114(defun ideal-intersection (ring-and-order f g
115 &optional
[1435]116 (top-reduction-only $poly_top_reduction_only)
117 (ring (ro-ring ring-and-order)))
[1428]118 (declare (type ring-and-order ring-and-order))
[67]119 (mapcar #'poly-contract
120 (ring-intersection
121 (reduced-grobner
[902]122 ring-and-order
[994]123 (append (mapcar #'(lambda (p) (poly-extend p (make-monom :dimension 1 :initial-exponent 1))) f)
[67]124 (mapcar #'(lambda (p)
[1436]125 (poly-append (poly-extend (poly-uminus ring p)
[994]126 (make-monom :dimension 1 :initial-exponent 1))
[67]127 (poly-extend p)))
128 g))
129 0
130 top-reduction-only)
131 1)))
132
[1386]133(defun poly-lcm (ring-and-order f g &aux (ring (ro-ring ring-and-order)))
[67]134 "Return LCM (least common multiple) of two polynomials F and G.
135The polynomials must be ordered according to monomial order PRED
136and their coefficients must be compatible with the RING structure
137defined in the COEFFICIENT-RING package."
138 (cond
139 ((poly-zerop f) f)
140 ((poly-zerop g) g)
141 ((and (endp (cdr (poly-termlist f))) (endp (cdr (poly-termlist g))))
142 (let ((m (monom-lcm (poly-lm f) (poly-lm g))))
[1841]143 (make-poly-from-termlist (list (make-term :monom m
144 :coeff (funcall (ring-lcm ring) (poly-lc f) (poly-lc g)))))))
[67]145 (t
146 (multiple-value-bind (f f-cont)
147 (poly-primitive-part ring f)
148 (multiple-value-bind (g g-cont)
149 (poly-primitive-part ring g)
150 (scalar-times-poly
151 ring
152 (funcall (ring-lcm ring) f-cont g-cont)
[1387]153 (poly-primitive-part ring (car (ideal-intersection ring-and-order (list f) (list g) nil)))))))))
[67]154
155;; Do two Grobner bases yield the same ideal?
[1388]156(defun grobner-equal (ring-and-order g1 g2)
[67]157 "Returns T if two lists of polynomials G1 and G2, assumed to be Grobner bases,
158generate the same ideal, and NIL otherwise."
[1388]159 (declare (type ring-and-order ring-and-order))
160 (and (grobner-subsetp ring-and-order g1 g2) (grobner-subsetp ring-and-order g2 g1)))
[67]161
[1389]162(defun grobner-subsetp (ring-and-order g1 g2)
[67]163 "Returns T if a list of polynomials G1 generates
164an ideal contained in the ideal generated by a polynomial list G2,
165both G1 and G2 assumed to be Grobner bases. Returns NIL otherwise."
[1389]166 (declare (type ring-and-order ring-and-order))
[1390]167 (every #'(lambda (p) (grobner-member ring-and-order p g2)) g1))
[67]168
[1391]169(defun grobner-member (ring-and-order p g)
[67]170 "Returns T if a polynomial P belongs to the ideal generated by the
171polynomial list G, which is assumed to be a Grobner basis. Returns NIL otherwise."
[1391]172 (declare (type ring-and-order ring-and-order))
173 (poly-zerop (normal-form ring-and-order p g nil)))
[67]174
175;; Calculate F : p^inf
[1470]176(defun ideal-saturation-1 (ring-and-order f p
[1392]177 &optional
[1470]178 (start 0)
[1471]179 (top-reduction-only $poly_top_reduction_only)
180 &aux
181 (ring (ro-ring ring-and-order)))
[67]182 "Returns the reduced Grobner basis of the saturation of the ideal
183generated by a polynomial list F in the ideal generated by a single
184polynomial P. The saturation ideal is defined as the set of
[1510]185polynomials H such for some natural number n (* (EXPT P N) H) is in
186the ideal spanned by F. Geometrically, over an algebraically closed
187field, this is the set of polynomials in the ideal generated by F
188which do not identically vanish on the variety of P."
[1392]189 (declare (type ring-and-order ring-and-order))
[67]190 (mapcar
191 #'poly-contract
[1528]192 (ring-intersection
[67]193 (reduced-grobner
[902]194 ring-and-order
[1471]195 (saturation-extension-1 ring f p)
[67]196 start top-reduction-only)
[1528]197 1)))
[67]198
199
200;; Calculate F : p1^inf : p2^inf : ... : ps^inf
[1491]201(defun ideal-polysaturation-1 (ring-and-order f plist
[1395]202 &optional
[1491]203 (start 0)
[1395]204 (top-reduction-only $poly_top_reduction_only))
[67]205 "Returns the reduced Grobner basis of the ideal obtained by a
206sequence of successive saturations in the polynomials
207of the polynomial list PLIST of the ideal generated by the
208polynomial list F."
209 (cond
[1519]210 ((endp plist)
211 (reduced-grobner ring-and-order f start top-reduction-only))
212 (t (let ((g (ideal-saturation-1 ring-and-order f (car plist) start top-reduction-only)))
213 (ideal-polysaturation-1 ring-and-order g (rest plist) (length g) top-reduction-only)))))
[67]214
[1511]215(defun ideal-saturation (ring-and-order f g
216 &optional
217 (start 0)
218 (top-reduction-only $poly_top_reduction_only)
[67]219 &aux
[1588]220 (k (length g))
221 (ring (ro-ring ring-and-order)))
[67]222 "Returns the reduced Grobner basis of the saturation of the ideal
223generated by a polynomial list F in the ideal generated a polynomial
224list G. The saturation ideal is defined as the set of polynomials H
225such for some natural number n and some P in the ideal generated by G
226the polynomial P**N * H is in the ideal spanned by F. Geometrically,
227over an algebraically closed field, this is the set of polynomials in
228the ideal generated by F which do not identically vanish on the
229variety of G."
[1590]230 (declare (type ring-and-order ring-and-order))
[67]231 (mapcar
232 #'(lambda (q) (poly-contract q k))
233 (ring-intersection
[903]234 (reduced-grobner ring-and-order
[1588]235 (polysaturation-extension ring f g)
[67]236 start
237 top-reduction-only)
238 k)))
239
[1512]240(defun ideal-polysaturation (ring-and-order f ideal-list
[1398]241 &optional
[1512]242 (start 0)
[1398]243 (top-reduction-only $poly_top_reduction_only))
[1519]244 "Returns the reduced Grobner basis of the ideal obtained by a
[67]245successive applications of IDEAL-SATURATION to F and lists of
246polynomials in the list IDEAL-LIST."
[1590]247 (declare (type ring-and-order ring-and-order))
[67]248 (cond
[1519]249 ((endp ideal-list) f)
250 (t (let ((h (ideal-saturation ring-and-order f (car ideal-list) start top-reduction-only)))
251 (ideal-polysaturation ring-and-order h (rest ideal-list) (length h) top-reduction-only)))))
Note: See TracBrowser for help on using the repository browser.