1 | ////////////////////////////////////////////////////////////////////////////// |
---|
2 | version="$Id: dmodapp.lib,v 1.1 2007-12-11 12:00:01 levandov Exp $"; |
---|
3 | category="Noncommutative"; |
---|
4 | info=" |
---|
5 | LIBRARY: dmodapp.lib Applications of algebraic D-modules |
---|
6 | AUTHORS: Viktor Levandovskyy, levandov@math.rwth-aachen.de |
---|
7 | @* Seminar Group (Lehrstuhl B and D fuer Mathematik, RWTH Aachen) |
---|
8 | |
---|
9 | THEORY: Given a polynomial ring R = K[x_1,...,x_n] and a polynomial F in R, |
---|
10 | @* one is interested in the R[1/F]-module of rank one, generated by F^s |
---|
11 | @* for a natural number s. |
---|
12 | |
---|
13 | GUIDE: |
---|
14 | @* - Ann F^s = I = I(F^s) = LD in D(R)[s] can be computed by SannfsBM, SannfsOT, SannfsLOT |
---|
15 | @* - global Bernstein polynomial bs resp. BS in K[s] can be computed by bernsteinBM |
---|
16 | |
---|
17 | MAIN PROCEDURES: |
---|
18 | |
---|
19 | charVariety(I); compute the characteristic variety of the ideal I |
---|
20 | |
---|
21 | SECONDARY PROCEDURES FOR D-MODULES: |
---|
22 | |
---|
23 | foo(); dummy prototype for a future procedure |
---|
24 | |
---|
25 | AUXILIARY PROCEDURES: |
---|
26 | |
---|
27 | Appell(a,b,c,d); create an ideal annihilating Appel F4 function |
---|
28 | |
---|
29 | SEE ALSO: dmod_lib, gmssing_lib |
---|
30 | "; |
---|
31 | |
---|
32 | LIB "poly.lib"; |
---|
33 | LIB "sing.lib"; |
---|
34 | LIB "primdec.lib"; |
---|
35 | LIB "dmod.lib"; // loads e.g. nctools.lib |
---|
36 | |
---|
37 | proc charVariety(ideal I) |
---|
38 | "USAGE: charVariety(I); I an ideal |
---|
39 | RETURN: ring |
---|
40 | PURPOSE: compute the D-module structure of basering[1/f]*f^s with the algorithm given in S and with the Groebner basis engine given in 'eng' |
---|
41 | ASSUME: the ground ring is the Weyl algebra with x's before d's |
---|
42 | NOTE: activate the output ring with the @code{setring} command. |
---|
43 | @* In the output (in a commutative ring): |
---|
44 | @* - the ideal CV is the characteristic variety char(I) |
---|
45 | @* If @code{printlevel}=1, progress debug messages will be printed, |
---|
46 | @* if @code{printlevel}>=2, all the debug messages will be printed. |
---|
47 | EXAMPLE: example annfs; shows examples |
---|
48 | " |
---|
49 | { |
---|
50 | // 1. introduce the weights 0, 1 |
---|
51 | def save = basering; |
---|
52 | list LL = ringlist(save); |
---|
53 | list L; |
---|
54 | int i; |
---|
55 | for(i=1;i<=4;i++) |
---|
56 | { |
---|
57 | L[i] = LL[i]; |
---|
58 | } |
---|
59 | list OLD = L[3]; |
---|
60 | list NEW; list tmp; |
---|
61 | tmp[1] = "a"; // string |
---|
62 | intvec iv; |
---|
63 | int N = nvars(basering); N = N div 2; |
---|
64 | for(i=N+1; i<=2*N; i++) |
---|
65 | { |
---|
66 | iv[i] = 1; |
---|
67 | } |
---|
68 | tmp[2] = iv; |
---|
69 | NEW[1] = tmp; |
---|
70 | for (i=2; i<=size(OLD);i++) |
---|
71 | { |
---|
72 | NEW[i] = OLD[i-1]; |
---|
73 | } |
---|
74 | L[3] = NEW; |
---|
75 | def @U = ring(L); |
---|
76 | // 2. create the commutative ring |
---|
77 | setring save; |
---|
78 | list CL; |
---|
79 | for(i=1;i<=4;i++) |
---|
80 | { |
---|
81 | CL[i] = L[i]; |
---|
82 | } |
---|
83 | CL[3] = OLD; |
---|
84 | def @CU = ring(CL); |
---|
85 | // comm ring is ready |
---|
86 | setring @U; |
---|
87 | // 2. compute Groebner basis |
---|
88 | ideal I = imap(save,I); |
---|
89 | // I = groebner(I); |
---|
90 | I = slimgb(I); |
---|
91 | setring @CU; |
---|
92 | ideal CV = imap(@U,I); |
---|
93 | // CV = groebner(CV); // cosmetics |
---|
94 | CV = slimgb(CV); |
---|
95 | export CV; |
---|
96 | kill @U; |
---|
97 | return(@CU); |
---|
98 | } |
---|
99 | example |
---|
100 | { |
---|
101 | "EXAMPLE:"; echo = 2; |
---|
102 | ring r = 0,(x,y),Dp; |
---|
103 | poly F = x3-y2; |
---|
104 | printlevel = 0; |
---|
105 | def A = annfs(F); |
---|
106 | setring A; // Weyl algebra |
---|
107 | LD; // the ideal |
---|
108 | def CA = charVariety(LD); |
---|
109 | setring CA; |
---|
110 | CV; |
---|
111 | dim(CV); |
---|
112 | } |
---|
113 | |
---|
114 | proc charInfo(ideal I) |
---|
115 | "USAGE: charInfo(I); I an ideal |
---|
116 | RETURN: ring |
---|
117 | PURPOSE: compute the characteristic information for I |
---|
118 | ASSUME: the ground ring is the Weyl algebra with x's before d's |
---|
119 | NOTE: activate the output ring with the @code{setring} command. |
---|
120 | @* In the output (in a commutative ring): |
---|
121 | @* - the ideal CV is the characteristic variety char(I) |
---|
122 | @* - the ideal SL is the singular locus of char(I) |
---|
123 | @* - the list PD is the primary decomposition of char(I) |
---|
124 | @* If @code{printlevel}=1, progress debug messages will be printed, |
---|
125 | @* if @code{printlevel}>=2, all the debug messages will be printed. |
---|
126 | EXAMPLE: example annfs; shows examples |
---|
127 | " |
---|
128 | { |
---|
129 | def save = basering; |
---|
130 | def @A = charVariety(I); |
---|
131 | setring @A; |
---|
132 | // run slocus |
---|
133 | // run primdec |
---|
134 | } |
---|
135 | |
---|
136 | |
---|
137 | proc Appel(number a,b,c,d) |
---|
138 | { |
---|
139 | ring @r = (0,a,b,c,d),(x,y,Dx,Dy),(a(0,0,1,1),dp); |
---|
140 | matrix @D[4][4]; |
---|
141 | @D[1,3]=1; @D[2,4]=1; |
---|
142 | def @S = nc_algebra(1,@D); |
---|
143 | setring @S; |
---|
144 | ideal IAppel = |
---|
145 | Dx*(x*Dx+c-1) - x*(x*Dx+y*Dy+a)*(x*Dx+y*Dy+b), |
---|
146 | Dy*(y*Dy+d-1) - y*(x*Dx+y*Dy+a)*(x*Dx+y*Dy+b); |
---|
147 | export IAppel; |
---|
148 | kill @r; |
---|
149 | return(@S); |
---|
150 | } |
---|
151 | example |
---|
152 | { |
---|
153 | "EXAMPLE:"; echo = 2; |
---|
154 | ring r = 0,x,dp; |
---|
155 | def Ap = Appel(1,2,3,4); |
---|
156 | setring Ap; |
---|
157 | IAppel; |
---|
158 | } |
---|
159 | |
---|
160 | proc isFsat(ideal I, poly F) |
---|
161 | { |
---|
162 | /* checks whether I is F-saturated, that is Ke (D -F-> D/I) is 0 */ |
---|
163 | /* works in any algebra */ |
---|
164 | /* for simplicity : later check attrib */ |
---|
165 | /* returns -1 if true */ |
---|
166 | I = groebner(I); |
---|
167 | matrix @M = matrix(I); |
---|
168 | matrix @F[1][1] = F; |
---|
169 | module S = modulo(@F,@M); |
---|
170 | S = NF(S,I); |
---|
171 | S = groebner(S); |
---|
172 | return( (gkdim(S) == -1) ); |
---|
173 | } |
---|
174 | example |
---|
175 | { |
---|
176 | "EXAMPLE:"; echo = 2; |
---|
177 | ring r = 0,(x,y),dp; |
---|
178 | poly G = x*(x-y)*y; |
---|
179 | def A = annfs(G); |
---|
180 | setring A; |
---|
181 | poly F = x3-y2; |
---|
182 | isFsat(LD,F); |
---|
183 | ideal J = LD*F; |
---|
184 | isFsat(J,F); |
---|
185 | } |
---|
186 | |
---|
187 | proc DLoc(ideal I, poly F) |
---|
188 | "USAGE: DLoc(I, F); I an ideal, F a poly |
---|
189 | RETURN: nothing (exports objects instead) |
---|
190 | ASSUME: the basering is a Weyl algebra |
---|
191 | PURPOSE: compute the presentation of the localization of D/I w.r.t. f^s |
---|
192 | NOTE: In the basering, the following objects are exported: |
---|
193 | @* - the ideal LD0 (which is a Groebner basis) is the presentation of the localization |
---|
194 | @* - the ideal BS contains the roots with multiplicities of a Bernstein polynomial of D/I w.r.t f. |
---|
195 | @* If printlevel=1, progress debug messages will be printed, |
---|
196 | @* if printlevel>=2, all the debug messages will be printed. |
---|
197 | EXAMPLE: example DLoc; shows examples |
---|
198 | " |
---|
199 | { |
---|
200 | /* runs SDLoc and DLoc0 */ |
---|
201 | /* assume: run from Weyl algebra */ |
---|
202 | int old_printlevel = printlevel; |
---|
203 | printlevel=printlevel+1; |
---|
204 | def @R = basering; |
---|
205 | def @R2 = SDLoc(I,F); |
---|
206 | setring @R2; |
---|
207 | poly F = imap(@R,F); |
---|
208 | def @R3 = DLoc0(LD,F); |
---|
209 | setring @R3; |
---|
210 | ideal bs = BS[1]; |
---|
211 | intvec m = BS[2]; |
---|
212 | setring @R; |
---|
213 | ideal LD0 = imap(@R3,LD0); |
---|
214 | export LD0; |
---|
215 | ideal bs = imap(@R3,bs); |
---|
216 | list BS; BS[1] = bs; BS[2] = m; |
---|
217 | export BS; |
---|
218 | kill @R3; |
---|
219 | printlevel = old_printlevel; |
---|
220 | } |
---|
221 | example; |
---|
222 | { |
---|
223 | "EXAMPLE:"; echo = 2; |
---|
224 | ring r = 0,(x,y,Dx,Dy),dp; |
---|
225 | def R = Weyl(); setring R; |
---|
226 | poly F = x2-y3; |
---|
227 | ideal I = (y^3 - x^2)*Dx - 2*x, (y^3 - x^2)*Dy + 3*y^2; // I = Dx*F, Dy*F; |
---|
228 | DLoc(I, x2-y3); |
---|
229 | LD0; |
---|
230 | BS; |
---|
231 | } |
---|
232 | |
---|
233 | |
---|
234 | proc DLoc0(ideal I, poly F) |
---|
235 | "USAGE: DLoc0(I, F); I an ideal, F a poly |
---|
236 | RETURN: ring |
---|
237 | PURPOSE: compute the presentation of the localization of D/I w.r.t. f^s, where D is a Weyl Algebra, based on the output of procedure SDLoc |
---|
238 | ASSUME: the basering is similar to the output ring of SDLoc procedure |
---|
239 | NOTE: activate this ring with the @code{setring} command. In this ring, |
---|
240 | @* - the ideal LD0 (which is a Groebner basis) is the presentation of the localization |
---|
241 | @* - the ideal BS contains the roots with multiplicities of a Bernstein polynomial of D/I w.r.t f. |
---|
242 | @* If printlevel=1, progress debug messages will be printed, |
---|
243 | @* if printlevel>=2, all the debug messages will be printed. |
---|
244 | EXAMPLE: example DLoc0; shows examples |
---|
245 | " |
---|
246 | { |
---|
247 | /* assume: to be run in the output ring of SDLoc */ |
---|
248 | /* todo: add F, eliminate vars*Dvars, factorize BS */ |
---|
249 | /* analogue to annfs0 */ |
---|
250 | def @R2 = basering; |
---|
251 | // we're in D_n[s], where the elim ord for s is set |
---|
252 | ideal J = NF(I,std(F)); |
---|
253 | // make leadcoeffs positive |
---|
254 | int i; |
---|
255 | for (i=1; i<= ncols(J); i++) |
---|
256 | { |
---|
257 | if (leadcoef(J[i]) <0 ) |
---|
258 | { |
---|
259 | J[i] = -J[i]; |
---|
260 | } |
---|
261 | } |
---|
262 | J = J,F; |
---|
263 | ideal M = groebner(J); |
---|
264 | int Nnew = nvars(@R2); |
---|
265 | ideal K2 = nselect(M,1,Nnew-1); |
---|
266 | int ppl = printlevel-voice+2; |
---|
267 | dbprint(ppl,"// -1-1- _x,_Dx are eliminated in basering"); |
---|
268 | dbprint(ppl-1, K2); |
---|
269 | // the ring @R3 and the search for minimal negative int s |
---|
270 | ring @R3 = 0,s,dp; |
---|
271 | dbprint(ppl,"// -2-1- the ring @R3 = K[s] is ready"); |
---|
272 | ideal K3 = imap(@R2,K2); |
---|
273 | poly p = K3[1]; |
---|
274 | dbprint(ppl,"// -2-2- attempt the factorization"); |
---|
275 | list PP = factorize(p); //with constants and multiplicities |
---|
276 | ideal bs; intvec m; //the Bernstein polynomial is monic, so we are not interested in constants |
---|
277 | for (i=2; i<= size(PP[1]); i++) //we delete P[1][1] and P[2][1] |
---|
278 | { |
---|
279 | bs[i-1] = PP[1][i]; |
---|
280 | m[i-1] = PP[2][i]; |
---|
281 | } |
---|
282 | ideal bbs; int srat=0; int HasRatRoots = 0; |
---|
283 | int sP; |
---|
284 | for (i=1; i<= size(bs); i++) |
---|
285 | { |
---|
286 | if (deg(bs[i]) == 1) |
---|
287 | { |
---|
288 | bbs = bbs,bs[i]; |
---|
289 | } |
---|
290 | } |
---|
291 | if (size(bbs)==0) |
---|
292 | { |
---|
293 | dbprint(ppl-1,"// -2-3- factorization: no rational roots"); |
---|
294 | // HasRatRoots = 0; |
---|
295 | HasRatRoots = 1; // s0 = -1 then |
---|
296 | sP = -1; |
---|
297 | // todo: return ideal with no subst and a b-function unfactorized |
---|
298 | } |
---|
299 | else |
---|
300 | { |
---|
301 | // exist rational roots |
---|
302 | dbprint(ppl-1,"// -2-3- factorization: rational roots found"); |
---|
303 | HasRatRoots = 1; |
---|
304 | // dbprint(ppl-1,bbs); |
---|
305 | bbs = bbs[2..ncols(bbs)]; |
---|
306 | ideal P = bbs; |
---|
307 | dbprint(ppl-1,P); |
---|
308 | srat = size(bs) - size(bbs); |
---|
309 | // define minIntRoot on linear factors or find out that it doesn't exist |
---|
310 | intvec vP; |
---|
311 | number nP; |
---|
312 | P = normalize(P); // now leadcoef = 1 |
---|
313 | P = lead(P)-P; |
---|
314 | sP = size(P); |
---|
315 | int cnt = 0; |
---|
316 | for (i=1; i<=sP; i++) |
---|
317 | { |
---|
318 | nP = leadcoef(P[i]); |
---|
319 | if ( (nP - int(nP)) == 0 ) |
---|
320 | { |
---|
321 | cnt++; |
---|
322 | vP[cnt] = int(nP); |
---|
323 | } |
---|
324 | } |
---|
325 | // if ( size(vP)>=2 ) |
---|
326 | // { |
---|
327 | // vP = vP[2..size(vP)]; |
---|
328 | // } |
---|
329 | if ( size(vP)==0 ) |
---|
330 | { |
---|
331 | // no roots! |
---|
332 | dbprint(ppl,"// -2-4- no integer root, setting s0 = -1"); |
---|
333 | sP = -1; |
---|
334 | // HasRatRoots = 0; // older stuff, here we do substitution |
---|
335 | HasRatRoots = 1; |
---|
336 | } |
---|
337 | else |
---|
338 | { |
---|
339 | HasRatRoots = 1; |
---|
340 | sP = -Max(-vP); |
---|
341 | dbprint(ppl,"// -2-4- minimal integer root found"); |
---|
342 | dbprint(ppl-1, sP); |
---|
343 | // int sP = minIntRoot(bbs,1); |
---|
344 | // P = normalize(P); |
---|
345 | // bs = -subst(bs,s,0); |
---|
346 | if (sP >=0) |
---|
347 | { |
---|
348 | dbprint(ppl,"// -2-5- nonnegative root, setting s0 = -1"); |
---|
349 | sP = -1; |
---|
350 | } |
---|
351 | else |
---|
352 | { |
---|
353 | dbprint(ppl,"// -2-5- the root is negative"); |
---|
354 | } |
---|
355 | } |
---|
356 | } |
---|
357 | |
---|
358 | if (HasRatRoots) |
---|
359 | { |
---|
360 | setring @R2; |
---|
361 | K2 = subst(I,s,sP); |
---|
362 | // IF min int root exists -> |
---|
363 | // create the ordinary Weyl algebra and put the result into it, |
---|
364 | // thus creating the ring @R5 |
---|
365 | // ELSE : return the same ring with new objects |
---|
366 | // keep: N, i,j,s, tmp, RL |
---|
367 | Nnew = Nnew - 1; // former 2*N; |
---|
368 | // list RL = ringlist(save); // is defined earlier |
---|
369 | // kill Lord, tmp, iv; |
---|
370 | list L = 0; |
---|
371 | list Lord, tmp; |
---|
372 | intvec iv; |
---|
373 | list RL = ringlist(basering); |
---|
374 | L[1] = RL[1]; |
---|
375 | L[4] = RL[4]; //char, minpoly |
---|
376 | // check whether vars have admissible names -> done earlier |
---|
377 | // list Name = RL[2]M |
---|
378 | // DName is defined earlier |
---|
379 | list NName; // = RL[2]; // skip the last var 's' |
---|
380 | for (i=1; i<=Nnew; i++) |
---|
381 | { |
---|
382 | NName[i] = RL[2][i]; |
---|
383 | } |
---|
384 | L[2] = NName; |
---|
385 | // dp ordering; |
---|
386 | string s = "iv="; |
---|
387 | for (i=1; i<=Nnew; i++) |
---|
388 | { |
---|
389 | s = s+"1,"; |
---|
390 | } |
---|
391 | s[size(s)] = ";"; |
---|
392 | execute(s); |
---|
393 | tmp = 0; |
---|
394 | tmp[1] = "dp"; // string |
---|
395 | tmp[2] = iv; // intvec |
---|
396 | Lord[1] = tmp; |
---|
397 | kill s; |
---|
398 | tmp[1] = "C"; |
---|
399 | iv = 0; |
---|
400 | tmp[2] = iv; |
---|
401 | Lord[2] = tmp; |
---|
402 | tmp = 0; |
---|
403 | L[3] = Lord; |
---|
404 | // we are done with the list |
---|
405 | // Add: Plural part |
---|
406 | def @R4@ = ring(L); |
---|
407 | setring @R4@; |
---|
408 | int N = Nnew/2; |
---|
409 | matrix @D[Nnew][Nnew]; |
---|
410 | for (i=1; i<=N; i++) |
---|
411 | { |
---|
412 | @D[i,N+i]=1; |
---|
413 | } |
---|
414 | def @R4 = nc_algebra(1,@D); |
---|
415 | setring @R4; |
---|
416 | kill @R4@; |
---|
417 | dbprint(ppl,"// -3-1- the ring @R4 is ready"); |
---|
418 | dbprint(ppl-1, @R4); |
---|
419 | ideal K4 = imap(@R2,K2); |
---|
420 | option(redSB); |
---|
421 | dbprint(ppl,"// -3-2- the final cosmetic std"); |
---|
422 | K4 = groebner(K4); // std does the job too |
---|
423 | // total cleanup |
---|
424 | setring @R2; |
---|
425 | ideal bs = imap(@R3,bs); |
---|
426 | bs = -normalize(bs); // "-" for getting correct coeffs! |
---|
427 | bs = subst(bs,s,0); |
---|
428 | kill @R3; |
---|
429 | setring @R4; |
---|
430 | ideal bs = imap(@R2,bs); // only rationals are the entries |
---|
431 | list BS; BS[1] = bs; BS[2] = m; |
---|
432 | export BS; |
---|
433 | // list LBS = imap(@R3,LBS); |
---|
434 | // list BS; BS[1] = sbs; BS[2] = m; |
---|
435 | // BS; |
---|
436 | // export BS; |
---|
437 | ideal LD0 = K4; |
---|
438 | export LD0; |
---|
439 | return(@R4); |
---|
440 | } |
---|
441 | else |
---|
442 | { |
---|
443 | /* SHOULD NEVER GET THERE */ |
---|
444 | /* no rational/integer roots */ |
---|
445 | /* return objects in the copy of current ring */ |
---|
446 | setring @R2; |
---|
447 | ideal LD0 = I; |
---|
448 | poly BS = normalize(K2[1]); |
---|
449 | export LD0; |
---|
450 | export BS; |
---|
451 | return(@R2); |
---|
452 | } |
---|
453 | } |
---|
454 | example; |
---|
455 | { |
---|
456 | "EXAMPLE:"; echo = 2; |
---|
457 | ring r = 0,(x,y,Dx,Dy),dp; |
---|
458 | def R = Weyl(); setring R; |
---|
459 | poly F = x2-y3; |
---|
460 | ideal I = (y^3 - x^2)*Dx - 2*x, (y^3 - x^2)*Dy + 3*y^2; // I = Dx*F, Dy*F; |
---|
461 | def W = SDLoc(I,F); setring W; // creates ideal LD |
---|
462 | def U = DLoc0(LD, x2-y3); setring U; |
---|
463 | LD0; |
---|
464 | BS; |
---|
465 | } |
---|
466 | |
---|
467 | |
---|
468 | proc SDLoc(ideal I, poly F) |
---|
469 | "USAGE: SDLoc(I, F); I an ideal, F a poly |
---|
470 | RETURN: ring |
---|
471 | PURPOSE: compute a generic presentation of the localization of D/I w.r.t. f^s, where D is a Weyl Algebra |
---|
472 | ASSUME: the basering is a Weyl algebra |
---|
473 | NOTE: activate this ring with the @code{setring} command. In this ring, |
---|
474 | @* - the ideal LD (which is a Groebner basis) is the presentation of the localization |
---|
475 | @* If printlevel=1, progress debug messages will be printed, |
---|
476 | @* if printlevel>=2, all the debug messages will be printed. |
---|
477 | EXAMPLE: example SDLoc; shows examples |
---|
478 | " |
---|
479 | { |
---|
480 | /* analogue to Sannfs */ |
---|
481 | /* printlevel >=4 gives debug info */ |
---|
482 | /* assume: we're in the Weyl algebra D in x1,x2,...,d1,d2,... */ |
---|
483 | def save = basering; |
---|
484 | /* 1. create D <t, dt, s > as in LOT */ |
---|
485 | /* ordering: eliminate t,dt */ |
---|
486 | int ppl = printlevel-voice+2; |
---|
487 | int N = nvars(save); N = N div 2; |
---|
488 | int Nnew = 2*N + 3; // t,Dt,s |
---|
489 | int i,j; |
---|
490 | string s; |
---|
491 | list RL = ringlist(save); |
---|
492 | list L, Lord; |
---|
493 | list tmp; |
---|
494 | intvec iv; |
---|
495 | L[1] = RL[1]; // char |
---|
496 | L[4] = RL[4]; // char, minpoly |
---|
497 | // check whether vars have admissible names |
---|
498 | list Name = RL[2]; |
---|
499 | list RName; |
---|
500 | RName[1] = "@t"; |
---|
501 | RName[2] = "@Dt"; |
---|
502 | RName[3] = "s"; |
---|
503 | for(i=1;i<=N;i++) |
---|
504 | { |
---|
505 | for(j=1; j<=size(RName);j++) |
---|
506 | { |
---|
507 | if (Name[i] == RName[j]) |
---|
508 | { |
---|
509 | ERROR("Variable names should not include @t,@Dt,s"); |
---|
510 | } |
---|
511 | } |
---|
512 | } |
---|
513 | // now, create the names for new vars |
---|
514 | tmp = 0; |
---|
515 | tmp[1] = "@t"; |
---|
516 | tmp[2] = "@Dt"; |
---|
517 | list SName ; SName[1] = "s"; |
---|
518 | list NName = tmp + Name + SName; |
---|
519 | L[2] = NName; |
---|
520 | tmp = 0; |
---|
521 | kill NName; |
---|
522 | // block ord (a(1,1),dp); |
---|
523 | tmp[1] = "a"; // string |
---|
524 | iv = 1,1; |
---|
525 | tmp[2] = iv; //intvec |
---|
526 | Lord[1] = tmp; |
---|
527 | // continue with dp 1,1,1,1... |
---|
528 | tmp[1] = "dp"; // string |
---|
529 | s = "iv="; |
---|
530 | for(i=1;i<=Nnew;i++) |
---|
531 | { |
---|
532 | s = s+"1,"; |
---|
533 | } |
---|
534 | s[size(s)]= ";"; |
---|
535 | execute(s); |
---|
536 | tmp[2] = iv; |
---|
537 | Lord[2] = tmp; |
---|
538 | tmp[1] = "C"; |
---|
539 | iv = 0; |
---|
540 | tmp[2] = iv; |
---|
541 | Lord[3] = tmp; |
---|
542 | tmp = 0; |
---|
543 | L[3] = Lord; |
---|
544 | // we are done with the list |
---|
545 | def @R@ = ring(L); |
---|
546 | setring @R@; |
---|
547 | matrix @D[Nnew][Nnew]; |
---|
548 | @D[1,2]=1; |
---|
549 | for(i=1; i<=N; i++) |
---|
550 | { |
---|
551 | @D[2+i,N+2+i]=1; |
---|
552 | } |
---|
553 | // ADD [s,t]=-t, [s,Dt]=Dt |
---|
554 | @D[1,Nnew] = -var(1); |
---|
555 | @D[2,Nnew] = var(2); |
---|
556 | def @R = nc_algebra(1,@D); |
---|
557 | setring @R; |
---|
558 | kill @R@; |
---|
559 | dbprint(ppl,"// -1-1- the ring @R(t,Dt,_x,_Dx,s) is ready"); |
---|
560 | dbprint(ppl-1, @R); |
---|
561 | poly F = imap(save,F); |
---|
562 | ideal I = imap(save,I); |
---|
563 | dbprint(ppl-1, "the ideal after map:"); |
---|
564 | dbprint(ppl-1, I); |
---|
565 | poly p = 0; |
---|
566 | for(i=1; i<=N; i++) |
---|
567 | { |
---|
568 | p = diff(F,var(2+i))*@Dt + var(2+N+i); |
---|
569 | dbprint(ppl-1, p); |
---|
570 | I = subst(I,var(2+N+i),p); |
---|
571 | dbprint(ppl-1, var(2+N+i)); |
---|
572 | p = 0; |
---|
573 | } |
---|
574 | I = I, @t - F; |
---|
575 | // t*Dt + s +1 reduced with t-f gives f*Dt + s |
---|
576 | I = I, F*var(2) + var(Nnew); |
---|
577 | // -------- the ideal I is ready ---------- |
---|
578 | dbprint(ppl,"// -1-2- starting the elimination of @t,@Dt in @R"); |
---|
579 | dbprint(ppl-1, I); |
---|
580 | // ideal J = engine(I,eng); |
---|
581 | ideal J = groebner(I); |
---|
582 | dbprint(ppl-1,"// -1-2-1- result of the elimination of @t,@Dt in @R"); |
---|
583 | dbprint(ppl-1, J);; |
---|
584 | ideal K = nselect(J,1,2); |
---|
585 | dbprint(ppl,"// -1-3- @t,@Dt are eliminated"); |
---|
586 | dbprint(ppl-1, K); // K is without t, Dt |
---|
587 | K = groebner(K); // std does the job too |
---|
588 | // now, we must change the ordering |
---|
589 | // and create a ring without t, Dt |
---|
590 | setring save; |
---|
591 | // ----------- the ring @R3 ------------ |
---|
592 | // _x, _Dx,s; elim.ord for _x,_Dx. |
---|
593 | // keep: N, i,j,s, tmp, RL |
---|
594 | Nnew = 2*N+1; |
---|
595 | kill Lord, tmp, iv, RName; |
---|
596 | list Lord, tmp; |
---|
597 | intvec iv; |
---|
598 | L[1] = RL[1]; |
---|
599 | L[4] = RL[4]; // char, minpoly |
---|
600 | // check whether vars hava admissible names -> done earlier |
---|
601 | // now, create the names for new var |
---|
602 | tmp[1] = "s"; |
---|
603 | list NName = Name + tmp; |
---|
604 | L[2] = NName; |
---|
605 | tmp = 0; |
---|
606 | // block ord (dp(N),dp); |
---|
607 | // string s is already defined |
---|
608 | s = "iv="; |
---|
609 | for (i=1; i<=Nnew-1; i++) |
---|
610 | { |
---|
611 | s = s+"1,"; |
---|
612 | } |
---|
613 | s[size(s)]=";"; |
---|
614 | execute(s); |
---|
615 | tmp[1] = "dp"; // string |
---|
616 | tmp[2] = iv; // intvec |
---|
617 | Lord[1] = tmp; |
---|
618 | // continue with dp 1,1,1,1... |
---|
619 | tmp[1] = "dp"; // string |
---|
620 | s[size(s)] = ","; |
---|
621 | s = s+"1;"; |
---|
622 | execute(s); |
---|
623 | kill s; |
---|
624 | kill NName; |
---|
625 | tmp[2] = iv; |
---|
626 | Lord[2] = tmp; |
---|
627 | tmp[1] = "C"; iv = 0; tmp[2]=iv; |
---|
628 | Lord[3] = tmp; tmp = 0; |
---|
629 | L[3] = Lord; |
---|
630 | // we are done with the list. Now add a Plural part |
---|
631 | def @R2@ = ring(L); |
---|
632 | setring @R2@; |
---|
633 | matrix @D[Nnew][Nnew]; |
---|
634 | for (i=1; i<=N; i++) |
---|
635 | { |
---|
636 | @D[i,N+i]=1; |
---|
637 | } |
---|
638 | def @R2 = nc_algebra(1,@D); |
---|
639 | setring @R2; |
---|
640 | kill @R2@; |
---|
641 | dbprint(ppl,"// -2-1- the ring @R2(_x,_Dx,s) is ready"); |
---|
642 | dbprint(ppl-1, @R2); |
---|
643 | ideal MM = maxideal(1); |
---|
644 | MM = 0,s,MM; |
---|
645 | map R01 = @R, MM; |
---|
646 | ideal K = R01(K); |
---|
647 | // total cleanup |
---|
648 | ideal LD = K; |
---|
649 | // make leadcoeffs positive |
---|
650 | for (i=1; i<= ncols(LD); i++) |
---|
651 | { |
---|
652 | if (leadcoef(LD[i]) <0 ) |
---|
653 | { |
---|
654 | LD[i] = -LD[i]; |
---|
655 | } |
---|
656 | } |
---|
657 | export LD; |
---|
658 | kill @R; |
---|
659 | return(@R2); |
---|
660 | } |
---|
661 | example; |
---|
662 | { |
---|
663 | "EXAMPLE:"; echo = 2; |
---|
664 | ring r = 0,(x,y,Dx,Dy),dp; |
---|
665 | def R = Weyl(); |
---|
666 | setring R; |
---|
667 | poly F = x2-y3; |
---|
668 | ideal I = Dx*F, Dy*F; |
---|
669 | def W = SDLoc(I,F); |
---|
670 | setring W; |
---|
671 | LD; |
---|
672 | } |
---|
673 | |
---|
674 | proc exCusp() |
---|
675 | { |
---|
676 | "EXAMPLE:"; echo = 2; |
---|
677 | ring r = 0,(x,y,Dx,Dy),dp; |
---|
678 | def R = Weyl(); setring R; |
---|
679 | poly F = x2-y3; |
---|
680 | ideal I = (y^3 - x^2)*Dx - 2*x, (y^3 - x^2)*Dy + 3*y^2; // I = Dx*F, Dy*F; |
---|
681 | def W = SDLoc(I,F); |
---|
682 | setring W; |
---|
683 | LD; |
---|
684 | def U = DLoc0(LD,x2-y3); |
---|
685 | setring U; |
---|
686 | LD0; |
---|
687 | BS; |
---|
688 | // the same with DLoc: |
---|
689 | setring R; |
---|
690 | DLoc(I,F); |
---|
691 | } |
---|
692 | |
---|
693 | proc exWalther1() |
---|
694 | { |
---|
695 | // p.18 Rem 3.10 |
---|
696 | ring r = 0,(x,Dx),dp; |
---|
697 | def R = nc_algebra(1,1); |
---|
698 | setring R; |
---|
699 | poly F = x; |
---|
700 | ideal I = x*Dx+1; |
---|
701 | def W = SDLoc(I,F); |
---|
702 | setring W; |
---|
703 | LD; |
---|
704 | ideal J = LD, x; |
---|
705 | eliminate(J,x*Dx); // must be [1]=s // agree! |
---|
706 | // the same result with Dloc0: |
---|
707 | def U = DLoc0(LD,x); |
---|
708 | setring U; |
---|
709 | LD0; |
---|
710 | BS; |
---|
711 | } |
---|
712 | |
---|
713 | proc exWalther2() |
---|
714 | { |
---|
715 | // p.19 Rem 3.10 cont'd |
---|
716 | ring r = 0,(x,Dx),dp; |
---|
717 | def R = nc_algebra(1,1); |
---|
718 | setring R; |
---|
719 | poly F = x; |
---|
720 | ideal I = (x*Dx)^2+1; |
---|
721 | def W = SDLoc(I,F); |
---|
722 | setring W; |
---|
723 | LD; |
---|
724 | ideal J = LD, x; |
---|
725 | eliminate(J,x*Dx); // must be [1]=s^2+2*s+2 // agree! |
---|
726 | // the same result with Dloc0: |
---|
727 | def U = DLoc0(LD,x); |
---|
728 | setring U; |
---|
729 | LD0; |
---|
730 | BS; |
---|
731 | // almost the same with DLoc |
---|
732 | setring R; |
---|
733 | DLoc(I,F); |
---|
734 | LD0; BS; |
---|
735 | } |
---|
736 | |
---|
737 | proc exWalther3() |
---|
738 | { |
---|
739 | // can check with annFs too :-) |
---|
740 | // p.21 Ex 3.15 |
---|
741 | LIB "nctools.lib"; |
---|
742 | ring r = 0,(x,y,z,w,Dx,Dy,Dz,Dw),dp; |
---|
743 | def R = Weyl(); |
---|
744 | setring R; |
---|
745 | poly F = x2+y2+z2+w2; |
---|
746 | ideal I = Dx,Dy,Dz,Dw; |
---|
747 | def W = SDLoc(I,F); |
---|
748 | setring W; |
---|
749 | LD; |
---|
750 | ideal J = LD, x2+y2+z2+w2; |
---|
751 | eliminate(J,x*y*z*w*Dx*Dy*Dz*Dw); // must be [1]=s^2+3*s+2 // agree |
---|
752 | ring r2 = 0,(x,y,z,w),dp; |
---|
753 | poly F = x2+y2+z2+w2; |
---|
754 | def Z = annfs(F); |
---|
755 | setring Z; |
---|
756 | LD; |
---|
757 | BS; |
---|
758 | // the same result with Dloc0: |
---|
759 | setring W; |
---|
760 | def U = DLoc0(LD,x2+y2+z2+w2); |
---|
761 | setring U; |
---|
762 | LD0; BS; |
---|
763 | // the same result with DLoc: |
---|
764 | setring R; |
---|
765 | DLoc(I,F); |
---|
766 | LD0; BS; |
---|
767 | } |
---|