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@ 1596

Last change on this file since 1596 was 1596, checked in by Marek Rychlik, 9 years ago

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