source: git/Singular/LIB/ring.lib @ 11a441

///////////////////////////////////////////////////////////////////////////////
version="$Id: ring.lib,v 1.30 2006-11-13 12:45:14 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)
 rootofUnity(n);         the minimal polynomial for the n-th primitive root of unity
";

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

proc changechar (string c, list #)
"USAGE:   changechar(c[,r]);  c=string, r=ring
RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
         charstr(r) to c.
NOTE:    Works for qrings if map from old_char to new_char is implemented.
         This proc uses 'execute' or calls a procedure using 'execute'.
EXAMPLE: example changechar; shows an example
"
{
   if( size(#)==0 ) { def @r=basering; }
   if(( size(#)==1 ) and (typeof(#[1])=="ring")) { def @r=#[1]; }
   setring @r;
   ideal i = ideal(@r); int @q = size(i);
   if( @q!=0 )
      { string @s = "Rnew1"; }
   else
      { string @s = "Rnew"; }
   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 ?
      qring Rnew=i;
   }
   return(Rnew);
}
example
{  "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,u,v),(dp(2),ds);
   def R=changechar("2,A"); R;"";
   def R1=changechar("32003",R); setring R1; R1;
   kill R,R1;
}
///////////////////////////////////////////////////////////////////////////////

proc changeord (string o, list #)
"USAGE:   changeord(newordstr[,r]);  newordstr=string, r=ring/qring
RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
         ordstr(r) to newordstr. If, say, newordstr=(\"R\",\"wp(2,3),dp\") and
         if the ring r exists and has >=3 variables, the ring R will be
         equipped with the monomial ordering wp(2,3),dp.
NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
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 = "Rnew1"; }
   else
      { string @s = "Rnew"; }
   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 ?
      qring Rnew=i;
   }
   return(Rnew);
}
example
{  "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,u,v),(dp(2),ds);
   def R=changeord("wp(2,3),dp"); R; "";
   ideal i = x^2,y^2-u^3,v;
   qring Q = std(i);
   def Q'=changeord("lp",Q); setring Q'; Q';
   kill R,Q,Q';
}
///////////////////////////////////////////////////////////////////////////////

proc changevar (string vars, list #)
"USAGE:   changevar(vars[,r]);  vars=string, r=ring/qring
RETURN:  ring R, obtained from the ring r [default: r=basering], by changing
         varstr(r) according to the value of vars.
         If, say, vars = \"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.
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'.
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 = "Rnew1"; }
   else
      { string @s = "Rnew"; }
   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 ?
      qring Rnew=i;
   }
   return(Rnew);
}
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);
   def R=changevar("A()"); R; "";
   def Q'=changevar("a,b,c,d",Q); setring Q'; Q';
   kill R,Q,Q';
}
///////////////////////////////////////////////////////////////////////////////

proc defring (string s2, int n, string s3, string s4)
"USAGE:   defring(ch,n,va,or);  ch,va,or=strings, n=integer
RETURN:  ring R with characteristic 'ch', ordering 'or' and n variables with
         names derived from va.
         If va is a single letter, say va=\"a\", and if n<=26 then a and the
         following n-1 letters from the alphabet (cyclic order) are taken as
         variables. If n>26 or if va is a single letter followed by a bracket,
         say va=\"T(\", the variables are T(1),...,T(n).
NOTE:    This proc is useful for defining a ring in a procedure.
         This proc uses 'execute' or calls a procedure using 'execute'.
EXAMPLE: example defring; shows an example
"
{
   string @newring = "ring newring =("+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);
   return(newring);
}
example
{ "EXAMPLE:"; echo = 2;
   def r=defring("0",5,"u","ls"); r; setring r;"";
   def R=defring("2,A",10,"x(","dp(3),ws(1,2,3),ds"); R; setring R;
   kill R,r;
}
///////////////////////////////////////////////////////////////////////////////

