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

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