source: git/Singular/LIB/ring.lib @ 8647dd

fieker-DuValspielwiese
Last change on this file since 8647dd was 8647dd, checked in by Hans Schönemann <hannes@…>, 19 years ago
*lossen: keepring elimiated git-svn-id: file:///usr/local/Singular/svn/trunk@7919 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 29.0 KB
Line 
1///////////////////////////////////////////////////////////////////////////////
2version="$Id: ring.lib,v 1.22 2005-04-28 09:21:59 Singular Exp $";
3category="General purpose";
4info="
5LIBRARY:  ring.lib      Manipulating Rings and Maps
6
7PROCEDURES:
8 changechar(\"R\",c[,r]); make a copy R of basering [ring r] with new char c
9 changeord(\"R\",o[,r]);  make a copy R of basering [ring r] with new ord o
10 changevar(\"R\",v[,r]);  make a copy R of basering [ring r] with new vars v
11 defring(\"R\",c,n,v,o);  define a ring R in specified char c, n vars v, ord o
12 defrings(n[,p]);         define ring Sn in n vars, char 32003 [p], ord ds
13 defringp(n[,p]);         define ring Pn in n vars, char 32003 [p], ord dp
14 extendring(\"R\",n,v,o); extend given ring by n vars v, ord o and name it R
15 fetchall(R[,str]);       fetch all objects of ring R to basering
16 imapall(R[,str]);        imap all objects of ring R to basering
17 mapall(R,i[,str]);       map all objects of ring R via ideal i to basering
18 ord_test(R);             test wether ordering of R is global, local or mixed
19 ringtensor(\"R\",s,t,..);create ring R, tensor product of rings s,t,...
20 ringweights(r);          intvec of weights of ring variables of ring r
21 preimageLoc(R,phi,Q)     computes preimage for non-global orderings
22             (parameters in square brackets [] are optional)
23";
24
25LIB "inout.lib";
26LIB "general.lib";
27LIB "primdec.lib";
28///////////////////////////////////////////////////////////////////////////////
29
30proc changechar (string c, list #)
31"USAGE:   changechar(c[,r]);  c=string, r=ring
32RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
33         charstr(r) to c.
34NOTE:    Works for qrings if map from old_char to new_char is implemented.
35         This proc uses 'execute' or calls a procedure using 'execute'.
36EXAMPLE: example changechar; shows an example
37"
38{
39   if( size(#)==0 ) { def @r=basering; }
40   if(( size(#)==1 ) and (typeof(#[1])=="ring")) { def @r=#[1]; }
41   setring @r;
42   ideal i = ideal(@r); int @q = size(i);
43   if( @q!=0 )
44      { string @s = "Rnew1"; }
45   else
46      { string @s = "Rnew"; }
47   string @newring = @s+"=("+c+"),("+varstr(@r)+"),("+ordstr(@r)+");";
48   execute("ring "+@newring);
49   if( @q!=0 )
50   {
51      map phi = @r,maxideal(1);
52      ideal i = phi(i);
53      attrib(i,"isSB",1);         //*** attrib funktioniert ?
54      qring Rnew=i;
55   }
56   return(Rnew);
57}
58example
59{  "EXAMPLE:"; echo = 2;
60   ring r=0,(x,y,u,v),(dp(2),ds);
61   def R=changechar("2,A"); R;"";
62   def R1=changechar("32003",R); R1;
63   kill R,R1;
64}
65///////////////////////////////////////////////////////////////////////////////
66
67proc changeord (string o, list #)
68"USAGE:   changeord(newordstr[,r]);  newordstr=string, r=ring/qring
69RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
70         ordstr(r) to newordstr. If, say, newordstr=(\"R\",\"wp(2,3),dp\") and
71         if the ring r exists and has >=3 variables, the ring R will be
72         equipped with the monomial ordering wp(2,3),dp.
73NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
74EXAMPLE: example changeord; shows an example
75"
76{
77   if( size(#)==0 ) { def @r=basering; }
78   if( size(#)==1 ) { def @r=#[1]; }
79   setring @r;
80   ideal i = ideal(@r); int @q = size(i);
81   if( @q!=0 )
82      { string @s = "Rnew1"; }
83   else
84      { string @s = "Rnew"; }
85   string @newring = @s+"=("+charstr(@r)+"),("+varstr(@r)+"),("+o+");";
86   execute("ring "+@newring);
87   if( @q!=0 )
88   {
89      map phi = @r,maxideal(1);
90      ideal i = phi(i);
91      attrib(i,"isSB",1);         //*** attrib funktioniert ?
92      qring Rnew=i;
93   }
94   return(Rnew);
95}
96example
97{  "EXAMPLE:"; echo = 2;
98   ring r=0,(x,y,u,v),(dp(2),ds);
99   def R=changeord("wp(2,3),dp"); R; "";
100   ideal i = x^2,y^2-u^3,v;
101   qring Q = std(i);
102   def Q'=changeord("lp",Q); Q';
103   kill R,Q,Q';
104}
105///////////////////////////////////////////////////////////////////////////////
106
107proc changevar (string vars, list #)
108"USAGE:   changevar(vars[,r]);  vars=string, r=ring/qring
109RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
110         varstr(r) according to the value of vars.
111         If, say, vars = \"t()\" and the ring r exists and has n
112         variables, the new basering will have name R and variables
113         t(1),...,t(n).
114         If vars = \"a,b,c,d\", the new ring will have the variables a,b,c,d.
115NOTE:    This procedure is useful in connection with the procedure ringtensor,
116         when a conflict between variable names must be avoided.
117         This proc uses 'execute' or calls a procedure using 'execute'.
118EXAMPLE: example changevar; shows an example
119"
120{
121   if( size(#)==0 ) { def @r=basering; }
122   if( size(#)==1 ) { def @r=#[1]; }
123   setring @r;
124   ideal i = ideal(@r); int @q = size(i);
125   if( @q!=0 )
126      { string @s = "Rnew1"; }
127   else
128      { string @s = "Rnew"; }
129   string @newring = @s+"=("+charstr(@r)+"),(";
130   if( vars[size(vars)-1]=="(" and vars[size(vars)]==")" )
131   {
132      @newring = @newring+vars[1,size(vars)-2]+"(1.."+string(nvars(@r))+")";
133   }
134   else { @newring = @newring+vars; }
135   @newring = @newring+"),("+ordstr(@r)+");";
136   execute("ring "+@newring);
137   if( @q!=0 )
138   {
139      map phi = @r,maxideal(1);
140      ideal i = phi(i);
141      attrib(i,"isSB",1);         //*** attrib funktioniert ?
142      qring Rnew=i;
143   }
144   return(Rnew);
145}
146example
147{  "EXAMPLE:"; echo = 2;
148   ring r=0,(x,y,u,v),(dp(2),ds);
149   ideal i = x^2,y^2-u^3,v;
150   qring Q = std(i);
151   setring(r);
152   def R=changevar("A()"); R; "";
153   def Q'=changevar("a,b,c,d",Q); Q';
154   kill R,Q,Q';
155}
156///////////////////////////////////////////////////////////////////////////////
157
158proc defring (string s2, int n, string s3, string s4)
159"USAGE:   defring(ch,n,va,or);  ch,va,or=strings, n=integer
160RETURN:  ring R with characteristic 'ch', ordering 'or' and n variables with
161         names derived from va.
162         If va is a single letter, say va=\"a\", and if n<=26 then a and the
163         following n-1 letters from the alphabet (cyclic order) are taken as
164         variables. If n>26 or if va is a single letter followed by a bracket,
165         say va=\"T(\", the variables are T(1),...,T(n).
166NOTE:    This proc is useful for defining a ring in a procedure.
167         This proc uses 'execute' or calls a procedure using 'execute'.
168EXAMPLE: example defring; shows an example
169"
170{
171   string @newring = "ring newring =("+s2+"),(";
172   if( n>26 or s3[2]=="(" ) { string @v = s3[1]+"(1.."+string(n)+")"; }
173   else { string @v = A_Z(s3,n); }
174   @newring=@newring+@v+"),("+s4+");";
175   execute(@newring);
176   return(newring);
177}
178example
179{ "EXAMPLE:"; echo = 2;
180   def r=defring("0",5,"u","ls"); r; setring r;"";
181   def R=defring("2,A",10,"x(","dp(3),ws(1,2,3),ds"); R; setring R;
182   kill R,r;
183}
184///////////////////////////////////////////////////////////////////////////////
185
186proc defrings (int n, list #)
187"USAGE:   defrings(n,[p]);  n,p integers
188RETURN:  ring R with characteristic p [default: p=32003], ordering ds and n
189         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26)
190NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
191EXAMPLE: example defrings; shows an example
192"
193{
194   int p;
195   if (size(#)==0) { p=32003; }
196   else { p=#[1]; }
197   if (n >26)
198   {
199      string s="ring S ="+string(p)+",x(1.."+string(n)+"),ds;";
200   }
201   else
202   {
203      string s="ring S ="+string(p)+",("+A_Z("x",n)+"),ds;";
204   }
205   execute(s);
206   dbprint(printlevel-voice+2,"
207// 'defrings' created a ring. To see the ring, type (if the name R was
208// assigned to the return value):
209    show R;
210// To make the ring the active basering, type
211    setring R; ");
212   return(S);
213}
214example
215{ "EXAMPLE:"; echo = 2;
216   def S5=defrings(5,0); S5; "";
217   def S30=defrings(30); S30;
218   kill S5,S30;
219}
220///////////////////////////////////////////////////////////////////////////////
221
222proc defringp (int n,list #)
223"USAGE:   defringp(n,[p]);  n,p=integers
224RETURN:  ring R with characteristic p [default: p=32003], ordering dp and n
225         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26)
226NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
227EXAMPLE: example defringp; shows an example
228"
229{
230   int p;
231   if (size(#)==0) { p=32003; }
232   else { p=#[1]; }
233   if (n >26)
234   {
235      string s="ring P="+string(p)+",x(1.."+string(n)+"),dp;";
236   }
237   else
238   {
239     string s="ring P="+string(p)+",("+A_Z("x",n)+"),dp;";
240   }
241   execute(s);
242   dbprint(printlevel-voice+2,"
243// 'defringp' created a ring. To see the ring, type (if the name R was
244// assigned to the return value):
245    show R;
246// To make the ring the active basering, type
247    setring R; ");
248   return(P);
249}
250example
251{ "EXAMPLE:"; echo = 2;
252   def P5=defringp(5,0); P5; "";
253   def P30=defringp(30); P30;
254   kill P5,P30;
255}
256///////////////////////////////////////////////////////////////////////////////
257
258proc extendring (int n, string va, string o, list #)
259"USAGE:   extendring(n,va,o[iv,i,r]);  va,o=strings, n,i=integers, r=ring,
260          iv=intvec of positive integers or iv=0
261RETURN:  ring R, which extends the ring r by adding n new variables in front
262         of (resp. after, if i!=0) the old variables.
263         [default: (i,r)=(0,basering)].
264@*       -- The characteristic is the characteristic of r.
265@*       -- The new vars are derived from va. If va is a single letter, say
266            va=\"T\", and if n<=26 then T and the following n-1 letters from
267            T..Z..T (resp. T(1..n) if n>26) are taken as additional variables.
268            If va is a single letter followed by a bracket, say va=\"x(\",
269            the new variables are x(1),...,x(n).
270@*       -- The ordering is the product ordering of the ordering of r and of an
271            ordering derived from `o` [and iv].
272@*        -  If o contains a 'c' or a 'C' in front resp. at the end, this is
273            taken for the whole ordering in front, resp. at the end. If o does
274            not contain a 'c' or a 'C' the same rule applies to ordstr(r).
275@*        -  If no intvec iv is given, or if iv=0, o may be any allowed ordstr,
276            like \"ds\" or \"dp(2),wp(1,2,3),Ds(2)\" or \"ds(a),dp(b),ls\" if
277            a and b are globally (!) defined integers and if a+b+1<=n.
278            If, however, a and b are local to a proc calling extendring, the
279            intvec iv must be used to let extendring know the values of a and b
280@*        -  If an intvec iv !=0 is given, iv[1],iv[2],... is taken for the
281            1st, 2nd,... block of o, if o contains no substring \"w\" or \"W\"
282            i.e. no weighted ordering (in the above case o=\"ds,dp,ls\"
283            and iv=a,b).
284            If o contains a weighted ordering (only one (!) weighted block is
285            allowed) iv[1] is taken as size for the weight-vector, the next
286            iv[1] values of iv are taken as weights and the remaining values of
287            iv as block-size for the remaining non-weighted blocks.
288            e.g. o=\"dp,ws,Dp,ds\", iv=3,2,3,4,2,5 creates the ordering
289            dp(2),ws(2,3,4),Dp(5),ds
290NOTE:    This proc is useful for adding deformation parameters.
291         This proc uses 'execute' or calls a procedure using 'execute'.
292         If you use it in your own proc, it may be advisable to let the local
293         names of your proc start with a @ (see the file HelpForProc)
294EXAMPLE: example extendring; shows an example
295"
296{
297//--------------- initialization and place c/C of ordering properly -----------
298   string @o1,@o2,@ro,@wstr,@v,@newring;
299   int @i,@w,@ii,@k;
300   intvec @iv,@iw;
301   if( find(o,"c")+find(o,"C") != 0)
302   {
303      @k=1;
304      if( o[1]=="c" or o[1]=="C" ) { @o1=o[1,2]; o=o[3..size(o)]; }
305      else                         { @o2=o[size(o)-1,2]; o=o[1..size(o)-2]; }
306   }
307   if( size(#)==0 ) { #[1]=0; }
308   if( typeof(#[1])!="intvec" )
309   {
310     if( size(#)==1 ) { @i=#[1]; def @r=basering; }
311     if( size(#)==2 ) { @i=#[1]; def @r=#[2]; }
312     if( o[size(o)]!=")" and find(o,",")==0 ) { o=o+"("+string(n)+")"; }
313   }
314   else
315   {
316     @iv=#[1];
317     if( size(#)==2 ) { @i=#[2]; def @r=basering; }
318     if( size(#)==3 ) { @i=#[2]; def @r=#[3]; }
319     if( @iv==0 && o[size(o)]!=")" && find(o,",")==0 ) {o=o+"("+string(n)+")";}
320   }
321   @ro=ordstr(@r);
322   if( @ro[1]=="c" or @ro[1]=="C" )
323      { @v=@ro[1,2]; @ro=@ro[3..size(@ro)]; }
324   else
325      { @wstr=@ro[size(@ro)-1,2]; @ro=@ro[1..size(@ro)-2]; }
326   if( @k==0) { @o1=@v; @o2=@wstr; }
327//----------------- prepare ordering if an intvec is given --------------------
328   if( typeof(#[1])=="intvec" and #[1]!=0 )
329   {
330      @k=n;                             //@k counts no of vars not yet ordered
331      @w=find(o,"w")+find(o,"W");o=o+" ";
332      if( @w!=0 )
333      {
334         @wstr=o[@w..@w+1];
335         o=o[1,@w-1]+"@"+o[@w+2,size(o)];
336         @iw=@iv[2..@iv[1]+1];
337         @wstr=@wstr+"("+string(@iw)+")";
338         @k=@k-@iv[1];
339         @iv=@iv[@iv[1]+2..size(@iv)];
340         @w=0;
341      }
342      for( @ii=1; @ii<=size(@iv); @ii=@ii+1 )
343      {
344         if( find(o,",",@w+1)!=0 )
345         {
346            @w=find(o,",",@w+1);
347            if( o[@w-1]!="@" )
348            {
349               o=o[1,@w-1]+"("+string(@iv[@ii])+")"+o[@w,size(o)];
350               @w=find(o,",",@w+1);
351               @k=@k-@iv[@ii];
352            }
353            else { @ii=@ii-1; }
354         }
355      }
356      @w=find(o,"@");
357      if( @w!=0 ) { o=o[1,@w-1] + @wstr + o[@w+1,size(o)]; }
358      if( @k>0 and o[size(o)]!=")" ) { o=o+"("+string(@k)+")"; }
359   }
360//------------------------ prepare string of new ring -------------------------
361   @newring = "ring na =("+charstr(@r)+"),(";
362   if( n>26 or va[2]=="(" ) { @v = va[1]+"(1.."+string(n)+")"; }
363   else                     { @v = A_Z(va,n); }
364   if( @i==0 )
365   {
366      @v=@v+","+varstr(@r);
367      o=@o1+o+","+@ro+@o2;
368   }
369   else
370   {
371      @v=varstr(@r)+","+@v;
372      o=@o1+@ro+","+o+@o2;
373   }
374   @newring=@newring+@v+"),("+o+");";
375//---------------------------- execute and export -----------------------------
376   execute(@newring);
377   dbprint(printlevel-voice+2,"
378// 'extendring' created a new ring.
379// To see the ring, type (if the name 'R' was assigned to the return value):
380     show(R);
381");
382
383   return(na);
384}
385example
386{ "EXAMPLE:"; echo = 2;
387   ring r=0,(x,y,z),ds;
388   show(r);"";
389   // blocksize is derived from no of vars:
390   int t=5;
391   def R1=extendring(t,"a","dp");         //t global: "dp" -> "dp(5)"
392   show(R1); setring R1; "";
393   def R2=extendring(4,"T(","c,dp",1,r);    //"dp" -> "c,..,dp(4)"
394   show(R2); setring R2; "";
395
396   // no intvec given, blocksize given: given blocksize is used:
397   def R3=extendring(4,"T(","dp(2)",0,r);   // "dp(2)" -> "dp(2)"
398   show(R3); setring R3; "";
399
400   // intvec given: weights and blocksize is derived from given intvec
401   // (no specification of a blocksize in the given ordstr is allowed!)
402   // if intvec does not cover all given blocks, the last block is used
403   // for the remaining variables, if intvec has too many components,
404   // the last ones are ignored
405   intvec v=3,2,3,4,1,3;
406   def R4=extendring(10,"A","ds,ws,Dp,dp",v,0,r);
407   // v covers 3 blocks: v[1] (=3) : no of components of ws
408   // next v[1] values (=v[2..4]) give weights
409   // remaining components of v are used for the remaining blocks
410   show(R4);
411   kill r,R1,R2,R3,R4;
412}
413///////////////////////////////////////////////////////////////////////////////
414
415proc fetchall (R, list #)
416"USAGE:   fetchall(R[,s]);  R=ring/qring, s=string
417CREATE:  fetch all objects of ring R (of type poly/ideal/vector/module/number/
418         matrix) into the basering.
419         If no 3rd argument is present, the names are the same as in R. If,
420         say, f is a poly in R and the 3rd argument is the string \"R\", then f
421         is maped to f_R etc.
422RETURN:  no return value
423NOTE:    As fetch, this procedure maps the 1st, 2nd, ... variable of R to the
424         1st, 2nd, ... variable of the basering.
425         The 3rd argument is useful in order to avoid conflicts of names, the
426         empty string is allowed
427CAUTION: fetchall does not work inside a procedure.
428         It does not work if R contains a map.
429EXAMPLE: example fetchall; shows an example
430"
431{
432   list @L@=names(R);
433   int @ii@; string @s@;
434   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
435   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
436   {
437      execute("def "+@L@[@ii@]+@s@+"=fetch(R,`@L@[@ii@]`);");
438      execute("export "+@L@[@ii@]+@s@+";");
439   }
440   return();
441}
442example
443{  "EXAMPLE:"; echo=2;
444// The example is not shown since fetchall does not work in a procedure;
445// (and hence not in the example procedure). Try the following commands:
446//   ring R=0,(x,y,z),dp;
447//   ideal j=x,y2,z2;
448//   matrix M[2][3]=1,2,3,x,y,z;
449//   j; print(M);
450//   ring S=0,(a,b,c),ds;
451//   fetchall(R);       //map from R to S: x->a, y->b, z->c;
452//   names(S);
453//   j; print(M);
454//   fetchall(S,"1");   //identity map of S: copy objects, change names
455//   names(S);
456//   kill R,S;
457}
458///////////////////////////////////////////////////////////////////////////////
459
460proc imapall (R, list #)
461"USAGE:   imapall(R[,s]);  R=ring/qring, s=string
462CREATE:  map all objects of ring R (of type poly/ideal/vector/module/number/
463         matrix) into the basering, by applying imap to all objects of R.
464         If no 3rd argument is present, the names are the same as in R. If,
465         say, f is a poly in R and the 3rd argument is the string \"R\", then f
466         is maped to f_R etc.
467RETURN:  no return value
468NOTE:    As imap, this procedure maps the variables of R to the variables with
469         the same name in the basering, the other variables are maped to 0.
470         The 3rd argument is useful in order to avoid conflicts of names, the
471         empty string is allowed
472CAUTION: imapall does not work inside a procedure
473         It does not work if R contains a map
474EXAMPLE: example imapall; shows an example
475"
476{
477   list @L@=names(R);
478   int @ii@; string @s@;
479   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
480   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
481   {
482         execute("def "+@L@[@ii@]+@s@+"=imap(R,`@L@[@ii@]`);");
483         execute("export "+@L@[@ii@]+@s@+";");
484   }
485   return();
486}
487example
488{  "EXAMPLE:"; echo = 2;
489// The example is not shown since imapall does not work in a procedure
490// (and hence not in the example procedure). Try the following commands:
491//   ring R=0,(x,y,z,u),dp;
492//   ideal j=x,y,z,u2+ux+z;
493//   matrix M[2][3]=1,2,3,x,y,uz;
494//   j; print(M);
495//   ring S=0,(a,b,c,x,z,y),ds;
496//   imapall(R);         //map from R to S: x->x, y->y, z->z, u->0
497//   names(S);
498//   j; print(M);
499//   imapall(S,"1");     //identity map of S: copy objects, change names
500//   names(S);
501//   kill R,S;
502}
503///////////////////////////////////////////////////////////////////////////////
504
505proc mapall (R, ideal i, list #)
506"USAGE:   mapall(R,i[,s]);  R=ring/qring, i=ideal of basering, s=string
507CREATE:  map all objects of ring R (of type poly/ideal/vector/module/number/
508         matrix, map) into the basering, by mapping the jth variable of R to
509         the jth generator of the ideal i. If no 3rd argument is present, the
510         names are the same as in R. If, say, f is a poly in R and the 3rd
511         argument is the string \"R\", then f is maped to f_R etc.
512RETURN:  no return value.
513NOTE:    This procedure has the same effect as defining a map, say psi, by
514         map psi=R,i; and then applying psi to all objects of R. In particular,
515         maps from R to some ring S are composed with psi, creating thus a map
516         from the basering to S.
517         mapall may be combined with copyring to change vars for all objects.
518         The 3rd argument is useful in order to avoid conflicts of names, the
519         empty string is allowed.
520CAUTION: mapall does not work inside a procedure.
521EXAMPLE: example mapall; shows an example
522"
523{
524   list @L@=names(R); map @psi@ = R,i;
525   int @ii@; string @s@;
526   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
527   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
528   {
529      execute("def "+@L@[@ii@]+@s@+"=@psi@(`@L@[@ii@]`);");
530      execute("export "+@L@[@ii@]+@s@+";");
531   }
532   return();
533}
534example
535{  "EXAMPLE:"; echo = 2;
536// The example is not shown since mapall does not work in a procedure
537// (and hence not in the example procedure). Try the following commands:
538//   ring R=0,(x,y,z),dp;
539//   ideal j=x,y,z;
540//   matrix M[2][3]=1,2,3,x,y,z;
541//   map phi=R,x2,y2,z2;
542//   ring S=0,(a,b,c),ds;
543//   ideal i=c,a,b;
544//   mapall(R,i);         //map from R to S: x->c, y->a, z->b
545//   names(S);
546//   j; print(M); phi;    //phi maps R to S: x->c2, y->a2, z->b2
547//   ideal i1=a2,a+b,1;
548//   mapall(R,i1,\"\");   //map from R to S: x->a2, y->a+b, z->1
549//   names(S);
550//   j_; print(M_); phi_;
551//   changevar(\"T\",\"x()\",R);  //change vars in R and call result T
552//   mapall(R,maxideal(1));       //identity map from R to T
553//   names(T);
554//   j; print(M); phi;
555//   kill R,S,T;
556}
557///////////////////////////////////////////////////////////////////////////////
558
559proc ord_test (r)
560"USAGE:   ord_test(r);  r ring
561RETURN:  int 1 (resp. -1, resp. 0) if ordering of r is global (resp. local,
562         resp. mixed)
563EXAMPLE: example ord_test; shows an example
564"
565{
566   if (typeof(r) != "ring")
567   {
568      "// ord_test requires a ring as input";
569      return();
570   }
571   def BAS = basering;
572   setring r;
573   poly f;
574   int n,o,u = nvars(r),1,1;
575   int ii;
576   for ( ii=1; ii<=n; ii++ )
577   {
578      f = 1+var(ii);
579      o = o*(lead(f) == var(ii));
580      u = u*(lead(f) == 1);
581   }
582   setring BAS;
583   if ( o==1 ) { return(1); }
584   if ( u==1 ) { return(-1); }
585   else { return(0); }
586}
587example
588{ "EXAMPLE:"; echo = 2;
589   ring R = 0,(x,y),dp;
590   ring S = 0,(u,v),ls;
591   ord_test(R);
592   ord_test(S);
593   ord_test(R+S);
594}
595///////////////////////////////////////////////////////////////////////////////
596
597proc ringtensor (list #)
598"USAGE:   ringtensor(r1,r2,...); s=string, r1,r2,...=rings
599RETURN:  ring R whose variables are the variables from all rings r1,r2,...
600         and whose monomial ordering is the block (product) ordering of the
601         respective monomial orderings of r1,r2,... . Hence, R
602         is the tensor product of the rings r1,r2,... with ordering matrix
603         equal to the direct sum of the ordering matrices of r1,r2,...
604NOTE:    The characteristic of the new ring will be that of r1. The names of
605         variables in the rings r1,r2,... should differ (if a name, say x,
606         occurs in r1 and r2, then, in the new ring r, x always refers to the
607         variable with name x in r1, there is no access to x in r2).
608         The procedure works also for quotient rings ri, if the characteristic
609         of ri is compatible with the characteristic of r1 (i.e. if imap from
610         ri to r1 is implemented)
611         This proc uses 'execute' or calls a procedure using 'execute'.
612EXAMPLE: example ringtensor; shows an example
613"
614{
615   int @ii,@q;
616   int @n = size(#);
617   string @vars,@order,@oi,@s1;
618//---- gather variables, orderings and ideals (of qrings) from given rings ----
619   for(@ii=1; @ii<=@n; @ii=@ii+1)
620   {
621      if( ordstr(#[@ii])[1]=="C" or ordstr(#[@ii])[1]=="c" )
622           { @oi=ordstr(#[@ii])[3,size(ordstr(#[@ii]))-2]; }
623      else { @oi=ordstr(#[@ii])[1,size(ordstr(#[@ii]))-2]; }
624      @vars = @vars+varstr(#[@ii])+",";
625      @order= @order+@oi+",";
626      def @r(@ii)=#[@ii];
627      setring @r(@ii);
628      ideal i(@ii)=ideal(@r(@ii));
629      int @q(@ii)=size(i(@ii));
630      @q=@q+@q(@ii);
631   }
632   if( @q!=0 ) { @s1 = "@newr"; }   // @q=0 iff none of the rings ri is a qring
633   else {  @s1 = "s"; }
634//------------------------------- create new ring -----------------------------
635   string @newring ="=("+charstr(#[1])+"),("+@vars[1,size(@vars)-1]+"),("
636                  +@order[1,size(@order)-1]+");";
637   execute("ring "+@s1+@newring);
638//------ create ideal for new ring if one of the given rings is a qring -------
639   if( @q!=0 )
640   {
641      ideal i;
642      for(@ii=1; @ii<=@n; @ii=@ii+1)
643      {
644         if( @q(@ii)!=0 )
645         {
646            i=i+imap(@r(@ii),i(@ii));
647         }
648      }
649      i=std(i);
650      qring s=i;
651   }
652   dbprint(printlevel-voice+2,"
653// 'ringtensor' created a ring. To see the ring, type (if the name R was
654// assigned to the return value):
655    show R;
656// To make the ring the active basering, type
657    setring R; ");
658   return(s);
659}
660example
661{ "EXAMPLE:"; echo = 2;
662   ring r=32003,(x,y,u,v),dp;
663   ring s=0,(a,b,c),wp(1,2,3);
664   ring t=0,x(1..5),(c,ls);
665   def R=ringtensor(r,s,t);
666   type R;
667   setring s;
668   ideal i = a2+b3+c5;
669   def S=changevar("x,y,z");       //change vars of s
670   setring S;
671   qring qS =std(fetch(s,i));      //create qring of S mod i (maped to S)
672   def T=changevar("d,e,f,g,h",t); //change vars of t
673   setring T;
674   qring qT=std(d2+e2-f3);         //create qring of T mod d2+e2-f3
675   def Q=ringtensor(s,qS,t,qT);
676   type Q;
677   kill R,S,T,Q;
678}
679///////////////////////////////////////////////////////////////////////////////
680
681proc ringweights (list # )
682"USAGE:   ringweights(P); P=name of an existing ring (true name, not a string)
683RETURN:  intvec consisting of the weights of the variables of P, as they
684         appear when typing P;.
685NOTE:    This is useful when enlarging P but keeping the weights of the old
686         variables.
687EXAMPLE: example ringweights; shows an example
688"
689{
690   int ii,q,fi,fo,fia;
691   intvec rw,nw;
692   string os;
693   def P = #[1];
694   string osP = ordstr(P);
695   fo  = 1;
696//------------------------- find weights in ordstr(P) -------------------------
697   fi  = find(osP,"(",fo);
698   fia = find(osP,"a",fo)+find(osP,"w",fo)+find(osP,"W",fo);
699   while ( fia )
700   {
701      os = osP[fi+1,find(osP,")",fi)-fi-1];
702      if( find(os,",") )
703      {
704         execute("nw = "+os+";");
705         if( size(nw) > ii )
706         {
707             rw = rw,nw[ii+1..size(nw)];
708         }
709         else  {  ii = ii - size(nw); }
710
711         if( find(osP[1,fi],"a",fo) ) { ii = size(nw); }
712      }
713      else
714      {
715         execute("q = "+os+";");
716         if( q > ii )
717         {
718            nw = 0; nw[q-ii] = 0;
719            nw = nw + 1;          //creates an intvec 1,...,1 of length q-ii
720            rw = rw,nw;
721         }
722         else { ii = ii - q; }
723      }
724      fo  = fi+1;
725      fi  = find(osP,"(",fo);
726      fia = find(osP,"a",fo)+find(osP,"w",fo)+find(osP,"W",fo);
727   }
728//-------------- adjust weight vector to length = nvars(P)  -------------------
729   if( fo > 1 )
730   {                                            // case when weights were found
731      rw = rw[2..size(rw)];
732      if( size(rw) > nvars(P) )
733      {
734         rw = rw[1..nvars(P)];
735      }
736      if( size(rw) < nvars(P) )
737      {
738         nw=0; nw[nvars(P)-size(rw)]=0; nw=nw+1; rw=rw,nw;
739      }
740   }
741   else
742   {                                         // case when no weights were found
743      rw[nvars(P)]= 0; rw=rw+1;
744   }
745   return(rw);
746}
747example
748{"EXAMPLE:";  echo = 2;
749  ring r0 = 0,(x,y,z),dp;
750  ringweights(r0);
751  ring r1 = 0,x(1..5),(ds(3),wp(2,3));
752  ringweights(r1);"";
753  // an example for enlarging the ring, keeping the first weights:
754  intvec v = ringweights(r1),6,2,3,4,5;
755  ring R = 0,x(1..10),(a(v),dp);
756  ordstr(R);
757}
758///////////////////////////////////////////////////////////////////////////////
759proc preimageLoc(string R_name,string phi_name,string Q_name )
760"SYNTAX: @code{preimageLoc (} ring_name, map_name, ideal_name  @code{)}
761        all input parameters of type string
762TYPE:    ideal
763PURPOSE: computes the preimage of an ideal under a given map for non-global
764         orderings.
765         The second argument has to be the name of a map from the basering to
766         the given ring (or the name of an ideal defining such a map), and
767         the ideal has to be an ideal in the given ring.
768SEE ALSO: preimage
769KEYWORDS:
770EXAMPLE: example preimageLoc ; shows an example"
771{
772  def S=basering;
773  int i;
774  string newRing,minpoly_string;
775  if(attrib(S,"global")!=1)
776  {
777    if(typeof(S)=="qring")
778    {
779      ideal I=ideal(S);
780      newRing="ring S0=("+charstr(S)+"),("+varstr(S)+"),dp;";
781      minpoly_string=string(minpoly);
782      execute(newRing);
783      execute("minpoly="+minpoly_string+";");
784      ideal I=imap(S,I);
785      list pr=primdecGTZ(I);
786      newRing="ring SL=("+charstr(S)+"),("+varstr(S)+"),("+ordstr(S)+");";
787      execute(newRing);
788      execute("minpoly="+minpoly_string+";");
789      list pr=imap(S0,pr);
790      ideal I0=std(pr[1][1]);
791      for(i=2;i<=size(pr);i++)
792      {
793         I0=intersect(I0,std(pr[i][1]));
794      }
795      setring S0;
796      ideal I0=imap(SL,I0);
797      qring S1=std(I0);
798    }
799    else
800    {
801      def S1=S;
802    }
803  }
804  else
805  {
806    def S1=S;
807  }
808  def @R=`R_name`;
809  setring @R;
810  def @phi=`phi_name`;
811  ideal phiId=ideal(@phi);
812  def Q=`Q_name`;
813  if(attrib(@R,"global")!=1)
814  {
815    if(typeof(@R)=="qring")
816    {
817      ideal J=ideal(@R);
818      newRing="ring R0=("+charstr(@R)+"),("+varstr(@R)+"),dp;";
819      minpoly_string=string(minpoly);
820      execute(newRing);
821      execute("minpoly="+minpoly_string+";");
822      ideal J=imap(@R,J);
823      list pr=primdecGTZ(J);
824      newRing="ring RL=("+charstr(@R)+"),("+varstr(@R)+"),("+ordstr(@R)+");";
825      execute(newRing);
826      execute("minpoly="+minpoly_string+";");
827      list pr=imap(R0,pr);
828      ideal J0=std(pr[1][1]);
829      for(i=2;i<=size(pr);i++)
830      {
831         J0=intersect(J0,std(pr[i][1]));
832      }
833      setring R0;
834      ideal J0=imap(RL,J0);
835      qring R1=std(J0);
836      ideal Q=imap(@R,Q);
837      map @phi=S1,imap(@R,phiId);
838    }
839    else
840    {
841      def R1=@R;
842    }
843  }
844  else
845  {
846    def R1=@R;
847  }
848  setring S1;
849  ideal preQ=preimage(R1,@phi,Q);
850  setring S;
851  ideal prQ=imap(S1,preQ);
852  return(prQ);
853}
854example
855{ "EXAMPLE:"; echo=2;
856  ring S =0,(x,y,z),dp;
857  ring R0=0,(x,y,z),ds;
858  qring R=std(x+x2);
859  map psi=S,x,y,z;
860  ideal null;
861  setring S;
862  ideal nu=preimageLoc("R","psi","null");
863  nu;
864}
865
Note: See TracBrowser for help on using the repository browser.