source: git/Singular/LIB/ring.lib @ 430001

//(GMG, last modified 03.11.95)
///////////////////////////////////////////////////////////////////////////////
version="$Id: ring.lib,v 1.19 2005-04-01 11:53:31 Singular Exp $";
category="General purpose";
info="
LIBRARY:  ring.lib      Manipulating Rings and Maps

PROCEDURES:
 changechar(\"R\",c[,r]); make a copy R of basering [ring r] with new char c
 changeord(\"R\",o[,r]);  make a copy R of basering [ring r] with new ord o
 changevar(\"R\",v[,r]);  make a copy R of basering [ring r] with new vars v
 defring(\"R\",c,n,v,o);  define a ring R in specified char c, n vars v, ord o
 defrings(n[,p]);         define ring Sn in n vars, char 32003 [p], ord ds
 defringp(n[,p]);         define ring Pn in n vars, char 32003 [p], ord dp
 extendring(\"R\",n,v,o); extend given ring by n vars v, ord o and name it R
 fetchall(R[,str]);       fetch all objects of ring R to basering
 imapall(R[,str]);        imap all objects of ring R to basering
 mapall(R,i[,str]);       map all objects of ring R via ideal i to basering
 ord_test(R);             test wether ordering of R is global, local or mixed
 ringtensor(\"R\",s,t,..);create ring R, tensor product of rings s,t,...
 ringweights(r);          intvec of weights of ring variables of ring r
 preimageLoc(R,phi,Q)     computes preimage for non-global orderings
             (parameters in square brackets [] are optional)
";

LIB "inout.lib";
LIB "general.lib";
///////////////////////////////////////////////////////////////////////////////

proc changechar (string newr, string c, list #)
"USAGE:   changechar(newr,c[,r]);  newr,c=strings, r=ring
CREATE:  create a new ring with name `newr` and make it the basering if r is
         an existing ring [default: r=basering].
         The new ring differs from the old ring only in the characteristic.
         If, say, (newr,c) = (\"R\",\"0,A\") and the ring r exists, the new
         basering will have name R, characteristic 0 and one parameter A.
RETURN:  No return value
NOTE:    Works for qrings if map from old_char to new_char is implemented
         This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @.
EXAMPLE: example changechar; shows an example
"
{
   if( size(#)==0 ) { def @r=basering; }
   if( size(#)==1 ) { def @r=#[1]; }
   setring @r;
   ideal i = ideal(@r); int @q = size(i);
   if( @q!=0 )
      { string @s = "@newr1"; }
   else
      { string @s = newr; }
   string @newring = @s+"=("+c+"),("+varstr(@r)+"),("+ordstr(@r)+");";
   execute("ring "+@newring);
   if( @q!=0 )
   {
      map phi = @r,maxideal(1);
      ideal i = phi(i);
      attrib(i,"isSB",1);         //*** attrib funktioniert ?
      execute("qring "+newr+"=i;");
   }
   export(`newr`);
   keepring(`newr`);
   if (voice==2) { "// basering is now",newr; }
   return();
}
example
{  "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,u,v),(dp(2),ds);
   changechar("R","2,A"); R;"";
   changechar("R1","32003",R); R1;
   if(system("with","Namespaces")) { kill Top::R,Top::R1; }
   if (defined(R)) {kill R,R1;}
}
///////////////////////////////////////////////////////////////////////////////

proc changeord (string newr, string o, list #)
"USAGE:   changeord(newr,o[,r]);  newr,o=strings, r=ring/qring
CREATE:  create a new ring with name `newr` and make it the basering if r is
         an existing ring/qring [default: r=basering].
         The new ring differs from the old ring only in the ordering. If, say,
         (newr,o) = (\"R\",\"wp(2,3),dp\") and the ring r exists and has >=3
         variables, the new basering will have name R and ordering wp(2,3),dp.
RETURN:  No return value
NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @.
EXAMPLE: example changeord; shows an example
"
{
   if( size(#)==0 ) { def @r=basering; }
   if( size(#)==1 ) { def @r=#[1]; }
   setring @r;
   ideal i = ideal(@r); int @q = size(i);
   if( @q!=0 )
      { string @s = "@newr1"; }
   else
      { string @s = newr; }
   string @newring = @s+"=("+charstr(@r)+"),("+varstr(@r)+"),("+o+");";
   execute("ring "+@newring);
   if( @q!=0 )
   {
      map phi = @r,maxideal(1);
      ideal i = phi(i);
      attrib(i,"isSB",1);         //*** attrib funktioniert ?
      execute("qring "+newr+"=i;");
   }
   export(`newr`);
   keepring(`newr`);
   if (voice==2) { "// basering is now",newr; }
   return();
}
example
{  "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,u,v),(dp(2),ds);
   changeord("R","wp(2,3),dp"); R; "";
   ideal i = x^2,y^2-u^3,v;
   qring Q = std(i);
   changeord("Q'","lp",Q); Q';
   if(system("with","Namespaces")) { kill Top::R,Top::Q,Top::Q'; }
   if (defined(R)) {kill R,Q,Q';}
}
///////////////////////////////////////////////////////////////////////////////

proc changevar (string newr, string vars, list #)
"USAGE:   changevar(newr,vars[,r]);  newr,vars=strings, r=ring/qring
CREATE:  creates a new ring with name `newr` and makes it the basering if r
         is an existing ring/qring [default: r=basering].
         The new ring differs from the old ring only in the variables. If,
         say, (newr,vars) = (\"R\",\"t()\") and the ring r exists and has n
         variables, the new basering will have name R and variables
         t(1),...,t(n).
         If vars = \"a,b,c,d\", the new ring will have the variables a,b,c,d.
RETURN:  No return value
NOTE:    This procedure is useful in connection with the procedure ringtensor,
         when a conflict between variable names must be avoided.
         This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @.
EXAMPLE: example changevar; shows an example
"
{
   if( size(#)==0 ) { def @r=basering; }
   if( size(#)==1 ) { def @r=#[1]; }
   setring @r;
   ideal i = ideal(@r); int @q = size(i);
   if( @q!=0 )
      { string @s = "@newr1"; }
   else
      { string @s = newr; }
   string @newring = @s+"=("+charstr(@r)+"),(";
   if( vars[size(vars)-1]=="(" and vars[size(vars)]==")" )
   {
      @newring = @newring+vars[1,size(vars)-2]+"(1.."+string(nvars(@r))+")";
   }
   else { @newring = @newring+vars; }
   @newring = @newring+"),("+ordstr(@r)+");";
   execute("ring "+@newring);
   if( @q!=0 )
   {
      map phi = @r,maxideal(1);
      ideal i = phi(i);
      attrib(i,"isSB",1);         //*** attrib funktioniert ?
      execute("qring "+newr+"=i;");
   }
   export(`newr`);
   keepring(`newr`);
   if (voice==2) { "// basering is now",newr; }
   return();
}
example
{  "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,u,v),(dp(2),ds);
   ideal i = x^2,y^2-u^3,v;
   qring Q = std(i);
   setring(r);
   changevar("R","A()"); R; "";
   changevar("Q'","a,b,c,d",Q); Q';
   if(system("with","Namespaces")) { kill Top::R,Top::Q,Top::Q'; }
   if (defined(R)) {kill R,Q,Q';}
}
///////////////////////////////////////////////////////////////////////////////

proc defring (string s1, string s2, int n, string s3, string s4)
"USAGE:   defring(s1,s2,n,s3,s4);  s1..s4=strings, n=integer
CREATE:  Define a ring with name 's1', characteristic 's2', ordering 's4' and
         n variables with names derived from s3 and make it the basering.
         If s3 is a single letter, say s3=\"a\", and if n<=26 then a and the
         following n-1 letters from the alphabeth (cyclic order) are taken as
         variables. If n>26 or if s3 is a single letter followed by (, say
         s3=\"T(\", the variables are T(1),...,T(n).
RETURN:  No return value
NOTE:    This proc is useful for defining a ring in a procedure.
         This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @.
EXAMPLE: example defring; shows an example
"
{
   string @newring = "ring "+s1+"=("+s2+"),(";
   if( n>26 or s3[2]=="(" ) { string @v = s3[1]+"(1.."+string(n)+")"; }
   else { string @v = A_Z(s3,n); }
   @newring=@newring+@v+"),("+s4+");";
   execute(@newring);
   export(basering);
   keepring(`s1`);
   if (voice==2) { "// basering is now:",s1; }
   return();
}
example
{ "EXAMPLE:"; echo = 2;
   defring("r","0",5,"u","ls"); r; "";
   defring("R","2,A",10,"x(","dp(3),ws(1,2,3),ds"); R;
   if(system("with","Namespaces")) { kill Top::R,Top::r; }
   if (defined(R)) {kill R,r;}
}
///////////////////////////////////////////////////////////////////////////////

proc defrings (int n, list #)
"USAGE:   defrings(n,[p]);  n,p integers
CREATE:  Defines a ring with name Sn, characteristic p, ordering ds and n
         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26) and makes it
         the basering (default: p=32003)
RETURN:  No return value
EXAMPLE: example defrings; shows an example
"
{
   int p;
   if (size(#)==0) { p=32003; }
   else { p=#[1]; }
   if (n >26)
   {
      string s="ring S"+string(n)+"="+string(p)+",x(1.."+string(n)+"),ds;";
   }
   else
   {
      string s="ring S"+string(n)+"="+string(p)+",("+A_Z("x",n)+"),ds;";
   }
   execute(s);
   export basering;
   execute("keepring S"+string(n)+";");
   if (voice==2) { "// basering is now:",s; }
}
example
{ "EXAMPLE:"; echo = 2;
   defrings(5,0); S5; "";
   defrings(30); S30;
   if(system("with","Namespaces")) { kill Top::S5,Top::S30; }
   if (defined(R)) {kill S5,S30;}
}
///////////////////////////////////////////////////////////////////////////////

proc defringp (int n,list #)
"USAGE:   defringp(n,[p]);  n,p=integers
CREATE:  defines a ring with name Pn, characteristic p, ordering dp and n
         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26) and makes it
         the basering (default: p=32003)
RETURN:  No return value
EXAMPLE: example defringp; shows an example
"
{
   int p;
   if (size(#)==0) { p=32003; }
   else { p=#[1]; }
   if (n >26)
   {
      string s="ring P"+string(n)+"="+string(p)+",x(1.."+string(n)+"),dp;";
   }
   else
   {
     string s="ring P"+string(n)+"="+string(p)+",("+A_Z("x",n)+"),dp;";
   }
   execute(s);
   export basering;
   execute("keepring P"+string(n)+";");
   //the next comment is only shown if defringp is not called by another proc
   if (voice==2) { "// basering is now:",s; }
}
example
{ "EXAMPLE:"; echo = 2;
   defringp(5,0); P5; "";
   defringp(30); P30;
   if(system("with","Namespaces")) { kill Top::P5,Top::P30; }
   if (defined(R)) {kill P5,P30;}
}
///////////////////////////////////////////////////////////////////////////////

proc extendring (string na, int n, string va, string o, list #)
"USAGE:   extendring(na,n,va,o[iv,i,r]);  na,va,o=strings,
         n,i=integers, r=ring, iv=intvec of positive integers or iv=0
CREATE:  Define a ring with name `na` which extends the ring r by adding n new
         variables in front of [after, if i!=0] the old variables and make it
         the basering [default: (i,r)=(0,basering)].
@*       -- The characteristic is the characteristic of r.
@*       -- The new vars are derived from va. If va is a single letter, say
            va=\"T\", and if n<=26 then T and the following n-1 letters from
            T..Z..T (resp. T(1..n) if n>26) are taken as additional variables.
            If va is a single letter followed by (, say va=\"x(\", the new
            variables are x(1),...,x(n).
@*       -- The ordering is the product ordering between the ordering of r and
            an ordering derived from `o` [and iv].
@*        -  If o contains a 'c' or a 'C' in front resp. at the end this is
            taken for the whole ordering in front resp. at the end. If o does
            not contain a 'c' or a 'C' the same rule applies to ordstr(r).
@*        -  If no intvec iv is given, or if iv=0, o may be any allowed ordstr,
            like \"ds\" or \"dp(2),wp(1,2,3),Ds(2)\" or \"ds(a),dp(b),ls\" if
            a and b are globally (!) defined integers and if a+b+1<=n.
            If, however, a and b are local to a proc calling extendring, the
            intvec iv must be used to let extendring know the values of a and b
@*        -  If an intvec iv !=0 is given, iv[1],iv[2],... is taken for the
            1st, 2nd,... block of o, if o contains no substring \"w\" or \"W\"
            i.e. no weighted ordering (in the above case o=\"ds,dp,ls\"
            and iv=a,b).
            If o contains a weighted ordering (only one (!) weighted block is
            allowed) iv[1] is taken as size for the weight-vector, the next
            iv[1] values of iv are taken as weights and the remaining values of
            iv as block-size for the remaining non-weighted blocks.
            e.g. o=\"dp,ws,Dp,ds\", iv=3,2,3,4,2,5 creates the ordering
            dp(2),ws(2,3,4),Dp(5),ds
RETURN:  No return value
NOTE:    This proc is useful for adding deformation parameters.
         This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @ (see the file HelpForProc)
EXAMPLE: example extendring; shows an example
"
{
//--------------- initialization and place c/C of ordering properly -----------
   string @o1,@o2,@ro,@wstr,@v,@newring;
   int @i,@w,@ii,@k;
   intvec @iv,@iw;
   if( find(o,"c")+find(o,"C") != 0)
   {
      @k=1;
      if( o[1]=="c" or o[1]=="C" ) { @o1=o[1,2]; o=o[3..size(o)]; }
      else                         { @o2=o[size(o)-1,2]; o=o[1..size(o)-2]; }
   }
   if( size(#)==0 ) { #[1]=0; }
   if( typeof(#[1])!="intvec" )
   {
     if( size(#)==1 ) { @i=#[1]; def @r=basering; }
     if( size(#)==2 ) { @i=#[1]; def @r=#[2]; }
     if( o[size(o)]!=")" and find(o,",")==0 ) { o=o+"("+string(n)+")"; }
   }
   else
   {
     @iv=#[1];
     if( size(#)==2 ) { @i=#[2]; def @r=basering; }
     if( size(#)==3 ) { @i=#[2]; def @r=#[3]; }
     if( @iv==0 && o[size(o)]!=")" && find(o,",")==0 ) {o=o+"("+string(n)+")";}
   }
   @ro=ordstr(@r);
   if( @ro[1]=="c" or @ro[1]=="C" )
      { @v=@ro[1,2]; @ro=@ro[3..size(@ro)]; }
   else
      { @wstr=@ro[size(@ro)-1,2]; @ro=@ro[1..size(@ro)-2]; }
   if( @k==0) { @o1=@v; @o2=@wstr; }
//----------------- prepare ordering if an intvec is given --------------------
   if( typeof(#[1])=="intvec" and #[1]!=0 )
   {
      @k=n;                             //@k counts no of vars not yet ordered
      @w=find(o,"w")+find(o,"W");o=o+" ";
      if( @w!=0 )
      {
         @wstr=o[@w..@w+1];
         o=o[1,@w-1]+"@"+o[@w+2,size(o)];
         @iw=@iv[2..@iv[1]+1];
         @wstr=@wstr+"("+string(@iw)+")";
         @k=@k-@iv[1];
         @iv=@iv[@iv[1]+2..size(@iv)];
         @w=0;
      }
      for( @ii=1; @ii<=size(@iv); @ii=@ii+1 )
      {
         if( find(o,",",@w+1)!=0 )
         {
            @w=find(o,",",@w+1);
            if( o[@w-1]!="@" )
            {
               o=o[1,@w-1]+"("+string(@iv[@ii])+")"+o[@w,size(o)];
               @w=find(o,",",@w+1);
               @k=@k-@iv[@ii];
            }
            else { @ii=@ii-1; }
         }
      }
      @w=find(o,"@");
      if( @w!=0 ) { o=o[1,@w-1] + @wstr + o[@w+1,size(o)]; }
      if( @k>0 and o[size(o)]!=")" ) { o=o+"("+string(@k)+")"; }
   }
//------------------------ prepare string of new ring -------------------------
   @newring = "ring "+na+"=("+charstr(@r)+"),(";
   if( n>26 or va[2]=="(" ) { @v = va[1]+"(1.."+string(n)+")"; }
   else                     { @v = A_Z(va,n); }
   if( @i==0 )
   {
      @v=@v+","+varstr(@r);
      o=@o1+o+","+@ro+@o2;
   }
   else
   {
      @v=varstr(@r)+","+@v;
      o=@o1+@ro+","+o+@o2;
   }
   @newring=@newring+@v+"),("+o+");";
//---------------------------- execute and export -----------------------------
   execute(@newring);
   export(basering);
   keepring(`na`);
   if (voice==2) { "// basering is now",na; }
   return();
}
example
{ "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,z),ds;
   show(r);"";
   //blocksize is derived from no of vars:
   int t=5;
   extendring("R1",t,"a","dp");         //t global: "dp" -> "dp(5)"
   show(R1); "";
   extendring("R2",4,"T(","c,dp",1,r);    //"dp" -> "c,..,dp(4)"
   show(R2);"";

   //no intvec given, blocksize given: given blocksize is used:
   extendring("R3",4,"T(","dp(2)",0,r);   // "dp(2)" -> "dp(2)"
   show(R3);"";

   //intvec given: weights and blocksize is derived from given intvec
   //(no specification of a blocksize in the given ordstr is allowed!)
   //if intvec does not cover all given blocks, the last block is used
   //for the remaining variables, if intvec has too many components,
   //the last ones are ignored
   intvec v=3,2,3,4,1,3;
   extendring("R4",10,"A","ds,ws,Dp,dp",v,0,r);
         //v covers 3 blocks: v[1] (=3) : no of components of ws
         //next v[1] values (=v[2..4]) give weights
         //remaining components of v are used for the remaining blocks
   show(R4);
   if(system("with","Namespaces")){kill Top::r,Top::R1,Top::R2,Top::R3,Top::R4;}
   if (defined(r)) { kill r,R1,R2,R3,R4; }
}
///////////////////////////////////////////////////////////////////////////////

proc fetchall (R, list #)
"USAGE:   fetchall(R[,s]);  R=ring/qring, s=string
CREATE:  fetch all objects of ring R (of type poly/ideal/vector/module/number/
         matrix) into the basering.
         If no 3rd argument is present, the names are the same as in R. If,
         say, f is a poly in R and the 3rd argument is the string \"R\", then f
         is maped to f_R etc.
RETURN:  no return value
NOTE:    As fetch, this procedure maps the 1st, 2nd, ... variable of R to the
         1st, 2nd, ... variable of the basering.
         The 3rd argument is useful in order to avoid conflicts of names, the
         empty string is allowed
CAUTION: fetchall does not work inside a procedure.
         It does not work if R contains a map.
EXAMPLE: example fetchall; shows an example
"
{
   list @L@=names(R);
   int @ii@; string @s@;
   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
   {
      execute("def "+@L@[@ii@]+@s@+"=fetch(R,`@L@[@ii@]`);");
      execute("export "+@L@[@ii@]+@s@+";");
   }
   return();
}
example
{  "EXAMPLE:"; echo=2;
// The example is not shown since fetchall does not work in a procedure;
// (and hence not in the example procedure). Try the following commands:
//   ring R=0,(x,y,z),dp;
//   ideal j=x,y2,z2;
//   matrix M[2][3]=1,2,3,x,y,z;
//   j; print(M);
//   ring S=0,(a,b,c),ds;
//   fetchall(R);       //map from R to S: x->a, y->b, z->c;
//   names(S);
//   j; print(M);
//   fetchall(S,"1");   //identity map of S: copy objects, change names
//   names(S);
//   kill R,S;
}
///////////////////////////////////////////////////////////////////////////////

proc imapall (R, list #)
"USAGE:   imapall(R[,s]);  R=ring/qring, s=string
CREATE:  map all objects of ring R (of type poly/ideal/vector/module/number/
         matrix) into the basering, by applying imap to all objects of R.
         If no 3rd argument is present, the names are the same as in R. If,
         say, f is a poly in R and the 3rd argument is the string \"R\", then f
         is maped to f_R etc.
RETURN:  no return value
NOTE:    As imap, this procedure maps the variables of R to the variables with
         the same name in the basering, the other variables are maped to 0.
         The 3rd argument is useful in order to avoid conflicts of names, the
         empty string is allowed
CAUTION: imapall does not work inside a procedure
         It does not work if R contains a map
EXAMPLE: example imapall; shows an example
"
{
   list @L@=names(R);
   int @ii@; string @s@;
   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
   {
         execute("def "+@L@[@ii@]+@s@+"=imap(R,`@L@[@ii@]`);");
         execute("export "+@L@[@ii@]+@s@+";");
   }
   return();
}
example
{  "EXAMPLE:"; echo = 2;
// The example is not shown since imapall does not work in a procedure
// (and hence not in the example procedure). Try the following commands:
//   ring R=0,(x,y,z,u),dp;
//   ideal j=x,y,z,u2+ux+z;
//   matrix M[2][3]=1,2,3,x,y,uz;
//   j; print(M);
//   ring S=0,(a,b,c,x,z,y),ds;
//   imapall(R);         //map from R to S: x->x, y->y, z->z, u->0
//   names(S);
//   j; print(M);
//   imapall(S,"1");     //identity map of S: copy objects, change names
//   names(S);
//   kill R,S;
}
///////////////////////////////////////////////////////////////////////////////

proc mapall (R, ideal i, list #)
"USAGE:   mapall(R,i[,s]);  R=ring/qring, i=ideal of basering, s=string
CREATE:  map all objects of ring R (of type poly/ideal/vector/module/number/
         matrix, map) into the basering, by mapping the jth variable of R to
         the jth generator of the ideal i. If no 3rd argument is present, the
         names are the same as in R. If, say, f is a poly in R and the 3rd
         argument is the string \"R\", then f is maped to f_R etc.
RETURN:  no return value.
NOTE:    This procedure has the same effect as defining a map, say psi, by
         map psi=R,i; and then applying psi to all objects of R. In particular,
         maps from R to some ring S are composed with psi, creating thus a map
         from the basering to S.
         mapall may be combined with copyring to change vars for all objects.
         The 3rd argument is useful in order to avoid conflicts of names, the
         empty string is allowed.
CAUTION: mapall does not work inside a procedure.
EXAMPLE: example mapall; shows an example
"
{
   list @L@=names(R); map @psi@ = R,i;
   int @ii@; string @s@;
   if( size(#) > 0 ) { @s@=@s@+"_"+#[1]; }
   for( @ii@=size(@L@); @ii@>0; @ii@=@ii@-1 )
   {
      execute("def "+@L@[@ii@]+@s@+"=@psi@(`@L@[@ii@]`);");
      execute("export "+@L@[@ii@]+@s@+";");
   }
   return();
}
example
{  "EXAMPLE:"; echo = 2;
// The example is not shown since mapall does not work in a procedure
// (and hence not in the example procedure). Try the following commands:
//   ring R=0,(x,y,z),dp;
//   ideal j=x,y,z;
//   matrix M[2][3]=1,2,3,x,y,z;
//   map phi=R,x2,y2,z2;
//   ring S=0,(a,b,c),ds;
//   ideal i=c,a,b;
//   mapall(R,i);         //map from R to S: x->c, y->a, z->b
//   names(S);
//   j; print(M); phi;    //phi maps R to S: x->c2, y->a2, z->b2
//   ideal i1=a2,a+b,1;
//   mapall(R,i1,\"\");   //map from R to S: x->a2, y->a+b, z->1
//   names(S);
//   j_; print(M_); phi_;
//   changevar(\"T\",\"x()\",R);  //change vars in R and call result T
//   mapall(R,maxideal(1));       //identity map from R to T
//   names(T);
//   j; print(M); phi;
//   kill R,S,T;
}
///////////////////////////////////////////////////////////////////////////////

proc ord_test (r)
"USAGE:   ord_test(r);  r ring
RETURN:  int 1 (resp. -1, resp. 0) if ordering of r is global (resp. local,
         resp. mixed)
EXAMPLE: example ord_test; shows an example
"
{
   if (typeof(r) != "ring")
   {
      "// ord_test requires a ring as input";
      return();
   }
   def BAS = basering;
   setring r;
   poly f;
   int n,o,u = nvars(r),1,1;
   int ii;
   for ( ii=1; ii<=n; ii++ )
   {
      f = 1+var(ii);
      o = o*(lead(f) == var(ii));
      u = u*(lead(f) == 1);
   }
   setring BAS;
   if ( o==1 ) { return(1); }
   if ( u==1 ) { return(-1); }
   else { return(0); }
}
example
{ "EXAMPLE:"; echo = 2;
   ring R = 0,(x,y),dp;
   ring S = 0,(u,v),ls;
   ord_test(R);
   ord_test(S);
   ord_test(R+S);
}
///////////////////////////////////////////////////////////////////////////////

proc ringtensor (string s, list #)
"USAGE:   ringtensor(s,r1,r2,...); s=string, r1,r2,...=rings
CREATE:  A new base ring with name `s` if r1,r2,... are existing rings.
         If, say, s = \"R\" and the rings r1,r2,... exist, the new ring will
         have name R, variables from all rings r1,r2,... and as monomial
         ordering the block (product) ordering of r1,r2,... . Hence, R
         is the tensor product of the rings r1,r2,... with ordering matrix
         equal to the direct sum of the ordering matrices of r1,r2,...
RETURN:  no return value
NOTE:    The characteristic of the new ring will be that of r1. The names of
         variables in the rings r1,r2,... should differ (if a name, say x,
         occurs in r1 and r2, then, in the new ring r, x always refers to the
         variable with name x in r1, there is no access to x in r2).
         The procedure works also for quotient rings ri, if the characteristic
         of ri is compatible with the characteristic of r1 (i.e. if imap from
         ri to r1 is implemented)
         This proc uses 'execute' or calls a procedure using 'execute'.
         If you use it in your own proc, let the local names of your proc
         start with @ (see the file HelpForProc)
EXAMPLE: example ringtensor; shows an example
"
{
   int @ii,@q;
   int @n = size(#);
   string @vars,@order,@oi,@s1;
//---- gather variables, orderings and ideals (of qrings) from given rings ----
   for(@ii=1; @ii<=@n; @ii=@ii+1)
   {
      if( ordstr(#[@ii])[1]=="C" or ordstr(#[@ii])[1]=="c" )
           { @oi=ordstr(#[@ii])[3,size(ordstr(#[@ii]))-2]; }
      else { @oi=ordstr(#[@ii])[1,size(ordstr(#[@ii]))-2]; }
      @vars = @vars+varstr(#[@ii])+",";
      @order= @order+@oi+",";
      def @r(@ii)=#[@ii];
      setring @r(@ii);
      ideal i(@ii)=ideal(@r(@ii));
      int @q(@ii)=size(i(@ii));
      @q=@q+@q(@ii);
   }
   if( @q!=0 ) { @s1 = "@newr"; }   // @q=0 iff none of the rings ri is a qring
   else {  @s1 = s; }
//------------------------------- create new ring -----------------------------
   string @newring ="=("+charstr(#[1])+"),("+@vars[1,size(@vars)-1]+"),("
                  +@order[1,size(@order)-1]+");";
   execute("ring "+@s1+@newring);
//------ create ideal for new ring if one of the given rings is a qring -------
   if( @q!=0 )
   {
      ideal i;
      for(@ii=1; @ii<=@n; @ii=@ii+1)
      {
         if( @q(@ii)!=0 )
         {
            i=i+imap(@r(@ii),i(@ii));
         }
      }
      i=std(i);
      execute("qring "+s+"=i;");
   }
//----------------------- export and keep created ring ------------------------
   export(`s`);
   keepring(`s`);
   if (voice==2) { "// basering is now",s; }
   return();
}
example
{ "EXAMPLE:"; echo = 2;
   ring r=32003,(x,y,u,v),dp;
   ring s=0,(a,b,c),wp(1,2,3);
   ring t=0,x(1..5),(c,ls);
   ringtensor("R",r,s,t);
   type R;
   setring s;
   ideal i = a2+b3+c5;
   changevar("S","x,y,z");       //change vars of sand make S the basering
   qring qS =std(fetch(s,i));    //create qring of S mod i (maped to S)
   changevar("T","d,e,f,g,h",t); //change vars of t and make T the basering
   qring qT=std(d2+e2-f3);       //create qring of T mod d2+e2-f3
   ringtensor("Q",s,qS,t,qT);
   type Q;
   if(system("with","Namespaces")){kill Top::Q,Top::R,Top::S,Top::T;}
   if (defined(R)) { kill R,S,T,Q; }
}
///////////////////////////////////////////////////////////////////////////////

proc ringweights (list # )
"USAGE:   ringweights(P); P=name of an existing ring (true name, not a string)
RETURN:  intvec consisting of the weights of the variables of P, as they
         appear when typing P;.
NOTE:    This is useful when enlarging P but keeping the weights of the old
         variables.
EXAMPLE: example ringweights; shows an example
"
{
   int ii,q,fi,fo,fia;
   intvec rw,nw;
   string os;
   def P = #[1];
   string osP = ordstr(P);
   fo  = 1;
//------------------------- find weights in ordstr(P) -------------------------
   fi  = find(osP,"(",fo);
   fia = find(osP,"a",fo)+find(osP,"w",fo)+find(osP,"W",fo);
   while ( fia )
   {
      os = osP[fi+1,find(osP,")",fi)-fi-1];
      if( find(os,",") )
      {
         execute("nw = "+os+";");
         if( size(nw) > ii )
         {
             rw = rw,nw[ii+1..size(nw)];
         }
         else  {  ii = ii - size(nw); }

         if( find(osP[1,fi],"a",fo) ) { ii = size(nw); }
      }
      else
      {
         execute("q = "+os+";");
         if( q > ii )
         {
            nw = 0; nw[q-ii] = 0;
            nw = nw + 1;          //creates an intvec 1,...,1 of length q-ii
            rw = rw,nw;
         }
         else { ii = ii - q; }
      }
      fo  = fi+1;
      fi  = find(osP,"(",fo);
      fia = find(osP,"a",fo)+find(osP,"w",fo)+find(osP,"W",fo);
   }
//-------------- adjust weight vector to length = nvars(P)  -------------------
   if( fo > 1 )
   {                                            // case when weights were found
      rw = rw[2..size(rw)];
      if( size(rw) > nvars(P) )
      {
         rw = rw[1..nvars(P)];
      }
      if( size(rw) < nvars(P) )
      {
         nw=0; nw[nvars(P)-size(rw)]=0; nw=nw+1; rw=rw,nw;
      }
   }
   else
   {                                         // case when no weights were found
      rw[nvars(P)]= 0; rw=rw+1;
   }
   return(rw);
}
example
{"EXAMPLE:";  echo = 2;
  ring r0 = 0,(x,y,z),dp;
  ringweights(r0);
  ring r1 = 0,x(1..5),(ds(3),wp(2,3));
  ringweights(r1);"";
  // an example for enlarging the ring, keeping the first weights:
  intvec v = ringweights(r1),6,2,3,4,5;
  ring R = 0,x(1..10),(a(v),dp);
  ordstr(R);
}
///////////////////////////////////////////////////////////////////////////////
proc preimageLoc(string R_name,string phi_name,string Q_name )
"SYNTAX: @code{preimageLoc (} ring_name, map_name, ideal_name  @code{)}
        all input parameters of type string
TYPE:    ideal
PURPOSE: computes the preimage of an ideal under a given map for non-global 
         orderings.
         The second argument has to be the name of a map from the basering to 
         the given ring (or the name of an ideal defining such a map), and 
         the ideal has to be an ideal in the given ring.
SEE ALSO: preimage
KEYWORDS: 
EXAMPLE: example preimageLoc ; shows an example"
{
  def S=basering;
  int i;
  string newRing,minpoly_string;
  if(attrib(S,"global")!=1)
  {
    if(typeof(S)=="qring")
    {
      ideal I=ideal(S);
      newRing="ring S0=("+charstr(S)+"),("+varstr(S)+"),dp;";
      minpoly_string=string(minpoly);
      execute(newRing);
      execute("minpoly="+minpoly_string+";");
      ideal I=imap(S,I);
      list pr=primdecGTZ(I);
      newRing="ring SL=("+charstr(S)+"),("+varstr(S)+"),("+ordstr(S)+");";
      execute(newRing);
      execute("minpoly="+minpoly_string+";");
      list pr=imap(S0,pr);
      ideal I0=std(pr[1][1]);
      for(i=2;i<=size(pr);i++)
      {
         I0=intersect(I0,std(pr[i][1]));
      }
      setring S0;
      ideal I0=imap(SL,I0);
      qring S1=std(I0);
    }
    else
    {
      def S1=S;
    }
  }
  else
  {
    def S1=S;
  }
  def @R=`R_name`;
  setring @R;
  def @phi=`phi_name`;
  ideal phiId=ideal(@phi);
  def Q=`Q_name`;
  if(attrib(@R,"global")!=1)
  {
    if(typeof(@R)=="qring")
    {
      ideal J=ideal(@R);
      newRing="ring R0=("+charstr(@R)+"),("+varstr(@R)+"),dp;";
      minpoly_string=string(minpoly);
      execute(newRing);
      execute("minpoly="+minpoly_string+";");
      ideal J=imap(@R,J);
      list pr=primdecGTZ(J);
      newRing="ring RL=("+charstr(@R)+"),("+varstr(@R)+"),("+ordstr(@R)+");";
      execute(newRing);
      execute("minpoly="+minpoly_string+";");
      list pr=imap(R0,pr);
      ideal J0=std(pr[1][1]);
      for(i=2;i<=size(pr);i++)
      {
         J0=intersect(J0,std(pr[i][1]));
      }
      setring R0;
      ideal J0=imap(RL,J0);
      qring R1=std(J0);
      ideal Q=imap(@R,Q);
      map @phi=S1,imap(@R,phiId);
    }
    else
    {
      def R1=@R;
    }
  }
  else
  {
    def R1=@R;
  }
  setring S1;
  ideal preQ=preimage(R1,@phi,Q);
  setring S;
  ideal prQ=imap(S1,preQ);
  return(prQ);
}
example
{ "EXAMPLE:"; echo=2;
  ring S =0,(x,y,z),dp;
  ring R0=0,(x,y,z),ds;
  qring R=std(x+x2);
  map psi=S,x,y,z;
  ideal null;
  setring S;
  ideal nu=preimageLoc("R","psi","null");
  nu;
}