proc defrings (int n, list #)
"USAGE:   defrings(n,[p]);  n,p integers
RETURN:  ring R with characteristic p [default: p=32003], ordering ds and n
         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26)
NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
EXAMPLE: example defrings; shows an example
"
{
   int p;
   if (size(#)==0) { p=32003; }
   else { p=#[1]; }
   if (n >26)
   {
      string s="ring S ="+string(p)+",x(1.."+string(n)+"),ds;";
   }
   else
   {
      string s="ring S ="+string(p)+",("+A_Z("x",n)+"),ds;";
   }
   execute(s);
   dbprint(printlevel-voice+2,"
// 'defrings' created a ring. To see the ring, type (if the name R was
// assigned to the return value):
    show R;
// To make the ring the active basering, type
    setring R; ");
   return(S);
}
example
{ "EXAMPLE:"; echo = 2;
   def S5=defrings(5,0); S5; "";
   def S30=defrings(30); S30;
   kill S5,S30;
}
///////////////////////////////////////////////////////////////////////////////

proc defringp (int n,list #)
"USAGE:   defringp(n,[p]);  n,p=integers
RETURN:  ring R with characteristic p [default: p=32003], ordering dp and n
         variables x,y,z,a,b,...if n<=26 (resp. x(1..n) if n>26)
NOTE:    This proc uses 'execute' or calls a procedure using 'execute'.
EXAMPLE: example defringp; shows an example
"
{
   int p;
   if (size(#)==0) { p=32003; }
   else { p=#[1]; }
   if (n >26)
   {
      string s="ring P="+string(p)+",x(1.."+string(n)+"),dp;";
   }
   else
   {
     string s="ring P="+string(p)+",("+A_Z("x",n)+"),dp;";
   }
   execute(s);
   dbprint(printlevel-voice+2,"
// 'defringp' created a ring. To see the ring, type (if the name R was
// assigned to the return value):
    show R;
// To make the ring the active basering, type
    setring R; ");
   return(P);
}
example
{ "EXAMPLE:"; echo = 2;
   def P5=defringp(5,0); P5; "";
   def P30=defringp(30); P30;
   kill P5,P30;
}
///////////////////////////////////////////////////////////////////////////////

proc extendring (int n, string va, string o, list #)
"USAGE:   extendring(n,va,o[,iv,i,r]);  va,o=strings, n,i=integers, r=ring,
          iv=intvec of positive integers or iv=0
RETURN:  ring R, which extends the ring r by adding n new variables in front
         of (resp. after, if i!=0) the old variables.
         [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 a bracket, say va=\"x(\",
            the new variables are x(1),...,x(n).
@*       -- The ordering is the product ordering of the ordering of r and of 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
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, it may be advisable to let the local
         names of your proc start with a @
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);
   dbprint(printlevel-voice+2,"
// 'extendring' created a new ring.
// To see the ring, type (if the name 'R' was assigned to the return value):
     show(R);
");

   return(na);
}
example
{ "EXAMPLE:"; echo = 2;
   ring r=0,(x,y,z),ds;
   show(r);"";
   // blocksize is derived from no of vars:
   int t=5;
   def R1=extendring(t,"a","dp");         //t global: "dp" -> "dp(5)"
   show(R1); setring R1; "";
   def R2=extendring(4,"T(","c,dp",1,r);    //"dp" -> "c,..,dp(4)"
   show(R2); setring R2; "";

   // no intvec given, blocksize given: given blocksize is used:
   def R3=extendring(4,"T(","dp(2)",0,r);   // "dp(2)" -> "dp(2)"
   show(R3); setring 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;
   def R4=extendring(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);
   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 2nd argument is present, the names are the same as in R. If,
         say, f is a poly in R and the 2nd 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 2nd 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.
SEE ALSO: imapall
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 2nd 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 2nd 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
SEE ALSO: fetchall
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/qring
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") and (typeof(r) != "qring"))
   {
      ERROR("ord_test requires a ring/qring as input");
   }
   if (attrib(r,"global")==1) { return(1);}
   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 (list #)
"USAGE:   ringtensor(r1,r2,...);  r1,r2,...=rings
RETURN:  ring R whose variables are the variables from all rings r1,r2,...
         and whose monomial ordering is the block (product) ordering of the
         respective monomial orderings 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,...
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'.
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);
      qring s=i;
   }
   dbprint(printlevel-voice+2,"
// 'ringtensor' created a ring. To see the ring, type (if the name R was
// assigned to the return value):
    show R;
// To make the ring the active basering, type
    setring R; ");
   return(s);
}
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);
   def R=ringtensor(r,s,t);
   type R;
   setring s;
   ideal i = a2+b3+c5;
   def S=changevar("x,y,z");       //change vars of s
   setring S;
   qring qS =std(fetch(s,i));      //create qring of S mod i (maped to S)
   def T=changevar("d,e,f,g,h",t); //change vars of t
   setring T;
   qring qT=std(d2+e2-f3);         //create qring of T mod d2+e2-f3
   def Q=ringtensor(s,qS,t,qT);
   setring Q; type Q;
   kill R,S,T,Q;
}
///////////////////////////////////////////////////////////////////////////////

proc ringweights (def P)
"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 i;
   intvec rw;
//------------------------- find weights  -------------------------
   for(i=nvars(P);i>0;i--)
   { rw[i]=ord(var(i)); }
   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 )
"USAGE: preimageLoc ( ring_name, map_name, ideal_name );
        all input parameters of type string
RETURN:  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: preimage under a map between local rings, map between local rings, map between local and global rings
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;
}

//////////////////////////////////////////////////////////////////////////////
/* moved here from the nctools.lib */
///////////////////////////////////////////////////////////////////////////////
proc rootofUnity(int n)
"USAGE:  rootofUnity(n); n an integer
RETURN:  number
PURPOSE: compute the minimal polynomial for the n-th primitive root of unity
NOTE: works only in field extensions by one element
EXAMPLE: example rootofUnity; shows examples
"
{
  if ( npars(basering) !=1 )
  {
    "the procedure works only with one parameter";
    return(0);
  }
  if (n<1) { return(0); }
  number mp = par(1);
  if (n==1) { return(mp-1); }
  if (n==2) { return(mp+1); }
  def OldRing = basering;
  string CH = charstr(basering);
  string MCH;
  int j=1;
  while ( (CH[j] !=",") && (j<=size(CH)))
  {
    MCH=MCH+CH[j]; j++;
  }
  string SR = "ring @@rR="+MCH+","+parstr(basering)+",dp;";
  execute(SR);
  poly @t=var(1)^n-1; // (x^2i-1)=(x^i-1)(x^i+1)
  list l=factorize(@t);
  ideal @l=l[1];
  list @d;
  int s=size(@l);
  int d=deg(@l[s]);
  int cnt=1;
  poly res;
  for (j=s-1; j>=1; j--)
  {
    if ( deg(@l[j]) > d) { d=deg(@l[j]); }
  }
  for (j=1; j<=s; j++)
  {
    if ( deg(@l[j]) == d) { @d[cnt]=@l[j]; cnt++; }
  }
  if ( size(@d)==1 )
  {
    res = poly(@d[1]);
  }
  else
  {
    j=1;
    while  ( j <= size(@d) )
    {
      res = @d[j]-lead(@d[j]);
      if ( leadcoef(res) >=0 ) { j++; }
      else { break; }
    }
    res = @d[j];
  }
  setring OldRing;
  poly I = imap(@@rR,res);
  mp = leadcoef(I);
  kill @@rR;
  return(mp);
}
example
{
  "EXAMPLE:";echo=2;
  ring r = (0,q),(x,y,z),dp;
  rootofUnity(6);
  rootofUnity(7);
  minpoly = rootofUnity(8);
  r;
}