source: git/Singular/LIB/primdec.lib @ d92713

spielwiese
Last change on this file since d92713 was d92713, checked in by Hans Schönemann <hannes@…>, 15 years ago
*hannes:decomp.,3) again git-svn-id: file:///usr/local/Singular/svn/trunk@11571 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 208.0 KB
RevLine 
[091424]1///////////////////////////////////////////////////////////////////////////////
[d92713]2version="$Id: primdec.lib,v 1.145 2009-03-18 14:17:33 Singular Exp $";
[0ae4ce]3category="Commutative Algebra";
[5480da]4info="
[8942a5]5LIBRARY: primdec.lib   Primary Decomposition and Radical of Ideals
[f3c6e5]6AUTHORS:  Gerhard Pfister, pfister@mathematik.uni-kl.de (GTZ)@*
7          Wolfram Decker, decker@math.uni-sb.de         (SY)@*
8          Hans Schoenemann, hannes@mathematik.uni-kl.de (SY)@*
9          Santiago Laplagne, slaplagn@dm.uba.ar         (GTZ)
[f34c37c]10
[b9b906]11OVERVIEW:
[07c623]12    Algorithms for primary decomposition based on the ideas of
[367e88]13    Gianni, Trager and Zacharias (implementation by Gerhard Pfister),
14    respectively based on the ideas of Shimoyama and Yokoyama (implementation
[7f7c25e]15    by Wolfram Decker and Hans Schoenemann).@*
16    The procedures are implemented to be used in characteristic 0.@*
17    They also work in positive characteristic >> 0.@*
18    In small characteristic and for algebraic extensions, primdecGTZ
19    may not terminate.@*
[b9b906]20    Algorithms for the computation of the radical based on the ideas of
[7f7c25e]21    Krick, Logar, Laplagne and Kemper (implementation by Gerhard Pfister and Santiago Laplagne).
22    They work in any characteristic.
[8942a5]23
[f34c37c]24PROCEDURES:
[24f458]25 Ann(M);           annihilator of R^n/M, R=basering, M in R^n
[8942a5]26 primdecGTZ(I);    complete primary decomposition via Gianni,Trager,Zacharias
27 primdecSY(I...);  complete primary decomposition via Shimoyama-Yokoyama
[7f7c25e]28 minAssGTZ(I);     the minimal associated primes via Gianni,Trager,Zacharias (with modifications by Laplagne)
[8942a5]29 minAssChar(I...); the minimal associated primes using characteristic sets
30 testPrimary(L,k); tests the result of the primary decomposition
[7f7c25e]31 radical(I);       computes the radical of I via Krick/Logar (with modifications by Laplagne) and Kemper
32 radicalEHV(I);    computes the radical of I via Eisenbud,Huneke,Vasconcelos
[8942a5]33 equiRadical(I);   the radical of the equidimensional part of the ideal I
34 prepareAss(I);    list of radicals of the equidimensional components of I
35 equidim(I);       weak equidimensional decomposition of I
36 equidimMax(I);    equidimensional locus of I
37 equidimMaxEHV(I); equidimensional locus of I via Eisenbud,Huneke,Vasconcelos
38 zerodec(I);       zerodimensional decomposition via Monico
[326dba]39 absPrimdecGTZ(I); the absolute prime components of I
[8942a5]40";
[e801fe]41
42LIB "general.lib";
[67bd4c]43LIB "elim.lib";
[e801fe]44LIB "poly.lib";
45LIB "random.lib";
[8afd58]46LIB "inout.lib";
[7f24dd7]47LIB "matrix.lib";
[24f458]48LIB "triang.lib";
[6fa3af]49LIB "absfact.lib";
[d6db1f2]50///////////////////////////////////////////////////////////////////////////////
[ebecf83]51//
[091424]52//                      Gianni/Trager/Zacharias
[ebecf83]53//
54///////////////////////////////////////////////////////////////////////////////
55
[07c623]56static proc sat1 (ideal id, poly p)
[d2b2a7]57"USAGE:   sat1(id,j);  id ideal, j polynomial
[d6db1f2]58RETURN:  saturation of id with respect to j (= union_(k=1...) of id:j^k)
59NOTE:    result is a std basis in the basering
[d2b2a7]60"
[d6db1f2]61{
[70ab73]62  int @k;
63  ideal inew=std(id);
64  ideal iold;
65  intvec op=option(get);
66  option(returnSB);
67  while(specialIdealsEqual(iold,inew)==0 )
68  {
69    iold=inew;
70    inew=quotient(iold,p);
71    @k++;
72  }
73  @k--;
74  option(set,op);
75  list L =inew,p^@k;
76  return (L);
[d6db1f2]77}
78
79///////////////////////////////////////////////////////////////////////////////
80
[07c623]81static proc sat2 (ideal id, ideal h)
[d2b2a7]82"USAGE:   sat2(id,j);  id ideal, j polynomial
[d6db1f2]83RETURN:  saturation of id with respect to j (= union_(k=1...) of id:j^k)
84NOTE:    result is a std basis in the basering
[d2b2a7]85"
[d6db1f2]86{
[70ab73]87  int @k,@i;
88  def @P= basering;
89  if(ordstr(basering)[1,2]!="dp")
90  {
91    execute("ring @Phelp=("+charstr(@P)+"),("+varstr(@P)+"),(C,dp);");
92    ideal inew=std(imap(@P,id));
93    ideal  @h=imap(@P,h);
94  }
95  else
96  {
97    ideal @h=h;
98    ideal inew=std(id);
99  }
100  ideal fac;
[d6db1f2]101
[70ab73]102  for(@i=1;@i<=ncols(@h);@i++)
103  {
104    if(deg(@h[@i])>0)
105    {
106      fac=fac+factorize(@h[@i],1);
107    }
108  }
109  fac=simplify(fac,6);
110  poly @f=1;
111  if(deg(fac[1])>0)
112  {
113    ideal iold;
114    for(@i=1;@i<=size(fac);@i++)
115    {
116      @f=@f*fac[@i];
117    }
118    intvec op = option(get);
119    option(returnSB);
120    while(specialIdealsEqual(iold,inew)==0 )
121    {
122      iold=inew;
123      if(deg(iold[size(iold)])!=1)
[d6db1f2]124      {
[70ab73]125        inew=quotient(iold,@f);
[d6db1f2]126      }
[70ab73]127      else
128      {
129        inew=iold;
130      }
131      @k++;
132    }
133    option(set,op);
134    @k--;
135  }
[d6db1f2]136
[70ab73]137  if(ordstr(@P)[1,2]!="dp")
138  {
139    setring @P;
140    ideal inew=std(imap(@Phelp,inew));
141    poly @f=imap(@Phelp,@f);
142  }
143  list L =inew,@f^@k;
144  return (L);
[d6db1f2]145}
146
147///////////////////////////////////////////////////////////////////////////////
148
[24f458]149
150proc minSat(ideal inew, ideal h)
[d6db1f2]151{
[70ab73]152  int i,k;
153  poly f=1;
154  ideal iold,fac;
155  list quotM,l;
[d6db1f2]156
[70ab73]157  for(i=1;i<=ncols(h);i++)
158  {
159    if(deg(h[i])>0)
160    {
161      fac=fac+factorize(h[i],1);
162    }
163  }
164  fac=simplify(fac,6);
165  if(size(fac)==0)
166  {
167    l=inew,1;
168    return(l);
169  }
170  fac=sort(fac)[1];
171  for(i=1;i<=size(fac);i++)
172  {
173    f=f*fac[i];
174  }
175  quotM[1]=inew;
176  quotM[2]=fac;
177  quotM[3]=f;
178  f=1;
179  intvec op = option(get);
180  option(returnSB);
181  while(specialIdealsEqual(iold,quotM[1])==0)
182  {
183    if(k>0)
184    {
185      f=f*quotM[3];
186    }
187    iold=quotM[1];
188    quotM=quotMin(quotM);
189    k++;
190  }
191  option(set,op);
192  l=quotM[1],f;
193  return(l);
[18dd47]194}
[d6db1f2]195
[07c623]196static proc quotMin(list tsil)
[d6db1f2]197{
[70ab73]198  int i,j,k,action;
199  ideal verg;
200  list l;
201  poly g;
[d6db1f2]202
[70ab73]203  ideal laedi=tsil[1];
204  ideal fac=tsil[2];
205  poly f=tsil[3];
[3939bc]206
[70ab73]207  ideal star=quotient(laedi,f);
[b1d1e8c]208
[70ab73]209  if(specialIdealsEqual(star,laedi))
210  {
211    l=star,fac,f;
212    return(l);
213  }
[b9b906]214
[70ab73]215  action=1;
[18dd47]216
[70ab73]217  while(action==1)
218  {
219    if(size(fac)==1)
220    {
221      action=0;
222      break;
223    }
224    for(i=1;i<=size(fac);i++)
225    {
226      g=1;
227      verg=laedi;
228      for(j=1;j<=size(fac);j++)
[d6db1f2]229      {
[70ab73]230        if(i!=j)
231        {
232          g=g*fac[j];
233        }
[d6db1f2]234      }
[70ab73]235      verg=quotient(laedi,g);
[3939bc]236
[70ab73]237      if(specialIdealsEqual(verg,star)==1)
238      {
239        f=g;
240        fac[i]=0;
241        fac=simplify(fac,2);
242        break;
[d6db1f2]243      }
[70ab73]244      if(i==size(fac))
245      {
246        action=0;
247      }
248    }
249  }
250  l=star,fac,f;
251  return(l);
[d6db1f2]252}
253
[091424]254///////////////////////////////////////////////////////////////////////////////
255
[07c623]256static proc testFactor(list act,poly p)
[d6db1f2]257{
[e801fe]258  poly keep=p;
[3939bc]259
[70ab73]260  int i;
261  poly q=act[1][1]^act[2][1];
262  for(i=2;i<=size(act[1]);i++)
263  {
264    q=q*act[1][i]^act[2][i];
265  }
266  q=1/leadcoef(q)*q;
267  p=1/leadcoef(p)*p;
268  if(p-q!=0)
269  {
270    "ERROR IN FACTOR, please inform the authors";
271  }
[d6db1f2]272}
[091424]273///////////////////////////////////////////////////////////////////////////////
[d6db1f2]274
[07c623]275static proc factor(poly p)
[d2b2a7]276"USAGE:   factor(p) p poly
[d6db1f2]277RETURN:  list=;
[18dd47]278NOTE:
[d6db1f2]279EXAMPLE: example factor; shows an example
[d2b2a7]280"
[d6db1f2]281{
282  ideal @i;
283  list @l;
284  intvec @v,@w;
285  int @j,@k,@n;
286
287  if(deg(p)<=1)
288  {
[70ab73]289    @i=ideal(p);
290    @v=1;
291    @l[1]=@i;
292    @l[2]=@v;
293    return(@l);
[d6db1f2]294  }
295  if (size(p)==1)
296  {
[70ab73]297    @w=leadexp(p);
298    for(@j=1;@j<=nvars(basering);@j++)
299    {
300      if(@w[@j]!=0)
301      {
302        @k++;
303        @v[@k]=@w[@j];
304        @i=@i+ideal(var(@j));
305      }
306    }
307    @l[1]=@i;
308    @l[2]=@v;
309    return(@l);
[d6db1f2]310  }
[091424]311  //  @l=factorize(p,2);
[e801fe]312  @l=factorize(p);
313  // if(npars(basering)>0)
314  // {
[70ab73]315    for(@j=1;@j<=size(@l[1]);@j++)
316    {
317      if(deg(@l[1][@j])==0)
318      {
319        @n++;
320      }
321    }
322    if(@n>0)
323    {
324      if(@n==size(@l[1]))
325      {
326        @l[1]=ideal(1);
327        @v=1;
328        @l[2]=@v;
329      }
330      else
331      {
332        @k=0;
333        int pleh;
334        for(@j=1;@j<=size(@l[1]);@j++)
[d6db1f2]335        {
[70ab73]336          if(deg(@l[1][@j])!=0)
337          {
338            @k++;
339            @i=@i+ideal(@l[1][@j]);
340            if(size(@i)==pleh)
341            {
342              "//factorization error";
343              @l;
344              @k--;
345              @v[@k]=@v[@k]+@l[2][@j];
346            }
347            else
348            {
349              pleh++;
350              @v[@k]=@l[2][@j];
351            }
352          }
[d6db1f2]353        }
[70ab73]354        @l[1]=@i;
355        @l[2]=@v;
356      }
357    }
358    // }
[d6db1f2]359  return(@l);
360}
361example
362{ "EXAMPLE:"; echo = 2;
363   ring  r = 0,(x,y,z),lp;
364   poly  p = (x+y)^2*(y-z)^3;
365   list  l = factor(p);
366   l;
367   ring r1 =(0,b,d,f,g),(a,c,e),lp;
368   poly p  =(1*d)*e^2+(1*d*f^2*g);
369   list  l = factor(p);
370   l;
371   ring r2 =(0,b,f,g),(a,c,e,d),lp;
372   poly p  =(1*d)*e^2+(1*d*f^2*g);
373   list  l = factor(p);
374   l;
375}
376
[091424]377///////////////////////////////////////////////////////////////////////////////
[d6db1f2]378
[50cbdc]379proc idealsEqual( ideal k, ideal j)
[18dd47]380{
[70ab73]381  return(stdIdealsEqual(std(k),std(j)));
[d6db1f2]382}
383
[07c623]384static proc specialIdealsEqual( ideal k1, ideal k2)
[d6db1f2]385{
[70ab73]386  int j;
[d6db1f2]387
[70ab73]388  if(size(k1)==size(k2))
389  {
390    for(j=1;j<=size(k1);j++)
391    {
392      if(leadexp(k1[j])!=leadexp(k2[j]))
[d6db1f2]393      {
[70ab73]394        return(0);
[d6db1f2]395      }
[70ab73]396    }
397    return(1);
398  }
399  return(0);
[d6db1f2]400}
401
[07c623]402static proc stdIdealsEqual( ideal k1, ideal k2)
[d6db1f2]403{
[70ab73]404  int j;
[d6db1f2]405
[70ab73]406  if(size(k1)==size(k2))
407  {
408    for(j=1;j<=size(k1);j++)
409    {
410      if(leadexp(k1[j])!=leadexp(k2[j]))
[d6db1f2]411      {
[70ab73]412        return(0);
[d6db1f2]413      }
[70ab73]414    }
415    attrib(k2,"isSB",1);
416    if(size(reduce(k1,k2,1))==0)
417    {
418      return(1);
419    }
420  }
421  return(0);
[d6db1f2]422}
[091424]423///////////////////////////////////////////////////////////////////////////////
[d6db1f2]424
[50cbdc]425proc primaryTest (ideal i, poly p)
[d6db1f2]426{
[70ab73]427  int m=1;
428  int n=nvars(basering);
429  int e,f;
430  poly t;
431  ideal h;
432  list act;
[d6db1f2]433
[70ab73]434  ideal prm=p;
435  attrib(prm,"isSB",1);
[d6db1f2]436
[70ab73]437  while (n>1)
438  {
439    n--;
440    m++;
[d6db1f2]441
[70ab73]442    //search for i[m] which has a power of var(n) as leading term
443    if (n==1)
444    {
445      m=size(i);
446    }
447    else
448    {
449      while (lead(i[m])/var(n-1)==0)
[d6db1f2]450      {
[70ab73]451        m++;
[d6db1f2]452      }
[70ab73]453      m--;
454    }
455    //check whether i[m] =(c*var(n)+h)^e modulo prm for some
456    //h in K[var(n+1),...,var(nvars(basering))], c in K
457    //if not (0) is returned, else var(n)+h is added to prm
458
459    e=deg(lead(i[m]));
460    if(char(basering)!=0)
461    {
462      f=1;
463      if(e mod char(basering)==0)
[d6db1f2]464      {
[70ab73]465        if ( voice >=15 )
[d6db1f2]466        {
[70ab73]467          "// WARNING: The characteristic is perhaps too small to use";
468          "// the algorithm of Gianni/Trager/Zacharias.";
469          "// This may result in an infinte loop";
470          "// loop in primaryTest, voice:",voice;"";
471        }
472        while(e mod char(basering)==0)
473        {
474          f=f*char(basering);
475          e=e/char(basering);
[a3432c]476        }
[971ba6f]477      }
[70ab73]478      t=leadcoef(i[m])*e*var(n)^f+(i[m]-lead(i[m]))/var(n)^((e-1)*f);
479      i[m]=poly(e)^e*leadcoef(i[m])^(e-1)*i[m];
480      if (reduce(i[m]-t^e,prm,1) !=0)
481      {
482        return(ideal(0));
483      }
484      if(f>1)
485      {
486        act=factorize(t);
487        if(size(act[1])>2)
488        {
489          return(ideal(0));
490        }
491        if(deg(act[1][2])>1)
492        {
493          return(ideal(0));
494        }
495        t=act[1][2];
496      }
497    }
498    else
499    {
500      t=leadcoef(i[m])*e*var(n)+(i[m]-lead(i[m]))/var(n)^(e-1);
501      i[m]=poly(e)^e*leadcoef(i[m])^(e-1)*i[m];
502      if (reduce(i[m]-t^e,prm,1) !=0)
[a3432c]503      {
[70ab73]504        return(ideal(0));
[a3432c]505      }
[70ab73]506    }
[6ffa84]507
[70ab73]508    h=interred(t);
509    t=h[1];
[d6db1f2]510
[70ab73]511    prm = prm,t;
512    attrib(prm,"isSB",1);
513  }
514  return(prm);
[d6db1f2]515}
516
[d12f079]517///////////////////////////////////////////////////////////////////////////////
518proc gcdTest(ideal act)
519{
520  int i,j;
521  if(size(act)<=1)
522  {
[70ab73]523    return(0);
[d12f079]524  }
525  for (i=1;i<=size(act)-1;i++)
526  {
[70ab73]527    for(j=i+1;j<=size(act);j++)
528    {
529      if(deg(std(ideal(act[i],act[j]))[1])>0)
530      {
531        return(0);
532      }
533    }
[d12f079]534  }
535  return(1);
536}
[d6db1f2]537
538///////////////////////////////////////////////////////////////////////////////
[07c623]539static proc splitPrimary(list l,ideal ser,int @wr,list sact)
[d6db1f2]540{
[70ab73]541  int i,j,k,s,r,w;
542  list keepresult,act,keepprime;
543  poly @f;
544  int sl=size(l);
545  for(i=1;i<=sl/2;i++)
546  {
547    if(sact[2][i]>1)
548    {
549      keepprime[i]=l[2*i-1]+ideal(sact[1][i]);
550    }
551    else
552    {
553      keepprime[i]=l[2*i-1];
554    }
555  }
556  i=0;
557  while(i<size(l)/2)
558  {
559    i++;
560    if((size(ser)>0)&&(size(reduce(ser,l[2*i-1],1))==0))
561    {
562      l[2*i-1]=ideal(1);
563      l[2*i]=ideal(1);
564      continue;
565    }
566
567    if(size(l[2*i])==0)
568    {
569      if(homog(l[2*i-1])==1)
[d6db1f2]570      {
[70ab73]571        l[2*i]=maxideal(1);
572        continue;
[d6db1f2]573      }
[70ab73]574      j=0;
575/*
576      if(i<=sl/2)
[d6db1f2]577      {
[70ab73]578        j=1;
[d6db1f2]579      }
[70ab73]580*/
581      while(j<size(l[2*i-1]))
[d6db1f2]582      {
[70ab73]583        j++;
584        act=factor(l[2*i-1][j]);
585        r=size(act[1]);
586        attrib(l[2*i-1],"isSB",1);
587        if((r==1)&&(vdim(l[2*i-1])==deg(l[2*i-1][j])))
588        {
589          l[2*i]=std(l[2*i-1],act[1][1]);
590          break;
591        }
592        if((r==1)&&(act[2][1]>1))
593        {
594          keepprime[i]=interred(keepprime[i]+ideal(act[1][1]));
595          if(homog(keepprime[i])==1)
596          {
[d6db1f2]597            l[2*i]=maxideal(1);
[70ab73]598            break;
599          }
600        }
601        if(gcdTest(act[1])==1)
602        {
603          for(k=2;k<=r;k++)
604          {
605            keepprime[size(l)/2+k-1]=interred(keepprime[i]+ideal(act[1][k]));
606          }
607          keepprime[i]=interred(keepprime[i]+ideal(act[1][1]));
608          for(k=1;k<=r;k++)
609          {
610            if(@wr==0)
611            {
612              keepresult[k]=std(l[2*i-1],act[1][k]^act[2][k]);
613            }
614            else
615            {
616              keepresult[k]=std(l[2*i-1],act[1][k]);
617            }
618          }
619          l[2*i-1]=keepresult[1];
620          if(vdim(keepresult[1])==deg(act[1][1]))
621          {
622            l[2*i]=keepresult[1];
623          }
624          if((homog(keepresult[1])==1)||(homog(keepprime[i])==1))
625          {
626            l[2*i]=maxideal(1);
627          }
628          s=size(l)-2;
629          for(k=2;k<=r;k++)
630          {
631            l[s+2*k-1]=keepresult[k];
632            keepprime[s/2+k]=interred(keepresult[k]+ideal(act[1][k]));
633            if(vdim(keepresult[k])==deg(act[1][k]))
634            {
635              l[s+2*k]=keepresult[k];
636            }
637            else
638            {
639              l[s+2*k]=ideal(0);
640            }
641            if((homog(keepresult[k])==1)||(homog(keepprime[s/2+k])==1))
642            {
643              l[s+2*k]=maxideal(1);
644            }
645          }
646          i--;
647          break;
648        }
649        if(r>=2)
650        {
651          s=size(l);
652          @f=act[1][1];
653          act=sat1(l[2*i-1],act[1][1]);
654          if(deg(act[1][1])>0)
655          {
656            l[s+1]=std(l[2*i-1],act[2]);
657            if(homog(l[s+1])==1)
658            {
659              l[s+2]=maxideal(1);
660            }
661            else
662            {
663              l[s+2]=ideal(0);
[d6db1f2]664            }
[70ab73]665            keepprime[s/2+1]=interred(keepprime[i]+ideal(@f));
666            if(homog(keepprime[s/2+1])==1)
[18dd47]667            {
[70ab73]668              l[s+2]=maxideal(1);
[d6db1f2]669            }
[70ab73]670            keepprime[i]=act[1];
671            l[2*i-1]=act[1];
672            attrib(l[2*i-1],"isSB",1);
673            if(homog(l[2*i-1])==1)
[d6db1f2]674            {
[70ab73]675              l[2*i]=maxideal(1);
[d6db1f2]676            }
[70ab73]677            i--;
678            break;
679          }
680        }
[d6db1f2]681      }
[70ab73]682    }
683  }
684  if(sl==size(l))
685  {
686    return(l);
687  }
688  for(i=1;i<=size(l)/2;i++)
689  {
690    attrib(l[2*i-1],"isSB",1);
[3939bc]691
[70ab73]692    if((size(ser)>0)&&(size(reduce(ser,l[2*i-1],1))==0)&&(deg(l[2*i-1][1])>0))
693    {
694      "Achtung in split";
[3939bc]695
[70ab73]696      l[2*i-1]=ideal(1);
697      l[2*i]=ideal(1);
698    }
699    if((size(l[2*i])==0)&&(specialIdealsEqual(keepprime[i],l[2*i-1])!=1))
700    {
701      keepprime[i]=std(keepprime[i]);
702      if(homog(keepprime[i])==1)
703      {
704        l[2*i]=maxideal(1);
[d6db1f2]705      }
[70ab73]706      else
707      {
708        act=zero_decomp(keepprime[i],ideal(0),@wr,1);
709        if(size(act)==2)
710        {
711          l[2*i]=act[2];
712        }
713      }
714    }
715  }
716  return(l);
[d6db1f2]717}
718example
719{ "EXAMPLE:"; echo=2;
720   ring  r = 32003,(x,y,z),lp;
721   ideal i1=x*(x+1),yz,(z+1)*(z-1);
722   ideal i2=xy,yz,(x-2)*(x+3);
723   list l=i1,ideal(0),i2,ideal(0),i2,ideal(1);
724   list l1=splitPrimary(l,ideal(0),0);
725   l1;
726}
[651953]727///////////////////////////////////////////////////////////////////////////////
[07c623]728static proc splitCharp(list l)
[651953]729{
730  if((char(basering)==0)||(npars(basering)>0))
731  {
[70ab73]732    return(l);
[651953]733  }
734  def P=basering;
[24f458]735  int i,j,k,m,q,d,o;
[651953]736  int n=nvars(basering);
737  ideal s,t,u,sact;
738  poly ni;
739  string minp,gnir,va;
[24f458]740  list sa,keep,rp,keep1;
[651953]741  for(i=1;i<=size(l)/2;i++)
742  {
743    if(size(l[2*i])==0)
744    {
[70ab73]745      if(deg(l[2*i-1][1])==vdim(l[2*i-1]))
746      {
747        l[2*i]=l[2*i-1];
748      }
[651953]749    }
750  }
751  for(i=1;i<=size(l)/2;i++)
752  {
753    if(size(l[2*i])==0)
754    {
[24f458]755      s=factorize(l[2*i-1][1],1);   //vermeiden!!!
[651953]756      t=l[2*i-1];
757      m=size(t);
758      ni=s[1];
759      if(deg(ni)>1)
760      {
761        va=varstr(P);
762        j=size(va);
763        while(va[j]!=","){j--;}
764        va=va[1..j-1];
[24f458]765        gnir="ring RL=("+string(char(P))+","+string(var(n))+"),("+va+"),lp;";
[651953]766        execute(gnir);
767        minpoly=leadcoef(imap(P,ni));
768        ideal act;
769        ideal t=imap(P,t);
[24f458]770
[651953]771        for(k=2;k<=m;k++)
[b9b906]772        {
[70ab73]773          act=factorize(t[k],1);
774          if(size(act)>1){break;}
[651953]775        }
776        setring P;
777        sact=imap(RL,act);
[24f458]778
[651953]779        if(size(sact)>1)
780        {
[70ab73]781          sa=sat1(l[2*i-1],sact[1]);
782          keep[size(keep)+1]=std(l[2*i-1],sa[2]);
783          l[2*i-1]=std(sa[1]);
784          l[2*i]=primaryTest(sa[1],sa[1][1]);
[651953]785        }
[24f458]786        if((size(sact)==1)&&(m==2))
787        {
[70ab73]788          l[2*i]=l[2*i-1];
789          attrib(l[2*i],"isSB",1);
[24f458]790        }
791        if((size(sact)==1)&&(m>2))
792        {
[70ab73]793          setring RL;
794          option(redSB);
795          t=std(t);
796
797          list sp=zero_decomp(t,0,0);
798
799          setring P;
800          rp=imap(RL,sp);
801          for(o=1;o<=size(rp);o++)
802          {
803            rp[o]=interred(simplify(rp[o],1)+ideal(ni));
804          }
805          l[2*i-1]=rp[1];
806          l[2*i]=rp[2];
807          rp=delete(rp,1);
808          rp=delete(rp,1);
809          keep1=keep1+rp;
810          option(noredSB);
[24f458]811        }
812        kill RL;
[651953]813      }
814    }
815  }
816  if(size(keep)>0)
817  {
818    for(i=1;i<=size(keep);i++)
819    {
[70ab73]820      if(deg(keep[i][1])>0)
821      {
822        l[size(l)+1]=keep[i];
823        l[size(l)+1]=primaryTest(keep[i],keep[i][1]);
824      }
[651953]825    }
826  }
[24f458]827  l=l+keep1;
[651953]828  return(l);
829}
[d6db1f2]830
[091424]831///////////////////////////////////////////////////////////////////////////////
[d6db1f2]832
[24f458]833proc zero_decomp (ideal j,ideal ser,int @wr,list #)
[d2b2a7]834"USAGE:   zero_decomp(j,ser,@wr); j,ser ideals, @wr=0 or 1
[7f7c25e]835         (@wr=0 for primary decomposition, @wr=1 for computation of associated
[d6db1f2]836         primes)
837RETURN:  list = list of primary ideals and their radicals (at even positions
838         in the list) if the input is zero-dimensional and a standardbases
839         with respect to lex-ordering
840         If ser!=(0) and ser is contained in j or if j is not zero-dimen-
841         sional then ideal(1),ideal(1) is returned
[7b3971]842NOTE:    Algorithm of Gianni/Trager/Zacharias
[d6db1f2]843EXAMPLE: example zero_decomp; shows an example
[d2b2a7]844"
[d6db1f2]845{
846  def   @P = basering;
[20057b]847  int uytrewq;
[d6db1f2]848  int nva = nvars(basering);
[e801fe]849  int @k,@s,@n,@k1,zz;
[a39a07]850  list primary,lres0,lres1,act,@lh,@wh;
[e801fe]851  map phi,psi,phi1,psi1;
852  ideal jmap,jmap1,jmap2,helpprim,@qh,@qht,ser1;
[d6db1f2]853  intvec @vh,@hilb;
854  string @ri;
855  poly @f;
856  if (dim(j)>0)
857  {
[70ab73]858    primary[1]=ideal(1);
859    primary[2]=ideal(1);
860    return(primary);
[d6db1f2]861  }
[a90eb0]862  intvec save=option(get);
863  option(redSB);
[3939bc]864  j=interred(j);
[0bcebab]865
[d6db1f2]866  attrib(j,"isSB",1);
[24f458]867
[d6db1f2]868  if(vdim(j)==deg(j[1]))
[3939bc]869  {
[70ab73]870    act=factor(j[1]);
871    for(@k=1;@k<=size(act[1]);@k++)
872    {
873      @qh=j;
874      if(@wr==0)
875      {
876        @qh[1]=act[1][@k]^act[2][@k];
877      }
878      else
879      {
880        @qh[1]=act[1][@k];
881      }
882      primary[2*@k-1]=interred(@qh);
883      @qh=j;
884      @qh[1]=act[1][@k];
885      primary[2*@k]=interred(@qh);
886      attrib( primary[2*@k-1],"isSB",1);
[3939bc]887
[70ab73]888      if((size(ser)>0)&&(size(reduce(ser,primary[2*@k-1],1))==0))
889      {
890        primary[2*@k-1]=ideal(1);
891        primary[2*@k]=ideal(1);
892      }
893    }
[a90eb0]894    option(set,save);
[70ab73]895    return(primary);
[d6db1f2]896  }
897
[a90eb0]898  option(set,save);
[d6db1f2]899  if(homog(j)==1)
900  {
[70ab73]901    primary[1]=j;
902    if((size(ser)>0)&&(size(reduce(ser,j,1))==0))
903    {
904      primary[1]=ideal(1);
905      primary[2]=ideal(1);
906      return(primary);
907    }
908    if(dim(j)==-1)
909    {
910      primary[1]=ideal(1);
911      primary[2]=ideal(1);
912    }
913    else
914    {
915      primary[2]=maxideal(1);
916    }
917    return(primary);
[d6db1f2]918  }
[18dd47]919
[d6db1f2]920//the first element in the standardbase is factorized
921  if(deg(j[1])>0)
922  {
923    act=factor(j[1]);
924    testFactor(act,j[1]);
925  }
926  else
927  {
[70ab73]928    primary[1]=ideal(1);
929    primary[2]=ideal(1);
930    return(primary);
[d6db1f2]931  }
932
[9050ca]933//with the factors new ideals (hopefully the primary decomposition)
[d6db1f2]934//are created
935  if(size(act[1])>1)
936  {
[70ab73]937    if(size(#)>1)
938    {
939      primary[1]=ideal(1);
940      primary[2]=ideal(1);
941      primary[3]=ideal(1);
942      primary[4]=ideal(1);
943      return(primary);
944    }
945    for(@k=1;@k<=size(act[1]);@k++)
946    {
947      if(@wr==0)
948      {
949        primary[2*@k-1]=std(j,act[1][@k]^act[2][@k]);
950      }
951      else
952      {
953        primary[2*@k-1]=std(j,act[1][@k]);
954      }
955      if((act[2][@k]==1)&&(vdim(primary[2*@k-1])==deg(act[1][@k])))
956      {
[a36e78]957        primary[2*@k]   = primary[2*@k-1];
[70ab73]958      }
959      else
960      {
961        primary[2*@k]   = primaryTest(primary[2*@k-1],act[1][@k]);
962      }
963    }
[d6db1f2]964  }
965  else
[3939bc]966  {
[70ab73]967    primary[1]=j;
968    if((size(#)>0)&&(act[2][1]>1))
969    {
970      act[2]=1;
971      primary[1]=std(primary[1],act[1][1]);
972    }
973    if(@wr!=0)
974    {
975      primary[1]=std(j,act[1][1]);
976    }
977    if((act[2][1]==1)&&(vdim(primary[1])==deg(act[1][1])))
978    {
979      primary[2]=primary[1];
980    }
981    else
982    {
983      primary[2]=primaryTest(primary[1],act[1][1]);
984    }
[d6db1f2]985  }
[50cbdc]986
[d6db1f2]987  if(size(#)==0)
988  {
[70ab73]989    primary=splitPrimary(primary,ser,@wr,act);
[d6db1f2]990  }
[24f458]991
992  if((voice>=6)&&(char(basering)<=181))
993  {
[70ab73]994    primary=splitCharp(primary);
[24f458]995  }
996
997  if((@wr==2)&&(npars(basering)>0)&&(voice>=6)&&(char(basering)>0))
998  {
999  //the prime decomposition of Yokoyama in characteristic p
[70ab73]1000    list ke,ek;
1001    @k=0;
1002    while(@k<size(primary)/2)
1003    {
1004      @k++;
1005      if(size(primary[2*@k])==0)
1006      {
1007        ek=insepDecomp(primary[2*@k-1]);
1008        primary=delete(primary,2*@k);
1009        primary=delete(primary,2*@k-1);
1010        @k--;
1011      }
1012      ke=ke+ek;
1013    }
1014    for(@k=1;@k<=size(ke);@k++)
1015    {
1016      primary[size(primary)+1]=ke[@k];
1017      primary[size(primary)+1]=ke[@k];
1018    }
[24f458]1019  }
1020
[0266ac]1021  if(voice>=8){primary=extF(primary);};
[24f458]1022
[d6db1f2]1023//test whether all ideals in the decomposition are primary and
1024//in general position
1025//if not after a random coordinate transformation of the last
1026//variable the corresponding ideal is decomposed again.
[24f458]1027  if((npars(basering)>0)&&(voice>=8))
1028  {
[70ab73]1029    poly randp;
1030    for(zz=1;zz<nvars(basering);zz++)
1031    {
1032      randp=randp
[24f458]1033              +(random(0,5)*par(1)^2+random(0,5)*par(1)+random(0,5))*var(zz);
[70ab73]1034    }
1035    randp=randp+var(nvars(basering));
[24f458]1036  }
[d6db1f2]1037  @k=0;
[67bd4c]1038  while(@k<(size(primary)/2))
[d6db1f2]1039  {
1040    @k++;
1041    if (size(primary[2*@k])==0)
1042    {
[70ab73]1043      for(zz=1;zz<size(primary[2*@k-1])-1;zz++)
1044      {
1045        attrib(primary[2*@k-1],"isSB",1);
1046        if(vdim(primary[2*@k-1])==deg(primary[2*@k-1][zz]))
1047        {
1048          primary[2*@k]=primary[2*@k-1];
1049        }
1050      }
[67bd4c]1051    }
1052  }
[3939bc]1053
[67bd4c]1054  @k=0;
[e801fe]1055  ideal keep;
[67bd4c]1056  while(@k<(size(primary)/2))
1057  {
1058    @k++;
1059    if (size(primary[2*@k])==0)
1060    {
[70ab73]1061      jmap=randomLast(100);
1062      jmap1=maxideal(1);
1063      jmap2=maxideal(1);
1064      @qht=primary[2*@k-1];
1065      if((npars(basering)>0)&&(voice>=10))
1066      {
1067        jmap[size(jmap)]=randp;
1068      }
[67bd4c]1069
[70ab73]1070      for(@n=2;@n<=size(primary[2*@k-1]);@n++)
1071      {
1072        if(deg(lead(primary[2*@k-1][@n]))==1)
1073        {
1074          for(zz=1;zz<=nva;zz++)
[d6db1f2]1075          {
[70ab73]1076            if(lead(primary[2*@k-1][@n])/var(zz)!=0)
1077            {
1078              jmap1[zz]=-1/leadcoef(primary[2*@k-1][@n])*primary[2*@k-1][@n]
[a36e78]1079                   +2/leadcoef(primary[2*@k-1][@n])*lead(primary[2*@k-1][@n]);
[70ab73]1080              jmap2[zz]=primary[2*@k-1][@n];
1081              @qht[@n]=var(zz);
1082            }
[d6db1f2]1083          }
[70ab73]1084          jmap[nva]=subst(jmap[nva],lead(primary[2*@k-1][@n]),0);
1085        }
1086      }
1087      if(size(subst(jmap[nva],var(1),0)-var(nva))!=0)
1088      {
1089        // jmap[nva]=subst(jmap[nva],var(1),0);
1090        //hier geaendert +untersuchen!!!!!!!!!!!!!!
1091      }
1092      phi1=@P,jmap1;
1093      phi=@P,jmap;
1094      for(@n=1;@n<=nva;@n++)
1095      {
1096        jmap[@n]=-(jmap[@n]-2*var(@n));
1097      }
1098      psi=@P,jmap;
1099      psi1=@P,jmap2;
1100      @qh=phi(@qht);
[24f458]1101
1102//=================== the new part ============================
1103
[8992ed]1104      if (npars(basering)>1) { @qh=groebner(@qh,"par2var"); }
1105      else                   { @qh=groebner(@qh); }
[24f458]1106
1107//=============================================================
1108//       if(npars(@P)>0)
1109//       {
1110//          @ri= "ring @Phelp ="
1111//                  +string(char(@P))+",
1112//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
1113//       }
1114//       else
1115//       {
1116//          @ri= "ring @Phelp ="
1117//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
1118//       }
1119//       execute(@ri);
1120//       ideal @qh=homog(imap(@P,@qht),@t);
1121//
1122//       ideal @qh1=std(@qh);
1123//       @hilb=hilb(@qh1,1);
1124//       @ri= "ring @Phelp1 ="
1125//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
1126//       execute(@ri);
1127//       ideal @qh=homog(imap(@P,@qh),@t);
1128//       kill @Phelp;
1129//       @qh=std(@qh,@hilb);
1130//       @qh=subst(@qh,@t,1);
1131//       setring @P;
1132//       @qh=imap(@Phelp1,@qh);
1133//       kill @Phelp1;
1134//       @qh=clearSB(@qh);
1135//       attrib(@qh,"isSB",1);
1136//=============================================================
1137
[70ab73]1138      ser1=phi1(ser);
1139      @lh=zero_decomp (@qh,phi(ser1),@wr);
[18dd47]1140
[70ab73]1141      kill lres0;
1142      list lres0;
1143      if(size(@lh)==2)
1144      {
1145        helpprim=@lh[2];
1146        lres0[1]=primary[2*@k-1];
1147        ser1=psi(helpprim);
1148        lres0[2]=psi1(ser1);
1149        if(size(reduce(lres0[2],lres0[1],1))==0)
1150        {
1151          primary[2*@k]=primary[2*@k-1];
1152          continue;
1153        }
1154      }
1155      else
1156      {
1157        lres1=psi(@lh);
1158        lres0=psi1(lres1);
1159      }
[d6db1f2]1160
[24f458]1161//=================== the new part ============================
[d6db1f2]1162
[70ab73]1163      primary=delete(primary,2*@k-1);
1164      primary=delete(primary,2*@k-1);
1165      @k--;
1166      if(size(lres0)==2)
1167      {
[a36e78]1168        lres0[2]=groebner(lres0[2]);
[70ab73]1169      }
1170      else
1171      {
1172        for(@n=1;@n<=size(lres0)/2;@n++)
1173        {
1174          if(specialIdealsEqual(lres0[2*@n-1],lres0[2*@n])==1)
[d6db1f2]1175          {
[a36e78]1176            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
[70ab73]1177            lres0[2*@n]=lres0[2*@n-1];
1178            attrib(lres0[2*@n],"isSB",1);
[d6db1f2]1179          }
[70ab73]1180          else
1181          {
[a36e78]1182            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
1183            lres0[2*@n]=groebner(lres0[2*@n]);
[70ab73]1184          }
1185        }
1186      }
1187      primary=primary+lres0;
[18dd47]1188
[24f458]1189//=============================================================
1190//       if(npars(@P)>0)
1191//       {
1192//          @ri= "ring @Phelp ="
1193//                  +string(char(@P))+",
1194//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
1195//       }
1196//       else
1197//       {
1198//          @ri= "ring @Phelp ="
1199//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
1200//       }
1201//       execute(@ri);
1202//       list @lvec;
1203//       list @lr=imap(@P,lres0);
1204//       ideal @lr1;
1205//
1206//       if(size(@lr)==2)
1207//       {
1208//          @lr[2]=homog(@lr[2],@t);
1209//          @lr1=std(@lr[2]);
1210//          @lvec[2]=hilb(@lr1,1);
1211//       }
1212//       else
1213//       {
1214//          for(@n=1;@n<=size(@lr)/2;@n++)
1215//          {
1216//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
1217//             {
1218//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
1219//                @lr1=std(@lr[2*@n-1]);
1220//                @lvec[2*@n-1]=hilb(@lr1,1);
1221//                @lvec[2*@n]=@lvec[2*@n-1];
1222//             }
1223//             else
1224//             {
1225//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
1226//                @lr1=std(@lr[2*@n-1]);
1227//                @lvec[2*@n-1]=hilb(@lr1,1);
1228//                @lr[2*@n]=homog(@lr[2*@n],@t);
1229//                @lr1=std(@lr[2*@n]);
1230//                @lvec[2*@n]=hilb(@lr1,1);
1231//
1232//             }
1233//         }
1234//       }
1235//       @ri= "ring @Phelp1 ="
1236//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
1237//       execute(@ri);
1238//       list @lr=imap(@Phelp,@lr);
1239//
1240//       kill @Phelp;
1241//       if(size(@lr)==2)
1242//      {
1243//          @lr[2]=std(@lr[2],@lvec[2]);
1244//          @lr[2]=subst(@lr[2],@t,1);
1245//       }
1246//       else
1247//       {
1248//          for(@n=1;@n<=size(@lr)/2;@n++)
1249//          {
1250//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
1251//             {
1252//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
1253//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
1254//                @lr[2*@n]=@lr[2*@n-1];
1255//                attrib(@lr[2*@n],"isSB",1);
1256//             }
1257//             else
1258//             {
1259//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
1260//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
1261//                @lr[2*@n]=std(@lr[2*@n],@lvec[2*@n]);
1262//                @lr[2*@n]=subst(@lr[2*@n],@t,1);
1263//             }
1264//          }
1265//       }
1266//       kill @lvec;
1267//       setring @P;
1268//       lres0=imap(@Phelp1,@lr);
1269//       kill @Phelp1;
1270//       for(@n=1;@n<=size(lres0);@n++)
1271//       {
1272//          lres0[@n]=clearSB(lres0[@n]);
1273//          attrib(lres0[@n],"isSB",1);
1274//       }
1275//
1276//       primary[2*@k-1]=lres0[1];
1277//       primary[2*@k]=lres0[2];
1278//       @s=size(primary)/2;
1279//       for(@n=1;@n<=size(lres0)/2-1;@n++)
1280//       {
1281//         primary[2*@s+2*@n-1]=lres0[2*@n+1];
1282//         primary[2*@s+2*@n]=lres0[2*@n+2];
1283//       }
1284//       @k--;
1285//=============================================================
[70ab73]1286    }
[d6db1f2]1287  }
1288  return(primary);
1289}
1290example
1291{ "EXAMPLE:"; echo = 2;
1292   ring  r = 0,(x,y,z),lp;
1293   poly  p = z2+1;
1294   poly  q = z4+2;
1295   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
1296   i=std(i);
1297   list  pr= zero_decomp(i,ideal(0),0);
1298   pr;
1299}
[24f458]1300///////////////////////////////////////////////////////////////////////////////
1301proc extF(list l,list #)
1302{
1303//zero_dimensional primary decomposition after finite field extension
[70ab73]1304  def R=basering;
1305  int p=char(R);
[24f458]1306
[70ab73]1307  if((p==0)||(p>13)||(npars(R)>0)){return(l);}
[24f458]1308
[70ab73]1309  int ex=3;
1310  if(size(#)>0){ex=#[1];}
[24f458]1311
[70ab73]1312  list peek,peek1;
1313  while(size(l)>0)
1314  {
1315    if(size(l[2])==0)
1316    {
1317      peek[size(peek)+1]=l[1];
1318    }
1319    else
1320    {
1321      peek1[size(peek1)+1]=l[1];
1322      peek1[size(peek1)+1]=l[2];
1323    }
1324    l=delete(l,1);
1325    l=delete(l,1);
1326  }
1327  if(size(peek)==0){return(peek1);}
1328
1329  string gnir="ring RH=("+string(p)+"^"+string(ex)+",a),("+varstr(R)+"),lp;";
1330  execute(gnir);
1331  string mp="minpoly="+string(minpoly)+";";
1332  gnir="ring RL=("+string(p)+",a),("+varstr(R)+"),lp;";
1333  execute(gnir);
1334  execute(mp);
1335  list L=imap(R,peek);
1336  list pr, keep;
1337  int i;
1338  for(i=1;i<=size(L);i++)
1339  {
1340    attrib(L[i],"isSB",1);
1341    pr=zero_decomp(L[i],0,0);
1342    keep=keep+pr;
1343  }
1344  for(i=1;i<=size(keep);i++)
1345  {
1346    keep[i]=simplify(keep[i],1);
1347  }
1348  mp="poly pp="+string(minpoly)+";";
[24f458]1349
[70ab73]1350  string gnir1="ring RS="+string(p)+",("+varstr(R)+",a),lp;";
1351  execute(gnir1);
1352  execute(mp);
1353  list L=imap(RL,keep);
[24f458]1354
[70ab73]1355  for(i=1;i<=size(L);i++)
1356  {
1357    L[i]=eliminate(L[i]+ideal(pp),a);
1358  }
1359  i=0;
1360  int j;
1361  while(i<size(L)/2-1)
1362  {
1363    i++;
1364    j=i;
1365    while(j<size(L)/2)
1366    {
1367      j++;
1368      if(idealsEqual(L[2*i-1],L[2*j-1]))
1369      {
1370        L=delete(L,2*j-1);
1371        L=delete(L,2*j-1);
1372        j--;
[24f458]1373      }
[70ab73]1374    }
1375  }
1376  setring R;
1377  list re=imap(RS,L);
1378  re=re+peek1;
[24f458]1379
[70ab73]1380  return(extF(re,ex+1));
[24f458]1381}
1382
1383///////////////////////////////////////////////////////////////////////////////
1384proc zeroSp(ideal i)
1385{
1386//preparation for the separable closure
1387//decomposition into ideals of special type
1388//i.e. the minimal polynomials of every variable mod i are irreducible
1389//returns a list of 2 lists: rr=pe,qe
1390//the ideals in pe[l] are special, their special elements are in qe[l]
1391//pe[l] is a dp-Groebnerbasis
1392//the radical of the intersection of the pe[l] is equal to the radical of i
1393
[70ab73]1394  def R=basering;
[24f458]1395
[70ab73]1396  //i has to be a reduced groebner basis
1397  ideal F=finduni(i);
[24f458]1398
[70ab73]1399  int j,k,l,ready;
1400  list fa;
1401  fa[1]=factorize(F[1],1);
1402  poly te,ti;
1403  ideal tj;
1404  //avoid factorization of the same polynomial
1405  for(j=2;j<=size(F);j++)
1406  {
1407    for(k=1;k<=j-1;k++)
1408    {
1409      ti=F[k];
1410      te=subst(ti,var(k),var(j));
1411      if(te==F[j])
[24f458]1412      {
[70ab73]1413        tj=fa[k];
1414        fa[j]=subst(tj,var(k),var(j));
1415        ready=1;
1416        break;
[24f458]1417      }
[70ab73]1418    }
1419    if(!ready)
1420    {
1421      fa[j]=factorize(F[j],1);
1422    }
1423    ready=0;
1424  }
1425  execute( "ring P=("+charstr(R)+"),("+varstr(R)+"),(C,dp);");
1426  ideal i=imap(R,i);
1427  if(npars(basering)==0)
1428  {
1429    ideal J=fglm(R,i);
1430  }
1431  else
1432  {
[a36e78]1433    ideal J=groebner(i);
[70ab73]1434  }
1435  list fa=imap(R,fa);
1436  list qe=J;          //collects a dp-Groebnerbasis of the special ideals
1437  list keep=ideal(0); //collects the special elements
[24f458]1438
[70ab73]1439  list re,em,ke;
1440  ideal K,L;
[24f458]1441
[70ab73]1442  for(j=1;j<=nvars(basering);j++)
1443  {
1444    for(l=1;l<=size(qe);l++)
1445    {
1446      for(k=1;k<=size(fa[j]);k++)
[24f458]1447      {
[70ab73]1448        L=std(qe[l],fa[j][k]);
1449        K=keep[l],fa[j][k];
1450        if(deg(L[1])>0)
1451        {
1452          re[size(re)+1]=L;
1453          ke[size(ke)+1]=K;
1454        }
[24f458]1455      }
1456    }
[70ab73]1457    qe=re;
1458    re=em;
1459    keep=ke;
1460    ke=em;
1461  }
1462
1463  setring R;
1464  list qe=imap(P,keep);
1465  list pe=imap(P,qe);
1466  for(l=1;l<=size(qe);l++)
1467  {
1468    qe[l]=simplify(qe[l],2);
1469  }
1470  list rr=pe,qe;
1471  return(rr);
[24f458]1472}
1473///////////////////////////////////////////////////////////////////////////////
1474
1475proc zeroSepClos(ideal I,ideal F)
1476{
1477//computes the separable closure of the special ideal I
1478//F is the set of special elements of I
1479//returns the separable closure sc(I) of I and an intvec v
1480//such that sc(I)=preimage(frobenius definde by v)
1481//i.e. var(i)----->var(i)^(p^v[i])
1482
[70ab73]1483  if(homog(I)==1){return(maxideal(1));}
[24f458]1484
[70ab73]1485  //assume F[i] irreducible in I and depending only on var(i)
[24f458]1486
[70ab73]1487  def R=basering;
1488  int n=nvars(R);
1489  int p=char(R);
1490  intvec v;
1491  v[n]=0;
1492  int i,k;
1493  list l;
[24f458]1494
[70ab73]1495  for(i=1;i<=n;i++)
1496  {
1497    l[i]=sep(F[i],i);
1498    F[i]=l[i][1];
1499    if(l[i][2]>k){k=l[i][2];}
1500  }
[24f458]1501
[70ab73]1502  if(k==0){return(list(I,v));}        //the separable case
1503  ideal m;
[24f458]1504
[70ab73]1505  for(i=1;i<=n;i++)
1506  {
1507    m[i]=var(i)^(p^l[i][2]);
1508    v[i]=l[i][2];
1509  }
1510  map phi=R,m;
1511  ideal J=preimage(R,phi,I);
1512  return(list(J,v));
[24f458]1513}
1514///////////////////////////////////////////////////////////////////////////////
1515
1516proc insepDecomp(ideal i)
1517{
1518//decomposes i into special ideals
1519//computes the prime decomposition of the special ideals
1520//and transforms it back to a decomposition of i
1521
[70ab73]1522  def R=basering;
1523  list pr=zeroSp(i);
1524  int l,k;
1525  list re,wo,qr;
1526  ideal m=maxideal(1);
1527  ideal K;
1528  map phi=R,m;
1529  int p=char(R);
1530  intvec op=option(get);
1531
1532  for(l=1;l<=size(pr[1]);l++)
1533  {
1534    wo=zeroSepClos(pr[1][l],pr[2][l]);
1535    for(k=1;k<=nvars(basering);k++)
1536    {
1537      m[k]=var(k)^(p^wo[2][k]);
1538    }
1539    phi=R,m;
1540    qr=decomp(wo[1],2);
[24f458]1541
[70ab73]1542    option(redSB);
1543    for(k=1;k<=size(qr)/2;k++)
1544    {
1545      K=qr[2*k];
1546      K=phi(K);
1547      K=groebner(K);
1548      re[size(re)+1]=zeroRad(K);
1549    }
1550    option(noredSB);
1551  }
1552  option(set,op);
1553  return(re);
[24f458]1554}
1555
1556
[67bd4c]1557///////////////////////////////////////////////////////////////////////////////
1558
[07c623]1559static proc clearSB (ideal i,list #)
[d2b2a7]1560"USAGE:   clearSB(i); i ideal which is SB ordered by monomial ordering
[d6db1f2]1561RETURN:  ideal = minimal SB
[18dd47]1562NOTE:
[d6db1f2]1563EXAMPLE: example clearSB; shows an example
[d2b2a7]1564"
[d6db1f2]1565{
1566  int k,j;
1567  poly m;
1568  int c=size(i);
[18dd47]1569
[d6db1f2]1570  if(size(#)==0)
1571  {
1572    for(j=1;j<c;j++)
1573    {
1574      if(deg(i[j])==0)
1575      {
1576        i=ideal(1);
1577        return(i);
[18dd47]1578      }
[d6db1f2]1579      if(deg(i[j])>0)
1580      {
1581        m=lead(i[j]);
1582        for(k=j+1;k<=c;k++)
1583        {
[70ab73]1584          if(size(lead(i[k])/m)>0)
1585          {
1586            i[k]=0;
1587          }
[d6db1f2]1588        }
1589      }
1590    }
1591  }
1592  else
1593  {
1594    j=0;
1595    while(j<c-1)
1596    {
1597      j++;
1598      if(deg(i[j])==0)
1599      {
1600        i=ideal(1);
1601        return(i);
[18dd47]1602      }
[d6db1f2]1603      if(deg(i[j])>0)
1604      {
1605        m=lead(i[j]);
1606        for(k=j+1;k<=c;k++)
1607        {
[70ab73]1608          if(size(lead(i[k])/m)>0)
1609          {
1610            if((leadexp(m)!=leadexp(i[k]))||(#[j]<=#[k]))
1611            {
1612              i[k]=0;
1613            }
1614            else
1615            {
1616              i[j]=0;
1617              break;
1618            }
1619          }
[d6db1f2]1620        }
1621      }
1622    }
1623  }
1624  return(simplify(i,2));
1625}
1626example
1627{ "EXAMPLE:"; echo = 2;
1628   ring  r = (0,a,b),(x,y,z),dp;
1629   ideal i=ax2+y,a2x+y,bx;
1630   list l=1,2,1;
1631   ideal j=clearSB(i,l);
1632   j;
1633}
1634
[f54c83]1635///////////////////////////////////////////////////////////////////////////////
1636static proc clearSBNeu (ideal i,list #)
1637"USAGE:   clearSB(i); i ideal which is SB ordered by monomial ordering
1638RETURN:  ideal = minimal SB
1639NOTE:
1640EXAMPLE: example clearSB; shows an example
1641"
1642{
[a36e78]1643 int k,j;
1644 intvec m,n,v,w;
1645 int c=size(i);
1646 w=leadexp(0);
1647 v[size(i)]=0;
1648
1649 j=0;
1650 while(j<c-1)
1651 {
1652   j++;
1653   if(deg(i[j])>=0)
1654   {
[f54c83]1655      m=leadexp(i[j]);
1656      for(k=j+1;k<=c;k++)
1657      {
1658        n=leadexp(i[k]);
1659        if(n!=w)
1660        {
[a36e78]1661           if(((m==n)&&(#[j]>#[k]))||((teilt(n,m))&&(n!=m)))
1662           {
1663             i[j]=0;
1664             v[j]=1;
1665             break;
1666           }
1667           if(((m==n)&&(#[j]<=#[k]))||((teilt(m,n))&&(n!=m)))
1668           {
1669             i[k]=0;
1670             v[k]=1;
1671           }
[f54c83]1672        }
1673      }
1674    }
1675  }
1676  return(v);
1677}
1678
1679static proc teilt(intvec a, intvec b)
1680{
[70ab73]1681  int i;
1682  for(i=1;i<=size(a);i++)
1683  {
1684    if(a[i]>b[i]){return(0);}
1685  }
1686  return(1);
[f54c83]1687}
[d6db1f2]1688///////////////////////////////////////////////////////////////////////////////
1689
[07c623]1690static proc independSet (ideal j)
[d2b2a7]1691"USAGE:   independentSet(i); i ideal
[d6db1f2]1692RETURN:  list = new varstring with the independent set at the end,
1693                ordstring with the corresponding block ordering,
1694                the integer where the independent set starts in the varstring
[18dd47]1695NOTE:
[d6db1f2]1696EXAMPLE: example independentSet; shows an example
[d2b2a7]1697"
[d6db1f2]1698{
[70ab73]1699  int n,k,di;
1700  list resu,hilf;
1701  string var1,var2;
1702  list v=indepSet(j,1);
[18dd47]1703
[70ab73]1704  for(n=1;n<=size(v);n++)
1705  {
1706    di=0;
1707    var1="";
1708    var2="";
1709    for(k=1;k<=size(v[n]);k++)
1710    {
1711      if(v[n][k]!=0)
1712      {
1713        di++;
1714        var2=var2+"var("+string(k)+"),";
[d6db1f2]1715      }
1716      else
1717      {
[70ab73]1718        var1=var1+"var("+string(k)+"),";
[d6db1f2]1719      }
[70ab73]1720    }
1721    if(di>0)
1722    {
1723      var1=var1+var2;
1724      var1=var1[1..size(var1)-1];
1725      hilf[1]=var1;
1726      hilf[2]="lp";
1727      //"lp("+string(nvars(basering)-di)+"),dp("+string(di)+")";
1728      hilf[3]=di;
1729      resu[n]=hilf;
1730    }
1731    else
1732    {
1733      resu[n]=varstr(basering),ordstr(basering),0;
1734    }
1735  }
1736  return(resu);
[d6db1f2]1737}
1738example
1739{ "EXAMPLE:"; echo = 2;
1740   ring s1=(0,x,y),(a,b,c,d,e,f,g),lp;
1741   ideal i=ea-fbg,fa+be,ec-fdg,fc+de;
1742   i=std(i);
1743   list  l=independSet(i);
1744   l;
1745   i=i,g;
1746   l=independSet(i);
1747   l;
1748
1749   ring s=0,(x,y,z),lp;
1750   ideal i=z,yx;
1751   list l=independSet(i);
1752   l;
1753
1754
1755}
1756///////////////////////////////////////////////////////////////////////////////
1757
[07c623]1758static proc maxIndependSet (ideal j)
[d2b2a7]1759"USAGE:   maxIndependentSet(i); i ideal
[d6db1f2]1760RETURN:  list = new varstring with the maximal independent set at the end,
1761                ordstring with the corresponding block ordering,
1762                the integer where the independent set starts in the varstring
[18dd47]1763NOTE:
[d6db1f2]1764EXAMPLE: example maxIndependentSet; shows an example
[d2b2a7]1765"
[d6db1f2]1766{
[70ab73]1767  int n,k,di;
1768  list resu,hilf;
1769  string var1,var2;
1770  list v=indepSet(j,0);
[18dd47]1771
[70ab73]1772  for(n=1;n<=size(v);n++)
1773  {
1774    di=0;
1775    var1="";
1776    var2="";
1777    for(k=1;k<=size(v[n]);k++)
1778    {
1779      if(v[n][k]!=0)
1780      {
1781        di++;
1782        var2=var2+"var("+string(k)+"),";
[d6db1f2]1783      }
1784      else
1785      {
[70ab73]1786        var1=var1+"var("+string(k)+"),";
[d6db1f2]1787      }
[70ab73]1788    }
1789    if(di>0)
1790    {
1791      var1=var1+var2;
1792      var1=var1[1..size(var1)-1];
1793      hilf[1]=var1;
1794      hilf[2]="lp";
1795      hilf[3]=di;
1796      resu[n]=hilf;
1797    }
1798    else
1799    {
1800      resu[n]=varstr(basering),ordstr(basering),0;
1801    }
1802  }
1803  return(resu);
[d6db1f2]1804}
1805example
1806{ "EXAMPLE:"; echo = 2;
1807   ring s1=(0,x,y),(a,b,c,d,e,f,g),lp;
1808   ideal i=ea-fbg,fa+be,ec-fdg,fc+de;
1809   i=std(i);
1810   list  l=maxIndependSet(i);
1811   l;
1812   i=i,g;
1813   l=maxIndependSet(i);
1814   l;
1815
1816   ring s=0,(x,y,z),lp;
1817   ideal i=z,yx;
1818   list l=maxIndependSet(i);
1819   l;
1820
1821
1822}
1823
1824///////////////////////////////////////////////////////////////////////////////
1825
[07c623]1826static proc prepareQuotientring (int nnp)
[d2b2a7]1827"USAGE:   prepareQuotientring(nnp); nnp int
[d6db1f2]1828RETURN:  string = to define Kvar(nnp+1),...,var(nvars)[..rest ]
[18dd47]1829NOTE:
[d6db1f2]1830EXAMPLE: example independentSet; shows an example
[d2b2a7]1831"
[18dd47]1832{
[d6db1f2]1833  ideal @ih,@jh;
1834  int npar=npars(basering);
1835  int @n;
[18dd47]1836
[d6db1f2]1837  string quotring= "ring quring = ("+charstr(basering);
1838  for(@n=nnp+1;@n<=nvars(basering);@n++)
1839  {
[a36e78]1840     quotring=quotring+",var("+string(@n)+")";
1841     @ih=@ih+var(@n);
[d6db1f2]1842  }
[18dd47]1843
[d6db1f2]1844  quotring=quotring+"),(var(1)";
1845  @jh=@jh+var(1);
1846  for(@n=2;@n<=nnp;@n++)
1847  {
1848    quotring=quotring+",var("+string(@n)+")";
1849    @jh=@jh+var(@n);
1850  }
[e801fe]1851  quotring=quotring+"),(C,lp);";
[18dd47]1852
[d6db1f2]1853  return(quotring);
1854
1855}
1856example
1857{ "EXAMPLE:"; echo = 2;
1858   ring s1=(0,x),(a,b,c,d,e,f,g),lp;
1859   def @Q=basering;
1860   list l= prepareQuotientring(3);
1861   l;
[2d2cad9]1862   execute(l[1]);
1863   execute(l[2]);
[d6db1f2]1864   basering;
1865   phi;
1866   setring @Q;
[18dd47]1867
[d6db1f2]1868}
1869
[091424]1870///////////////////////////////////////////////////////////////////////////////
[07c623]1871static proc cleanPrimary(list l)
[d6db1f2]1872{
[a36e78]1873   int i,j;
1874   list lh;
1875   for(i=1;i<=size(l)/2;i++)
1876   {
1877      if(deg(l[2*i-1][1])>0)
1878      {
1879         j++;
1880         lh[j]=l[2*i-1];
1881         j++;
1882         lh[j]=l[2*i];
1883      }
1884   }
1885   return(lh);
[d6db1f2]1886}
1887///////////////////////////////////////////////////////////////////////////////
1888
[840745]1889
1890proc minAssPrimesold(ideal i, list #)
[d2b2a7]1891"USAGE:   minAssPrimes(i); i ideal
[d6db1f2]1892         minAssPrimes(i,1); i ideal  (to use also the factorizing Groebner)
1893RETURN:  list = the minimal associated prime ideals of i
1894EXAMPLE: example minAssPrimes; shows an example
[d2b2a7]1895"
[d6db1f2]1896{
[a36e78]1897   def @P=basering;
1898   if(size(i)==0){return(list(ideal(0)));}
1899   list qr=simplifyIdeal(i);
1900   map phi=@P,qr[2];
1901   i=qr[1];
[3939bc]1902
[a36e78]1903   execute ("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),("
[2d2cad9]1904             +ordstr(basering)+");");
[67bd4c]1905
1906
[a36e78]1907   ideal i=fetch(@P,i);
1908   if(size(#)==0)
1909   {
1910      int @wr;
1911      list tluser,@res;
1912      list primary=decomp(i,2);
[d6db1f2]1913
[a36e78]1914      @res[1]=primary;
[d6db1f2]1915
[a36e78]1916      tluser=union(@res);
1917      setring @P;
1918      list @res=imap(gnir,tluser);
1919      return(phi(@res));
1920   }
1921   list @res,empty;
1922   ideal ser;
1923   option(redSB);
1924   list @pr=facstd(i);
1925   //if(size(@pr)==1)
[17407e]1926//   {
1927//      attrib(@pr[1],"isSB",1);
1928//      if((dim(@pr[1])==0)&&(homog(@pr[1])==1))
1929//      {
1930//         setring @P;
1931//         list @res=maxideal(1);
1932//         return(phi(@res));
1933//      }
1934//      if(dim(@pr[1])>1)
1935//      {
1936//         setring @P;
1937//        // kill gnir;
1938//         execute ("ring gnir1 = ("+charstr(basering)+"),
1939//                              ("+varstr(basering)+"),(C,lp);");
1940//         ideal i=fetch(@P,i);
1941//         list @pr=facstd(i);
1942//        // ideal ser;
1943//         setring gnir;
1944//         @pr=fetch(gnir1,@pr);
1945//         kill gnir1;
1946//      }
1947//   }
[a36e78]1948    option(noredSB);
1949   int j,k,odim,ndim,count;
1950   attrib(@pr[1],"isSB",1);
1951   if(#[1]==77)
1952   {
1953     odim=dim(@pr[1]);
1954     count=1;
1955     intvec pos;
1956     pos[size(@pr)]=0;
1957     for(j=2;j<=size(@pr);j++)
1958     {
1959        attrib(@pr[j],"isSB",1);
1960        ndim=dim(@pr[j]);
1961        if(ndim>odim)
[80b3cd]1962        {
[a36e78]1963           for(k=count;k<=j-1;k++)
1964           {
1965              pos[k]=1;
1966           }
1967           count=j;
1968           odim=ndim;
[80b3cd]1969        }
[a36e78]1970        if(ndim<odim)
1971        {
1972           pos[j]=1;
1973        }
1974     }
1975     for(j=1;j<=size(@pr);j++)
1976     {
1977        if(pos[j]!=1)
1978        {
1979            @res[j]=decomp(@pr[j],2);
1980        }
1981        else
1982        {
1983           @res[j]=empty;
1984        }
1985     }
1986   }
1987   else
1988   {
1989     ser=ideal(1);
1990     for(j=1;j<=size(@pr);j++)
1991     {
[e801fe]1992//@pr[j];
[917fb5]1993//pause();
[a36e78]1994        @res[j]=decomp(@pr[j],2);
[e801fe]1995//       @res[j]=decomp(@pr[j],2,@pr[j],ser);
1996//       for(k=1;k<=size(@res[j]);k++)
1997//       {
[d950c5]1998//          ser=intersect(ser,@res[j][k]);
[e801fe]1999//       }
[a36e78]2000     }
2001   }
[d6db1f2]2002
[a36e78]2003   @res=union(@res);
2004   setring @P;
2005   list @res=imap(gnir,@res);
2006   return(phi(@res));
[d6db1f2]2007}
2008example
2009{ "EXAMPLE:"; echo = 2;
2010   ring  r = 32003,(x,y,z),lp;
2011   poly  p = z2+1;
2012   poly  q = z4+2;
2013   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
[091424]2014   list pr= minAssPrimes(i);  pr;
2015
[9050ca]2016   minAssPrimes(i,1);
[d6db1f2]2017}
2018
[24f458]2019static proc primT(ideal i)
2020{
[a36e78]2021   //assumes that all generators of i are irreducible
2022   //i is standard basis
[840745]2023
[a36e78]2024   attrib(i,"isSB",1);
2025   int j=size(i);
2026   int k;
2027   while(j>0)
2028   {
2029     if(deg(i[j])>1){break;}
2030     j--;
2031   }
2032   if(j==0){return(1);}
2033   if(deg(i[j])==vdim(i)){return(1);}
2034   return(0);
[24f458]2035}
[840745]2036
2037static proc minAssPrimes(ideal i, list #)
2038"USAGE:   minAssPrimes(i); i ideal
[808a9f3]2039      Optional parameters in list #: (can be entered in any order)
2040      0, "facstd"   ->   uses facstd to first decompose the ideal
2041      1, "noFacstd" ->  does not use facstd (default)
2042      "SL" ->     the new algorithm is used (default)
2043      "GTZ" ->     the old algorithm is used
[840745]2044RETURN:  list = the minimal associated prime ideals of i
2045EXAMPLE: example minAssPrimes; shows an example
2046"
2047{
[70ab73]2048  if(size(i) == 0){return(list(ideal(0)));}
2049  string algorithm;    // Algorithm to be used
2050  string facstdOption;    // To uses proc facstd
2051  int j;          // Counter
2052  def P0 = basering;
2053  list Pl=ringlist(P0);
2054  intvec dp_w;
2055  for(j=nvars(P0);j>0;j--) {dp_w[j]=1;}
2056  Pl[3]=list(list("dp",dp_w),list("C",0));
2057  def P=ring(Pl);
2058  setring P;
2059  ideal i=imap(P0,i);
[24f458]2060
[70ab73]2061  // Set input parameters
2062  algorithm = "SL";         // Default: SL algorithm
[fc1526c]2063  facstdOption = "Facstd";    // Default: facstd is not used
[70ab73]2064  if(size(#) > 0)
2065  {
2066    int valid;
2067    for(j = 1; j <= size(#); j++)
2068    {
2069      valid = 0;
2070      if((typeof(#[j]) == "int") or (typeof(#[j]) == "number"))
[f54c83]2071      {
[70ab73]2072        if (#[j] == 0) {facstdOption = "noFacstd"; valid = 1;}    // If #[j] == 0, facstd is not used.
2073        if (#[j] == 1) {facstdOption = "facstd";   valid = 1;}    // If #[j] == 1, facstd is used.
[f54c83]2074      }
[70ab73]2075      if(typeof(#[j]) == "string")
[f54c83]2076      {
[70ab73]2077        if(#[j] == "GTZ" || #[j] == "SL")
2078        {
2079          algorithm = #[j];
2080          valid = 1;
2081        }
2082        if(#[j] == "noFacstd" || #[j] == "facstd")
2083        {
2084          facstdOption = #[j];
2085          valid = 1;
2086        }
[f54c83]2087      }
[70ab73]2088      if(valid == 0)
[24a90ca]2089      {
[70ab73]2090        dbprint(1, "Warning! The following input parameter was not recognized:", #[j]);
[7f7c25e]2091      }
[70ab73]2092    }
2093  }
[4d63da]2094
[70ab73]2095  list q = simplifyIdeal(i);
2096  list re = maxideal(1);
2097  int a, k;
2098  intvec op = option(get);
2099  map phi = P,q[2];
2100
2101  list result;
2102
2103  if(npars(P) == 0){option(redSB);}
2104
2105  if(attrib(i,"isSB")!=1)
2106  {
2107    i=groebner(q[1]);
2108  }
2109  else
2110  {
2111    for(j=1;j<=nvars(basering);j++)
2112    {
2113      if(q[2][j]!=var(j)){k=1;break;}
2114    }
2115    if(k)
2116    {
2117      i=groebner(q[1]);
2118    }
2119  }
2120
2121  if(dim(i) == -1){setring P0;return(ideal(1));}
2122  if((dim(i) == 0) && (npars(P) == 0))
2123  {
2124    int di = vdim(i);
2125    execute ("ring gnir=("+charstr(P)+"),("+varstr(P)+"),lp;");
2126    ideal J = std(imap(P,i));
2127    attrib(J, "isSB", 1);
2128    if(vdim(J) != di)
2129    {
2130      J = fglm(P, i);
2131    }
[b0db25]2132//    list pr = triangMH(J,2); HIER KOENNEN verschiedene Mengen zu gleichen
2133//                             asoziierten Primidealen fuehren
2134// Aenderung
[85e68dd]2135    list pr = triangMH(J,2);
[70ab73]2136    list qr, re;
2137    for(k = 1; k <= size(pr); k++)
2138    {
[fc1526c]2139      if(primT(pr[k])&&(0))
[840745]2140      {
[70ab73]2141        re[size(re) + 1] = pr[k];
[840745]2142      }
2143      else
2144      {
[70ab73]2145        attrib(pr[k], "isSB", 1);
2146        // Lines changed
2147        if (algorithm == "GTZ")
2148        {
2149          qr = decomp(pr[k], 2);
2150        }
2151        else
2152        {
2153          qr = minAssSL(pr[k]);
2154        }
2155        for(j = 1; j <= size(qr) / 2; j++)
2156        {
[fc1526c]2157          re[size(re) + 1] = std(qr[2 * j]);
[70ab73]2158        }
[840745]2159      }
[70ab73]2160    }
2161    setring P;
2162    re = imap(gnir, re);
2163    re=phi(re);
2164    option(set, op);
2165    setring(P0);
2166    list re=imap(P,re);
2167    return(re);
2168  }
2169
2170  // Lines changed
2171  if ((facstdOption == "noFacstd") || (dim(i) == 0))
2172  {
2173    if (algorithm == "GTZ")
2174    {
2175      re[1] = decomp(i, 2);
2176    }
2177    else
2178    {
2179      re[1] = minAssSL(i);
2180    }
2181    re = union(re);
2182    option(set, op);
2183    re=phi(re);
2184    setring(P0);
2185    list re=imap(P,re);
2186    return(re);
2187  }
2188  q = facstd(i);
2189
2190/*
2191  if((size(q) == 1) && (dim(i) > 1))
2192  {
2193    execute ("ring gnir=("+charstr(P)+"),("+varstr(P)+"),lp;");
2194    list p = facstd(fetch(P, i));
2195    if(size(p) > 1)
2196    {
2197      a = 1;
2198      setring P;
2199      q = fetch(gnir,p);
2200    }
2201    else
2202    {
2203      setring P;
2204    }
2205    kill gnir;
2206  }
[f54c83]2207*/
[70ab73]2208  option(set,op);
2209  // Debug
2210  dbprint(printlevel - voice, "Components returned by facstd", size(q), q);
2211  for(j = 1; j <= size(q); j++)
2212  {
2213    if(a == 0){attrib(q[j], "isSB", 1);}
2214    // Debug
2215    dbprint(printlevel - voice, "We compute the decomp of component", j);
2216    // Lines changed
2217    if (algorithm == "GTZ")
2218    {
2219      re[j] = decomp(q[j], 2);
2220    }
2221    else
2222    {
2223      re[j] = minAssSL(q[j]);
2224    }
2225    // Debug
2226    dbprint(printlevel - voice, "Number of components obtained for this component:", size(re[j]) / 2);
2227    dbprint(printlevel - voice, "re[j]:", re[j]);
2228  }
2229  re = union(re);
2230  re=phi(re);
2231  setring(P0);
2232  list re=imap(P,re);
2233  return(re);
[840745]2234}
2235example
2236{ "EXAMPLE:"; echo = 2;
2237   ring  r = 32003,(x,y,z),lp;
2238   poly  p = z2+1;
2239   poly  q = z4+2;
2240   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
2241   list pr= minAssPrimes(i);  pr;
2242
2243   minAssPrimes(i,1);
2244}
2245
[07c623]2246static proc union(list li)
[d6db1f2]2247{
2248  int i,j,k;
[67bd4c]2249
2250  def P=basering;
2251
[2d2cad9]2252  execute("ring ir = ("+charstr(basering)+"),("+varstr(basering)+"),(C,lp);");
[67bd4c]2253  list l=fetch(P,li);
[d6db1f2]2254  list @erg;
2255
2256  for(k=1;k<=size(l);k++)
2257  {
[a36e78]2258     for(j=1;j<=size(l[k])/2;j++)
2259     {
2260        if(deg(l[k][2*j][1])!=0)
2261        {
2262           i++;
2263           @erg[i]=l[k][2*j];
2264        }
2265     }
[d6db1f2]2266  }
2267
2268  list @wos;
2269  i=0;
2270  ideal i1,i2;
2271  while(i<size(@erg)-1)
2272  {
[a36e78]2273     i++;
2274     k=i+1;
2275     i1=lead(@erg[i]);
2276      attrib(i1,"isSB",1);
2277      attrib(@erg[i],"isSB",1);
[d6db1f2]2278
[a36e78]2279     while(k<=size(@erg))
2280     {
2281        if(deg(@erg[i][1])==0)
2282        {
2283           break;
2284        }
2285        i2=lead(@erg[k]);
2286        attrib(@erg[k],"isSB",1);
2287        attrib(i2,"isSB",1);
[d6db1f2]2288
[a36e78]2289        if(size(reduce(i1,i2,1))==0)
[d6db1f2]2290        {
[a36e78]2291           if(size(reduce(@erg[i],@erg[k],1))==0)
2292           {
2293              @erg[k]=ideal(1);
2294              i2=ideal(1);
2295           }
[d6db1f2]2296        }
[a36e78]2297        if(size(reduce(i2,i1,1))==0)
[d6db1f2]2298        {
[a36e78]2299           if(size(reduce(@erg[k],@erg[i],1))==0)
2300           {
2301              break;
2302           }
[d6db1f2]2303        }
[a36e78]2304        k++;
2305        if(k>size(@erg))
2306        {
2307           @wos[size(@wos)+1]=@erg[i];
2308        }
2309     }
[d6db1f2]2310  }
2311  if(deg(@erg[size(@erg)][1])!=0)
2312  {
[a36e78]2313     @wos[size(@wos)+1]=@erg[size(@erg)];
[d6db1f2]2314  }
[67bd4c]2315  setring P;
2316  list @ser=fetch(ir,@wos);
2317  return(@ser);
[d6db1f2]2318}
2319///////////////////////////////////////////////////////////////////////////////
[d8d3af]2320proc equidim(ideal i,list #)
[b9b906]2321"USAGE:  equidim(i) or equidim(i,1) ; i ideal
[7b3971]2322RETURN: list of equidimensional ideals a[1],...,a[s] with:
[25c431]2323        - a[s] the equidimensional locus of i, i.e. the intersection
2324          of the primary ideals of dimension of i
[367e88]2325        - a[1],...,a[s-1] the lower dimensional equidimensional loci.
2326NOTE:    An embedded component q (primary ideal) of i can be replaced in the
[7b3971]2327         decomposition by a primary ideal q1 with the same radical as q. @*
2328         @code{equidim(i,1)} uses the algorithm of Eisenbud/Huneke/Vasconcelos.
2329
[07c623]2330EXAMPLE:example equidim; shows an example
[ba94539]2331"
2332{
[d88470]2333  if(attrib(basering,"global")!=1)
[07c623]2334  {
[a36e78]2335      ERROR(
[07c623]2336      "// Not implemented for this ordering, please change to global ordering."
[a36e78]2337      );
[07c623]2338  }
[b9b906]2339  intvec op ;
[ba94539]2340  def  P = basering;
2341  list eq;
2342  intvec w;
[4d68980]2343  int n,m;
[6d6ed5b]2344  int g=size(i);
[ba94539]2345  int a=attrib(i,"isSB");
2346  int homo=homog(i);
[d8d3af]2347  if(size(#)!=0)
2348  {
[4d68980]2349     m=1;
2350  }
2351
[ba94539]2352  if(((homo==1)||(a==1))&&(find(ordstr(basering),"l")==0)
2353                                &&(find(ordstr(basering),"s")==0))
2354  {
[a36e78]2355     execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),("
[2d2cad9]2356                              +ordstr(basering)+");");
[a36e78]2357     ideal i=imap(P,i);
2358     ideal j=i;
2359     if(a==1)
2360     {
2361       attrib(j,"isSB",1);
2362     }
2363     else
2364     {
2365       j=groebner(i);
2366     }
[ba94539]2367  }
2368  else
2369  {
[a36e78]2370     execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),dp;");
2371     ideal i=imap(P,i);
2372     ideal j=groebner(i);
[b9b906]2373  }
[ba94539]2374  if(homo==1)
2375  {
[a36e78]2376     for(n=1;n<=nvars(basering);n++)
2377     {
2378        w[n]=ord(var(n));
2379     }
2380     intvec hil=hilb(j,1,w);
[ba94539]2381  }
[4d68980]2382
[6d6ed5b]2383  if ((dim(j)==-1)||(size(j)==0)||(nvars(basering)==1)
2384                  ||(dim(j)==0)||(dim(j)+g==nvars(basering)))
[ba94539]2385  {
2386    setring P;
[6d6ed5b]2387    eq[1]=i;
[ba94539]2388    return(eq);
2389  }
2390
[4d68980]2391  if(m==0)
[ba94539]2392  {
[a36e78]2393     ideal k=equidimMax(j);
[ba94539]2394  }
2395  else
2396  {
[a36e78]2397     ideal k=equidimMaxEHV(j);
[ba94539]2398  }
[6d6ed5b]2399  if(size(reduce(k,j,1))==0)
2400  {
2401    setring P;
2402    eq[1]=i;
2403    kill gnir;
2404    return(eq);
2405  }
[466f80]2406  op=option(get);
[b9b906]2407  option(returnSB);
[651953]2408  j=quotient(j,k);
[02335e]2409  option(set,op);
[d8d3af]2410
[b9b906]2411  list equi=equidim(j);
[4d68980]2412  if(deg(equi[size(equi)][1])<=0)
[a9cf54]2413  {
[a36e78]2414      equi[size(equi)]=k;
[a9cf54]2415  }
2416  else
2417  {
[4d68980]2418    equi[size(equi)+1]=k;
[a9cf54]2419  }
[ba94539]2420  setring P;
[4d68980]2421  eq=imap(gnir,equi);
[ba94539]2422  kill gnir;
2423  return(eq);
2424}
2425example
2426{ "EXAMPLE:"; echo = 2;
2427   ring  r = 32003,(x,y,z),dp;
[7b3971]2428   ideal i = intersect(ideal(z),ideal(x,y),ideal(x2,z2),ideal(x5,y5,z5));
[ba94539]2429   equidim(i);
2430}
[6d6ed5b]2431
[03f29c]2432///////////////////////////////////////////////////////////////////////////////
2433proc equidimMax(ideal i)
[b9b906]2434"USAGE:  equidimMax(i); i ideal
[07c623]2435RETURN:  ideal of equidimensional locus (of maximal dimension) of i.
2436EXAMPLE: example equidimMax; shows an example
[03f29c]2437"
2438{
[d88470]2439  if(attrib(basering,"global")!=1)
[07c623]2440  {
[a36e78]2441      ERROR(
[07c623]2442      "// Not implemented for this ordering, please change to global ordering."
[a36e78]2443      );
[07c623]2444  }
[03f29c]2445  def  P = basering;
2446  ideal eq;
2447  intvec w;
2448  int n;
[6d6ed5b]2449  int g=size(i);
[03f29c]2450  int a=attrib(i,"isSB");
2451  int homo=homog(i);
[b9b906]2452
[03f29c]2453  if(((homo==1)||(a==1))&&(find(ordstr(basering),"l")==0)
2454                                &&(find(ordstr(basering),"s")==0))
2455  {
[a36e78]2456     execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),("
[2d2cad9]2457                              +ordstr(basering)+");");
[a36e78]2458     ideal i=imap(P,i);
2459     ideal j=i;
2460     if(a==1)
2461     {
2462       attrib(j,"isSB",1);
2463     }
2464     else
2465     {
2466       j=groebner(i);
2467     }
[03f29c]2468  }
2469  else
2470  {
[a36e78]2471     execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),dp;");
2472     ideal i=imap(P,i);
2473     ideal j=groebner(i);
[03f29c]2474  }
2475  list indep;
2476  ideal equ,equi;
2477  if(homo==1)
2478  {
[a36e78]2479     for(n=1;n<=nvars(basering);n++)
2480     {
2481        w[n]=ord(var(n));
2482     }
2483     intvec hil=hilb(j,1,w);
[03f29c]2484  }
[6d6ed5b]2485  if ((dim(j)==-1)||(size(j)==0)||(nvars(basering)==1)
2486                  ||(dim(j)==0)||(dim(j)+g==nvars(basering)))
[03f29c]2487  {
2488    setring P;
[a9cf54]2489    return(i);
[03f29c]2490  }
2491
2492  indep=maxIndependSet(j);
[a9cf54]2493
[2d2cad9]2494  execute("ring gnir1 = ("+charstr(basering)+"),("+indep[1][1]+"),("
2495                              +indep[1][2]+");");
[03f29c]2496  if(homo==1)
2497  {
[a36e78]2498     ideal j=std(imap(gnir,j),hil,w);
[03f29c]2499  }
2500  else
2501  {
[a36e78]2502     ideal j=groebner(imap(gnir,j));
[03f29c]2503  }
2504  string quotring=prepareQuotientring(nvars(basering)-indep[1][3]);
[2d2cad9]2505  execute(quotring);
[03f29c]2506  ideal j=imap(gnir1,j);
2507  kill gnir1;
2508  j=clearSB(j);
2509  ideal h;
2510  for(n=1;n<=size(j);n++)
2511  {
[a36e78]2512     h[n]=leadcoef(j[n]);
[03f29c]2513  }
2514  setring gnir;
2515  ideal h=imap(quring,h);
2516  kill quring;
[6d6ed5b]2517
[03f29c]2518  list l=minSat(j,h);
[b9b906]2519
[b1d1e8c]2520  if(deg(l[2])>0)
2521  {
2522    equ=l[1];
2523    attrib(equ,"isSB",1);
2524    j=std(j,l[2]);
[6d6ed5b]2525
[b1d1e8c]2526    if(dim(equ)==dim(j))
2527    {
2528      equi=equidimMax(j);
2529      equ=interred(intersect(equ,equi));
2530    }
2531  }
2532  else
[03f29c]2533  {
[b1d1e8c]2534    equ=i;
[03f29c]2535  }
[b1d1e8c]2536
[03f29c]2537  setring P;
2538  eq=imap(gnir,equ);
2539  kill gnir;
2540  return(eq);
2541}
2542example
2543{ "EXAMPLE:"; echo = 2;
2544   ring  r = 32003,(x,y,z),dp;
[7b3971]2545   ideal i = intersect(ideal(z),ideal(x,y),ideal(x2,z2),ideal(x5,y5,z5));
[03f29c]2546   equidimMax(i);
2547}
[24f458]2548///////////////////////////////////////////////////////////////////////////////
2549static proc islp()
2550{
[a36e78]2551   string s=ordstr(basering);
2552   int n=find(s,"lp");
2553   if(!n){return(0);}
2554   int k=find(s,",");
2555   string t=s[k+1..size(s)];
2556   int l=find(t,",");
2557   t=s[1..k-1];
2558   int m=find(t,",");
2559   if(l+m){return(0);}
2560   return(1);
[24f458]2561}
2562///////////////////////////////////////////////////////////////////////////////
2563
2564proc algeDeco(ideal i, int w)
2565{
2566//reduces primery decomposition over algebraic extensions to
2567//the other cases
[a36e78]2568   def R=basering;
2569   int n=nvars(R);
[fc5095]2570
2571//---Anfang Provisorium
[a36e78]2572   if((size(i)==2) && (w==2))
2573   {
2574      option(redSB);
2575      ideal J=std(i);
2576      option(noredSB);
2577      if((size(J)==2)&&(deg(J[1])==1))
2578      {
2579         ideal keep;
2580         poly f;
2581         int j;
2582         for(j=1;j<=nvars(basering);j++)
2583         {
2584           f=J[2];
2585           while((f/var(j))*var(j)-f==0)
2586           {
2587             f=f/var(j);
2588             keep=keep,var(j);
2589           }
2590           J[2]=f;
2591         }
2592         ideal K=factorize(J[2],1);
2593         if(deg(K[1])==0){K=0;}
2594         K=K+std(keep);
2595         ideal L;
2596         list resu;
2597         for(j=1;j<=size(K);j++)
2598         {
2599            L=J[1],K[j];
2600            resu[j]=L;
2601         }
2602         return(resu);
[70ab73]2603      }
[a36e78]2604   }
[fc5095]2605//---Ende Provisorium
[a36e78]2606   string mp="poly p="+string(minpoly)+";";
2607   string gnir="ring RH="+string(char(R))+",("+varstr(R)+","+string(par(1))
[24f458]2608                +"),dp;";
[a36e78]2609   execute(gnir);
2610   execute(mp);
2611   ideal i=imap(R,i);
2612   ideal I=subst(i,var(nvars(basering)),0);
2613   int j;
2614   for(j=1;j<=ncols(i);j++)
2615   {
2616     if(i[j]!=I[j]){break;}
2617   }
2618   if((j>ncols(i))&&(deg(p)==1))
2619   {
2620     setring R;
2621     kill RH;
2622     kill gnir;
2623     string gnir="ring RH="+string(char(R))+",("+varstr(R)+"),dp;";
2624     execute(gnir);
2625     ideal i=imap(R,i);
2626     ideal J;
2627   }
2628   else
2629   {
2630      i=i,p;
2631   }
2632   list pr;
[24f458]2633
[a36e78]2634   if(w==0)
2635   {
2636      pr=decomp(i);
2637   }
2638   if(w==1)
2639   {
2640      pr=prim_dec(i,1);
2641      pr=reconvList(pr);
2642   }
2643   if(w==2)
2644   {
2645      pr=minAssPrimes(i);
2646   }
2647   if(n<nvars(basering))
2648   {
2649      gnir="ring RS="+string(char(R))+",("+varstr(RH)
[24f458]2650                +"),(dp("+string(n)+"),lp);";
[a36e78]2651      execute(gnir);
2652      list pr=imap(RH,pr);
2653      ideal K;
2654      for(j=1;j<=size(pr);j++)
2655      {
2656         K=groebner(pr[j]);
2657         K=K[2..size(K)];
2658         pr[j]=K;
2659      }
2660      setring R;
2661      list pr=imap(RS,pr);
2662   }
2663   else
2664   {
2665      setring R;
2666      list pr=imap(RH,pr);
2667   }
2668   list re;
2669   if(w==2)
2670   {
2671      re=pr;
2672   }
2673   else
2674   {
2675      re=convList(pr);
2676   }
2677   return(re);
[24f458]2678}
[ab8937]2679///////////////////////////////////////////////////////////////////////////////
2680static proc prepare_absprimdec(list primary)
2681{
2682  list resu,tempo;
2683  string absotto;
2684  resu[size(primary)/2]=list();
2685  for(int ab=1;ab<=size(primary)/2;ab++)
2686  {
2687    absotto= absFactorize(primary[2*ab][1],77);
2688    tempo=primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
2689    resu[ab]=tempo;
2690  }
2691  return(resu);
2692}
[67bd4c]2693///////////////////////////////////////////////////////////////////////////////
[07c623]2694static proc decomp(ideal i,list #)
[7a7df90]2695"USAGE:  decomp(i); i ideal  (for primary decomposition)   (resp.
2696         decomp(i,1);        (for the associated primes of dimension of i) )
2697         decomp(i,2);        (for the minimal associated primes) )
[6fa3af]2698         decomp(i,3);        (for the absolute primary decomposition) )
[d6db1f2]2699RETURN:  list = list of primary ideals and their associated primes
2700         (at even positions in the list)
2701         (resp. a list of the minimal associated primes)
[7b3971]2702NOTE:    Algorithm of Gianni/Trager/Zacharias
[d6db1f2]2703EXAMPLE: example decomp; shows an example
[d2b2a7]2704"
[d6db1f2]2705{
[7cd077]2706  intvec op,@vv;
[d6db1f2]2707  def  @P = basering;
[67bd4c]2708  list primary,indep,ltras;
[d36f7f]2709  intvec @vh,isat,@w;
[6fa3af]2710  int @wr,@k,@n,@m,@n1,@n2,@n3,homo,seri,keepdi,abspri,ab,nn;
[d6db1f2]2711  ideal peek=i;
2712  ideal ser,tras;
[24f458]2713  int isS=(attrib(i,"isSB")==1);
[18dd47]2714
[6fa3af]2715
[d6db1f2]2716  if(size(#)>0)
2717  {
[1d430ab]2718    if((#[1]==1)||(#[1]==2)||(#[1]==3))
2719    {
2720      @wr=#[1];
2721      if(@wr==3){abspri=1;@wr=0;}
2722      if(size(#)>1)
[d6db1f2]2723      {
[e801fe]2724        seri=1;
[1d430ab]2725        peek=#[2];
2726        ser=#[3];
[d6db1f2]2727      }
[1d430ab]2728    }
2729    else
2730    {
2731      seri=1;
2732      peek=#[1];
2733      ser=#[2];
2734    }
[d6db1f2]2735  }
[6fa3af]2736  if(abspri)
2737  {
[1d430ab]2738    list absprimary,abskeep,absprimarytmp,abskeeptmp;
[6fa3af]2739  }
[e801fe]2740  homo=homog(i);
[d6db1f2]2741  if(homo==1)
2742  {
[e801fe]2743    if(attrib(i,"isSB")!=1)
2744    {
[17407e]2745      //ltras=mstd(i);
2746      tras=groebner(i);
2747      ltras=tras,tras;
[e801fe]2748      attrib(ltras[1],"isSB",1);
2749    }
2750    else
2751    {
2752      ltras=i,i;
[24f458]2753      attrib(ltras[1],"isSB",1);
[e801fe]2754    }
2755    tras=ltras[1];
[24f458]2756    attrib(tras,"isSB",1);
[adde988]2757    if((dim(tras)==0) && (!abspri))
[e801fe]2758    {
[1d430ab]2759      primary[1]=ltras[2];
2760      primary[2]=maxideal(1);
2761      if(@wr>0)
2762      {
2763        list l;
2764        l[1]=maxideal(1);
2765        l[2]=maxideal(1);
2766        return(l);
2767      }
2768      return(primary);
2769    }
2770    for(@n=1;@n<=nvars(basering);@n++)
2771    {
2772      @w[@n]=ord(var(@n));
2773    }
2774    intvec @hilb=hilb(tras,1,@w);
2775    intvec keephilb=@hilb;
[a36e78]2776  }
2777
2778  //----------------------------------------------------------------
[d6db1f2]2779  //i is the zero-ideal
2780  //----------------------------------------------------------------
[18dd47]2781
[d6db1f2]2782  if(size(i)==0)
2783  {
[810a4af]2784    primary=ideal(0),ideal(0);
[ab8937]2785    if (abspri) { return(prepare_absprimdec(primary));}
[1d430ab]2786    return(primary);
[d6db1f2]2787  }
[18dd47]2788
[d6db1f2]2789  //----------------------------------------------------------------
2790  //pass to the lexicographical ordering and compute a standardbasis
2791  //----------------------------------------------------------------
2792
[24f458]2793  int lp=islp();
2794
[2d2cad9]2795  execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),(C,lp);");
[466f80]2796  op=option(get);
[d6db1f2]2797  option(redSB);
[e801fe]2798
[3939bc]2799  ideal ser=fetch(@P,ser);
[18dd47]2800
[d6db1f2]2801  if(homo==1)
2802  {
[1d430ab]2803    if(!lp)
2804    {
2805      ideal @j=std(fetch(@P,i),@hilb,@w);
2806    }
2807    else
2808    {
2809      ideal @j=fetch(@P,tras);
2810      attrib(@j,"isSB",1);
2811    }
[d6db1f2]2812  }
2813  else
2814  {
[1d430ab]2815    if(lp&&isS)
2816    {
2817      ideal @j=fetch(@P,i);
2818      attrib(@j,"isSB",1);
2819    }
2820    else
2821    {
2822      ideal @j=groebner(fetch(@P,i));
2823    }
[d6db1f2]2824  }
[02335e]2825  option(set,op);
[e801fe]2826  if(seri==1)
2827  {
2828    ideal peek=fetch(@P,peek);
2829    attrib(peek,"isSB",1);
2830  }
2831  else
2832  {
2833    ideal peek=@j;
2834  }
[6fa3af]2835  if((size(ser)==0)&&(!abspri))
[e801fe]2836  {
2837    ideal fried;
2838    @n=size(@j);
2839    for(@k=1;@k<=@n;@k++)
2840    {
2841      if(deg(lead(@j[@k]))==1)
2842      {
2843        fried[size(fried)+1]=@j[@k];
2844        @j[@k]=0;
2845      }
2846    }
[5674d5]2847    if(size(fried)==nvars(basering))
2848    {
[1d430ab]2849      setring @P;
2850      primary[1]=i;
2851      primary[2]=i;
[ab8937]2852      if (abspri) { return(prepare_absprimdec(primary));}
[1d430ab]2853      return(primary);
[5674d5]2854    }
[e801fe]2855    if(size(fried)>0)
2856    {
[1d430ab]2857      string newva;
2858      string newma;
2859      for(@k=1;@k<=nvars(basering);@k++)
2860      {
2861        @n1=0;
2862        for(@n=1;@n<=size(fried);@n++)
2863        {
2864          if(leadmonom(fried[@n])==var(@k))
[a36e78]2865          {
[1d430ab]2866            @n1=1;
2867            break;
[a36e78]2868          }
[1d430ab]2869        }
2870        if(@n1==0)
2871        {
2872          newva=newva+string(var(@k))+",";
2873          newma=newma+string(var(@k))+",";
2874        }
2875        else
2876        {
2877          newma=newma+string(0)+",";
2878        }
2879      }
2880      newva[size(newva)]=")";
2881      newma[size(newma)]=";";
2882      execute("ring @deirf=("+charstr(gnir)+"),("+newva+",lp;");
2883      execute("map @kappa=gnir,"+newma);
2884      ideal @j= @kappa(@j);
2885      @j=simplify(@j,2);
2886      attrib(@j,"isSB",1);
2887      list pr=decomp(@j);
2888      setring gnir;
2889      list pr=imap(@deirf,pr);
2890      for(@k=1;@k<=size(pr);@k++)
2891      {
2892        @j=pr[@k]+fried;
2893        pr[@k]=@j;
2894      }
2895      setring @P;
[810a4af]2896      primary=imap(gnir,pr);
2897      if (abspri) { return(prepare_absprimdec(primary));}
2898      return(primary);
[e801fe]2899    }
2900  }
[d6db1f2]2901  //----------------------------------------------------------------
2902  //j is the ring
2903  //----------------------------------------------------------------
2904
2905  if (dim(@j)==-1)
2906  {
[e801fe]2907    setring @P;
[651953]2908    primary=ideal(1),ideal(1);
[ab8937]2909    if (abspri) { return(prepare_absprimdec(primary));}
[651953]2910    return(primary);
[d6db1f2]2911  }
[18dd47]2912
[d6db1f2]2913  //----------------------------------------------------------------
2914  //  the case of one variable
2915  //----------------------------------------------------------------
2916
2917  if(nvars(basering)==1)
2918  {
[1d430ab]2919    list fac=factor(@j[1]);
2920    list gprimary;
2921    for(@k=1;@k<=size(fac[1]);@k++)
2922    {
2923      if(@wr==0)
2924      {
2925        gprimary[2*@k-1]=ideal(fac[1][@k]^fac[2][@k]);
2926        gprimary[2*@k]=ideal(fac[1][@k]);
2927      }
2928      else
2929      {
2930        gprimary[2*@k-1]=ideal(fac[1][@k]);
2931        gprimary[2*@k]=ideal(fac[1][@k]);
2932      }
2933    }
2934    setring @P;
2935    primary=fetch(gnir,gprimary);
[d6db1f2]2936
[6fa3af]2937//HIER
[ab8937]2938    if (abspri) { return(prepare_absprimdec(primary));}
[1d430ab]2939    return(primary);
[d6db1f2]2940  }
[3939bc]2941
[d6db1f2]2942 //------------------------------------------------------------------
2943 //the zero-dimensional case
2944 //------------------------------------------------------------------
2945  if (dim(@j)==0)
2946  {
[466f80]2947    op=option(get);
[e801fe]2948    option(redSB);
2949    list gprimary= zero_decomp(@j,ser,@wr);
[6fa3af]2950
[e801fe]2951    setring @P;
2952    primary=fetch(gnir,gprimary);
[6fa3af]2953
[e801fe]2954    if(size(ser)>0)
2955    {
2956      primary=cleanPrimary(primary);
2957    }
[6fa3af]2958//HIER
2959    if(abspri)
2960    {
[1d430ab]2961      setring gnir;
2962      list primary=imap(@P,primary);
2963      list resu,tempo;
2964      string absotto;
2965      map sigma,invsigma;
2966      ideal II,jmap;
2967      nn=nvars(basering);
2968      for(ab=1;ab<=size(primary)/2;ab++)
2969      {
2970        II=primary[2*ab];
2971        attrib(II,"isSB",1);
2972        if(deg(II[1])==vdim(II))
2973        {
[a36e78]2974          absotto= absFactorize(primary[2*ab][1],77);
[1d430ab]2975          tempo=
2976            primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
2977        }
2978        else
2979        {
2980          invsigma=basering,maxideal(1);
2981          jmap=randomLast(50);
2982          sigma=basering,jmap;
2983          jmap[nn]=2*var(nn)-jmap[nn];
2984          invsigma=basering,jmap;
2985          II=groebner(sigma(II));
2986          absotto = absFactorize(II[1],77);
2987          II=var(nn);
2988          tempo= primary[2*ab-1],primary[2*ab],absotto,string(invsigma(II));
2989        }
2990        resu[ab]=tempo;
2991      }
2992      primary=resu;
2993      setring @P;
2994      primary=imap(gnir,primary);
[6fa3af]2995    }
[e801fe]2996    return(primary);
2997  }
[d6db1f2]2998
2999  poly @gs,@gh,@p;
3000  string @va,quotring;
3001  list quprimary,htprimary,collectprimary,lsau,lnew,allindep,restindep;
3002  ideal @h;
3003  int jdim=dim(@j);
3004  list fett;
[e801fe]3005  int lauf,di,newtest;
[67bd4c]3006  //------------------------------------------------------------------
3007  //search for a maximal independent set indep,i.e.
3008  //look for subring such that the intersection with the ideal is zero
3009  //j intersected with K[var(indep[3]+1),...,var(nvar] is zero,
[9050ca]3010  //indep[1] is the new varstring and indep[2] the string for block-ordering
[67bd4c]3011  //------------------------------------------------------------------
[d6db1f2]3012  if(@wr!=1)
3013  {
[1d430ab]3014    allindep=independSet(@j);
3015    for(@m=1;@m<=size(allindep);@m++)
3016    {
3017      if(allindep[@m][3]==jdim)
3018      {
3019        di++;
3020        indep[di]=allindep[@m];
3021      }
3022      else
3023      {
3024        lauf++;
3025        restindep[lauf]=allindep[@m];
3026      }
3027    }
3028  }
3029  else
3030  {
3031    indep=maxIndependSet(@j);
3032  }
[3939bc]3033
[d6db1f2]3034  ideal jkeep=@j;
3035  if(ordstr(@P)[1]=="w")
3036  {
[1d430ab]3037    execute("ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),("+ordstr(@P)+");");
[d6db1f2]3038  }
3039  else
3040  {
[1d430ab]3041    execute( "ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),(C,dp);");
[e801fe]3042  }
3043
3044  if(homo==1)
3045  {
3046    if((ordstr(@P)[3]=="d")||(ordstr(@P)[1]=="d")||(ordstr(@P)[1]=="w")
3047       ||(ordstr(@P)[3]=="w"))
3048    {
3049      ideal jwork=imap(@P,tras);
3050      attrib(jwork,"isSB",1);
3051    }
3052    else
3053    {
[2d2c8be]3054      ideal jwork=std(imap(gnir,@j),@hilb,@w);
[e801fe]3055    }
3056  }
3057  else
3058  {
[9a384e]3059    ideal jwork=groebner(imap(gnir,@j));
[d6db1f2]3060  }
[e801fe]3061  list hquprimary;
[d6db1f2]3062  poly @p,@q;
[e801fe]3063  ideal @h,fac,ser;
[5c7562]3064  ideal @Ptest=1;
[d6db1f2]3065  di=dim(jwork);
[e801fe]3066  keepdi=di;
[3939bc]3067
[d6db1f2]3068  setring gnir;
3069  for(@m=1;@m<=size(indep);@m++)
3070  {
[1d430ab]3071    isat=0;
3072    @n2=0;
3073    if((indep[@m][1]==varstr(basering))&&(@m==1))
3074    //this is the good case, nothing to do, just to have the same notations
3075    //change the ring
3076    {
3077      execute("ring gnir1 = ("+charstr(basering)+"),("+varstr(basering)+"),("
[a36e78]3078                              +ordstr(basering)+");");
[1d430ab]3079      ideal @j=fetch(gnir,@j);
3080      attrib(@j,"isSB",1);
3081      ideal ser=fetch(gnir,ser);
3082    }
3083    else
3084    {
3085      @va=string(maxideal(1));
3086      if(@m==1)
3087      {
3088        @j=fetch(@P,i);
3089      }
3090      execute("ring gnir1 = ("+charstr(basering)+"),("+indep[@m][1]+"),("
[2d2cad9]3091                              +indep[@m][2]+");");
[1d430ab]3092      execute("map phi=gnir,"+@va+";");
3093      op=option(get);
3094      option(redSB);
3095      if(homo==1)
3096      {
3097        ideal @j=std(phi(@j),@hilb,@w);
3098      }
3099      else
3100      {
3101        ideal @j=groebner(phi(@j));
3102      }
3103      ideal ser=phi(ser);
[3939bc]3104
[1d430ab]3105      option(set,op);
3106    }
3107    if((deg(@j[1])==0)||(dim(@j)<jdim))
3108    {
3109      setring gnir;
3110      break;
3111    }
3112    for (lauf=1;lauf<=size(@j);lauf++)
3113    {
3114      fett[lauf]=size(@j[lauf]);
3115    }
3116    //------------------------------------------------------------------------
3117    //we have now the following situation:
3118    //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may pass
3119    //to this quotientring, j is their still a standardbasis, the
3120    //leading coefficients of the polynomials  there (polynomials in
3121    //K[var(nnp+1),..,var(nva)]) are collected in the list h,
3122    //we need their ggt, gh, because of the following: let
3123    //(j:gh^n)=(j:gh^infinity) then j*K(var(nnp+1),..,var(nva))[..the rest..]
3124    //intersected with K[var(1),...,var(nva)] is (j:gh^n)
3125    //on the other hand j=(j,gh^n) intersected with (j:gh^n)
3126
3127    //------------------------------------------------------------------------
3128
3129    //arrangement for quotientring K(var(nnp+1),..,var(nva))[..the rest..] and
3130    //map phi:K[var(1),...,var(nva)] --->K(var(nnpr+1),..,var(nva))[..rest..]
3131    //------------------------------------------------------------------------
3132
3133    quotring=prepareQuotientring(nvars(basering)-indep[@m][3]);
3134
3135    //---------------------------------------------------------------------
3136    //we pass to the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
3137    //---------------------------------------------------------------------
3138
3139    ideal @jj=lead(@j);               //!! vorn vereinbaren
3140    execute(quotring);
3141
3142    ideal @jj=imap(gnir1,@jj);
3143    @vv=clearSBNeu(@jj,fett);  //!! vorn vereinbaren
3144    setring gnir1;
3145    @k=size(@j);
3146    for (lauf=1;lauf<=@k;lauf++)
3147    {
3148      if(@vv[lauf]==1)
3149      {
3150        @j[lauf]=0;
3151      }
3152    }
3153    @j=simplify(@j,2);
3154    setring quring;
3155    // @j considered in the quotientring
3156    ideal @j=imap(gnir1,@j);
[70ab73]3157
[1d430ab]3158    ideal ser=imap(gnir1,ser);
[70ab73]3159
[1d430ab]3160    kill gnir1;
[70ab73]3161
[1d430ab]3162    //j is a standardbasis in the quotientring but usually not minimal
3163    //here it becomes minimal
[70ab73]3164
[1d430ab]3165    attrib(@j,"isSB",1);
[70ab73]3166
[1d430ab]3167    //we need later ggt(h[1],...)=gh for saturation
3168    ideal @h;
3169    if(deg(@j[1])>0)
3170    {
3171      for(@n=1;@n<=size(@j);@n++)
3172      {
3173        @h[@n]=leadcoef(@j[@n]);
3174      }
3175      //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..the rest..]
3176      op=option(get);
3177      option(redSB);
[70ab73]3178
[1d430ab]3179      list uprimary= zero_decomp(@j,ser,@wr);
[a36e78]3180//HIER
[1d430ab]3181      if(abspri)
3182      {
3183        ideal II;
3184        ideal jmap;
3185        map sigma;
3186        nn=nvars(basering);
3187        map invsigma=basering,maxideal(1);
3188        for(ab=1;ab<=size(uprimary)/2;ab++)
[a36e78]3189        {
[1d430ab]3190          II=uprimary[2*ab];
3191          attrib(II,"isSB",1);
3192          if(deg(II[1])!=vdim(II))
3193          {
3194            jmap=randomLast(50);
3195            sigma=basering,jmap;
3196            jmap[nn]=2*var(nn)-jmap[nn];
3197            invsigma=basering,jmap;
3198            II=groebner(sigma(II));
3199          }
3200          absprimarytmp[ab]= absFactorize(II[1],77);
3201          II=var(nn);
3202          abskeeptmp[ab]=string(invsigma(II));
3203          invsigma=basering,maxideal(1);
[a36e78]3204        }
[1d430ab]3205      }
3206      option(set,op);
3207    }
3208    else
3209    {
3210      list uprimary;
3211      uprimary[1]=ideal(1);
3212      uprimary[2]=ideal(1);
3213    }
3214    //we need the intersection of the ideals in the list quprimary with the
3215    //polynomialring, i.e. let q=(f1,...,fr) in the quotientring such an ideal
3216    //but fi polynomials, then the intersection of q with the polynomialring
3217    //is the saturation of the ideal generated by f1,...,fr with respect to
3218    //h which is the lcm of the leading coefficients of the fi considered in
3219    //in the quotientring: this is coded in saturn
[f54c83]3220
[1d430ab]3221    list saturn;
3222    ideal hpl;
[d6db1f2]3223
[1d430ab]3224    for(@n=1;@n<=size(uprimary);@n++)
3225    {
3226      uprimary[@n]=interred(uprimary[@n]); // temporary fix
3227      hpl=0;
3228      for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
3229      {
3230        hpl=hpl,leadcoef(uprimary[@n][@n1]);
3231      }
3232      saturn[@n]=hpl;
3233    }
[18dd47]3234
[1d430ab]3235    //--------------------------------------------------------------------
3236    //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
3237    //back to the polynomialring
3238    //---------------------------------------------------------------------
3239    setring gnir;
[d6db1f2]3240
[1d430ab]3241    collectprimary=imap(quring,uprimary);
3242    lsau=imap(quring,saturn);
3243    @h=imap(quring,@h);
[d6db1f2]3244
[1d430ab]3245    kill quring;
[7a7df90]3246
[1d430ab]3247    @n2=size(quprimary);
3248    @n3=@n2;
[a36e78]3249
[1d430ab]3250    for(@n1=1;@n1<=size(collectprimary)/2;@n1++)
3251    {
3252      if(deg(collectprimary[2*@n1][1])>0)
3253      {
3254        @n2++;
3255        quprimary[@n2]=collectprimary[2*@n1-1];
3256        lnew[@n2]=lsau[2*@n1-1];
3257        @n2++;
3258        lnew[@n2]=lsau[2*@n1];
3259        quprimary[@n2]=collectprimary[2*@n1];
3260        if(abspri)
[d6db1f2]3261        {
[1d430ab]3262          absprimary[@n2/2]=absprimarytmp[@n1];
3263          abskeep[@n2/2]=abskeeptmp[@n1];
[d6db1f2]3264        }
[1d430ab]3265      }
3266    }
3267    //here the intersection with the polynomialring
3268    //mentioned above is really computed
3269    for(@n=@n3/2+1;@n<=@n2/2;@n++)
3270    {
3271      if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
3272      {
3273        quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3274        quprimary[2*@n]=quprimary[2*@n-1];
3275      }
3276      else
3277      {
3278        if(@wr==0)
[d6db1f2]3279        {
[1d430ab]3280          quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
[d6db1f2]3281        }
[1d430ab]3282        quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
3283      }
3284    }
[3939bc]3285
[1d430ab]3286    if(size(@h)>0)
3287    {
3288      //---------------------------------------------------------------
3289      //we change to @Phelp to have the ordering dp for saturation
3290      //---------------------------------------------------------------
3291      setring @Phelp;
3292      @h=imap(gnir,@h);
3293      if(@wr!=1)
3294      {
3295        if(defined(@LL)){kill @LL;}
3296        list @LL=minSat(jwork,@h);
3297        @Ptest=intersect(@Ptest,@LL[1]);
3298        @q=@LL[2];
3299      }
3300      else
3301      {
3302        fac=ideal(0);
3303        for(lauf=1;lauf<=ncols(@h);lauf++)
[a36e78]3304        {
[1d430ab]3305          if(deg(@h[lauf])>0)
3306          {
3307            fac=fac+factorize(@h[lauf],1);
3308          }
[a36e78]3309        }
[1d430ab]3310        fac=simplify(fac,6);
3311        @q=1;
3312        for(lauf=1;lauf<=size(fac);lauf++)
[a36e78]3313        {
[1d430ab]3314          @q=@q*fac[lauf];
[a36e78]3315        }
[1d430ab]3316      }
3317      jwork=std(jwork,@q);
3318      keepdi=dim(jwork);
3319      if(keepdi<di)
3320      {
[d6db1f2]3321        setring gnir;
3322        @j=imap(@Phelp,jwork);
[1d430ab]3323        break;
3324      }
3325      if(homo==1)
3326      {
3327        @hilb=hilb(jwork,1,@w);
3328      }
3329
3330      setring gnir;
3331      @j=imap(@Phelp,jwork);
3332    }
[d6db1f2]3333  }
[7a7df90]3334
3335  if((size(quprimary)==0)&&(@wr==1))
[d6db1f2]3336  {
[1d430ab]3337    @j=ideal(1);
3338    quprimary[1]=ideal(1);
3339    quprimary[2]=ideal(1);
[d6db1f2]3340  }
[e801fe]3341  if((size(quprimary)==0))
3342  {
3343    keepdi=di-1;
[17407e]3344    quprimary[1]=ideal(1);
3345    quprimary[2]=ideal(1);
[3939bc]3346  }
[d6db1f2]3347  //---------------------------------------------------------------
3348  //notice that j=sat(j,gh) intersected with (j,gh^n)
3349  //we finished with sat(j,gh) and have to start with (j,gh^n)
3350  //---------------------------------------------------------------
3351  if((deg(@j[1])!=0)&&(@wr!=1))
3352  {
[1d430ab]3353    if(size(quprimary)>0)
3354    {
3355      setring @Phelp;
3356      ser=imap(gnir,ser);
3357      hquprimary=imap(gnir,quprimary);
3358      if(@wr==0)
3359      {
3360        //HIER STATT DURCHSCHNITT SATURIEREN!
3361        ideal htest=@Ptest;
3362      }
3363      else
3364      {
3365        ideal htest=hquprimary[2];
3366
3367        for (@n1=2;@n1<=size(hquprimary)/2;@n1++)
[d6db1f2]3368        {
[1d430ab]3369          htest=intersect(htest,hquprimary[2*@n1]);
[d6db1f2]3370        }
[1d430ab]3371      }
[d6db1f2]3372
[1d430ab]3373      if(size(ser)>0)
3374      {
3375        ser=intersect(htest,ser);
3376      }
3377      else
3378      {
3379        ser=htest;
3380      }
3381      setring gnir;
3382      ser=imap(@Phelp,ser);
3383    }
3384    if(size(reduce(ser,peek,1))!=0)
3385    {
3386      for(@m=1;@m<=size(restindep);@m++)
3387      {
3388        // if(restindep[@m][3]>=keepdi)
3389        // {
3390        isat=0;
3391        @n2=0;
[e801fe]3392
[1d430ab]3393        if(restindep[@m][1]==varstr(basering))
3394           //the good case, nothing to do, just to have the same notations
3395           //change the ring
[3939bc]3396        {
[1d430ab]3397          execute("ring gnir1 = ("+charstr(basering)+"),("+
3398               varstr(basering)+"),("+ordstr(basering)+");");
3399          ideal @j=fetch(gnir,jkeep);
3400          attrib(@j,"isSB",1);
[d6db1f2]3401        }
[a36e78]3402        else
[d6db1f2]3403        {
[1d430ab]3404          @va=string(maxideal(1));
3405          execute("ring gnir1 = ("+charstr(basering)+"),("+
[a36e78]3406                      restindep[@m][1]+"),(" +restindep[@m][2]+");");
[1d430ab]3407          execute("map phi=gnir,"+@va+";");
3408          op=option(get);
3409          option(redSB);
3410          if(homo==1)
3411          {
3412            ideal @j=std(phi(jkeep),keephilb,@w);
3413          }
3414          else
3415          {
3416            ideal @j=groebner(phi(jkeep));
3417          }
3418          ideal ser=phi(ser);
3419          option(set,op);
3420        }
[a36e78]3421
[1d430ab]3422        for (lauf=1;lauf<=size(@j);lauf++)
3423        {
3424          fett[lauf]=size(@j[lauf]);
3425        }
3426        //------------------------------------------------------------------
3427        //we have now the following situation:
3428        //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may
3429        //pass to this quotientring, j is their still a standardbasis, the
3430        //leading coefficients of the polynomials  there (polynomials in
3431        //K[var(nnp+1),..,var(nva)]) are collected in the list h,
3432        //we need their ggt, gh, because of the following:
3433        //let (j:gh^n)=(j:gh^infinity) then
3434        //j*K(var(nnp+1),..,var(nva))[..the rest..]
3435        //intersected with K[var(1),...,var(nva)] is (j:gh^n)
3436        //on the other hand j=(j,gh^n) intersected with (j:gh^n)
3437
3438        //------------------------------------------------------------------
3439
3440        //the arrangement for the quotientring
3441        // K(var(nnp+1),..,var(nva))[..the rest..]
3442        //and the map phi:K[var(1),...,var(nva)] ---->
3443        //--->K(var(nnpr+1),..,var(nva))[..the rest..]
3444        //------------------------------------------------------------------
3445
3446        quotring=prepareQuotientring(nvars(basering)-restindep[@m][3]);
3447
3448        //------------------------------------------------------------------
3449        //we pass to the quotientring  K(var(nnp+1),..,var(nva))[..rest..]
3450        //------------------------------------------------------------------
3451
3452        execute(quotring);
3453
3454        // @j considered in the quotientring
3455        ideal @j=imap(gnir1,@j);
3456        ideal ser=imap(gnir1,ser);
3457
3458        kill gnir1;
3459
3460        //j is a standardbasis in the quotientring but usually not minimal
3461        //here it becomes minimal
3462        @j=clearSB(@j,fett);
3463        attrib(@j,"isSB",1);
[a36e78]3464
[1d430ab]3465        //we need later ggt(h[1],...)=gh for saturation
3466        ideal @h;
[a36e78]3467
[1d430ab]3468        for(@n=1;@n<=size(@j);@n++)
3469        {
3470          @h[@n]=leadcoef(@j[@n]);
3471        }
3472        //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..rest..]
[a36e78]3473
[1d430ab]3474        op=option(get);
3475        option(redSB);
3476        list uprimary= zero_decomp(@j,ser,@wr);
[a36e78]3477//HIER
[1d430ab]3478        if(abspri)
3479        {
3480          ideal II;
3481          ideal jmap;
3482          map sigma;
3483          nn=nvars(basering);
3484          map invsigma=basering,maxideal(1);
3485          for(ab=1;ab<=size(uprimary)/2;ab++)
3486          {
3487            II=uprimary[2*ab];
3488            attrib(II,"isSB",1);
3489            if(deg(II[1])!=vdim(II))
3490            {
3491              jmap=randomLast(50);
3492              sigma=basering,jmap;
3493              jmap[nn]=2*var(nn)-jmap[nn];
3494              invsigma=basering,jmap;
3495              II=groebner(sigma(II));
3496            }
3497            absprimarytmp[ab]= absFactorize(II[1],77);
3498            II=var(nn);
3499            abskeeptmp[ab]=string(invsigma(II));
3500            invsigma=basering,maxideal(1);
3501          }
3502        }
3503        option(set,op);
[a36e78]3504
[1d430ab]3505        //we need the intersection of the ideals in the list quprimary with
3506        //the polynomialring, i.e. let q=(f1,...,fr) in the quotientring
3507        //such an ideal but fi polynomials, then the intersection of q with
3508        //the polynomialring is the saturation of the ideal generated by
3509        //f1,...,fr with respect toh which is the lcm of the leading
3510        //coefficients of the fi considered in the quotientring:
3511        //this is coded in saturn
[a36e78]3512
[1d430ab]3513        list saturn;
3514        ideal hpl;
[a36e78]3515
[1d430ab]3516        for(@n=1;@n<=size(uprimary);@n++)
3517        {
3518          hpl=0;
3519          for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
3520          {
3521            hpl=hpl,leadcoef(uprimary[@n][@n1]);
3522          }
3523          saturn[@n]=hpl;
3524        }
3525        //------------------------------------------------------------------
3526        //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..rest..]
3527        //back to the polynomialring
3528        //------------------------------------------------------------------
3529        setring gnir;
3530        collectprimary=imap(quring,uprimary);
3531        lsau=imap(quring,saturn);
3532        @h=imap(quring,@h);
[a36e78]3533
[1d430ab]3534        kill quring;
[a36e78]3535
[1d430ab]3536        @n2=size(quprimary);
3537        @n3=@n2;
[a36e78]3538
[1d430ab]3539        for(@n1=1;@n1<=size(collectprimary)/2;@n1++)
3540        {
3541          if(deg(collectprimary[2*@n1][1])>0)
3542          {
3543            @n2++;
3544            quprimary[@n2]=collectprimary[2*@n1-1];
3545            lnew[@n2]=lsau[2*@n1-1];
3546            @n2++;
3547            lnew[@n2]=lsau[2*@n1];
3548            quprimary[@n2]=collectprimary[2*@n1];
3549            if(abspri)
3550            {
3551              absprimary[@n2/2]=absprimarytmp[@n1];
3552              abskeep[@n2/2]=abskeeptmp[@n1];
3553            }
3554          }
3555        }
[a36e78]3556
3557
[1d430ab]3558        //here the intersection with the polynomialring
3559        //mentioned above is really computed
[70ab73]3560
[1d430ab]3561        for(@n=@n3/2+1;@n<=@n2/2;@n++)
[6fa3af]3562        {
[1d430ab]3563          if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
[6fa3af]3564          {
[1d430ab]3565            quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3566            quprimary[2*@n]=quprimary[2*@n-1];
3567          }
3568          else
3569          {
3570            if(@wr==0)
3571            {
3572              quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3573            }
3574            quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
[6fa3af]3575          }
3576        }
[1d430ab]3577        if(@n2>=@n3+2)
[d6db1f2]3578        {
[1d430ab]3579          setring @Phelp;
3580          ser=imap(gnir,ser);
3581          hquprimary=imap(gnir,quprimary);
3582          for(@n=@n3/2+1;@n<=@n2/2;@n++)
3583          {
3584            if(@wr==0)
3585            {
3586              ser=intersect(ser,hquprimary[2*@n-1]);
3587            }
3588            else
3589            {
3590              ser=intersect(ser,hquprimary[2*@n]);
3591            }
3592          }
3593          setring gnir;
3594          ser=imap(@Phelp,ser);
[d6db1f2]3595        }
[3939bc]3596
[1d430ab]3597         // }
3598      }
3599//HIER
[6fa3af]3600      if(abspri)
3601      {
3602        list resu,tempo;
3603        for(ab=1;ab<=size(quprimary)/2;ab++)
3604        {
[1d430ab]3605          if (deg(quprimary[2*ab][1])!=0)
3606          {
3607            tempo=quprimary[2*ab-1],quprimary[2*ab],
3608                         absprimary[ab],abskeep[ab];
3609            resu[ab]=tempo;
3610          }
[6fa3af]3611        }
3612        quprimary=resu;
[1d430ab]3613        @wr=3;
[70ab73]3614      }
[1d430ab]3615      if(size(reduce(ser,peek,1))!=0)
3616      {
3617        if(@wr>0)
3618        {
3619          htprimary=decomp(@j,@wr,peek,ser);
3620        }
3621        else
3622        {
3623          htprimary=decomp(@j,peek,ser);
3624        }
3625        // here we collect now both results primary(sat(j,gh))
3626        // and primary(j,gh^n)
3627        @n=size(quprimary);
3628        for (@k=1;@k<=size(htprimary);@k++)
3629        {
3630          quprimary[@n+@k]=htprimary[@k];
3631        }
3632      }
3633    }
3634  }
3635  else
3636  {
3637    if(abspri)
3638    {
3639      list resu,tempo;
3640      for(ab=1;ab<=size(quprimary)/2;ab++)
3641      {
3642        tempo=quprimary[2*ab-1],quprimary[2*ab],
3643                   absprimary[ab],abskeep[ab];
3644        resu[ab]=tempo;
3645      }
3646      quprimary=resu;
3647    }
3648  }
[091424]3649  //---------------------------------------------------------------------------
[d6db1f2]3650  //back to the ring we started with
3651  //the final result: primary
[091424]3652  //---------------------------------------------------------------------------
[d6db1f2]3653  setring @P;
3654  primary=imap(gnir,quprimary);
[0ccdf4]3655  if(!abspri)
3656  {
[1d430ab]3657    primary=cleanPrimary(primary);
[0ccdf4]3658  }
[d92713]3659  if (abspri && (typeof(primary[1][1])=="poly"))
3660  { return(prepare_absprimdec(primary));}
[d6db1f2]3661  return(primary);
3662}
[a36e78]3663
3664
[d6db1f2]3665example
3666{ "EXAMPLE:"; echo = 2;
3667   ring  r = 32003,(x,y,z),lp;
3668   poly  p = z2+1;
3669   poly  q = z4+2;
3670   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
3671   list pr= decomp(i);
3672   pr;
[18dd47]3673   testPrimary( pr, i);
[d6db1f2]3674}
[67bd4c]3675
3676///////////////////////////////////////////////////////////////////////////////
[07c623]3677static proc powerCoeffs(poly f,int e)
[80654d]3678//computes a polynomial with the same monomials as f but coefficients
3679//the p^e th power of the coefficients of f
[67bd4c]3680{
[a36e78]3681   int i;
3682   poly g;
3683   int ex=char(basering)^e;
3684   for(i=1;i<=size(f);i++)
3685   {
3686      g=g+leadcoef(f[i])^ex*leadmonom(f[i]);
3687   }
3688   return(g);
[80654d]3689}
3690///////////////////////////////////////////////////////////////////////////////
3691
[fc5095]3692proc sep(poly f,int i, list #)
[80654d]3693"USAGE:  input: a polynomial f depending on the i-th variable and optional
3694         an integer k considering the polynomial f defined over Fp(t1,...,tm)
3695         as polynomial over Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3696 RETURN: the separabel part of f as polynomial in Fp(t1,...,tm)
[b9b906]3697        and an integer k to indicate that f should be considerd
[80654d]3698        as polynomial over Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3699 EXAMPLE: example sep; shows an example
3700{
[a36e78]3701   def R=basering;
3702   int k;
3703   if(size(#)>0){k=#[1];}
[fc5095]3704
[80654d]3705
[a36e78]3706   poly h=gcd(f,diff(f,var(i)));
3707   if((reduce(f,std(h))!=0)||(reduce(diff(f,var(i)),std(h))!=0))
3708   {
3709      ERROR("FEHLER IN GCD");
3710   }
3711   poly g1=lift(h,f)[1][1];    //  f/h
3712   poly h1;
3713
3714   while(h!=h1)
3715   {
3716      h1=h;
3717      h=gcd(h,diff(h,var(i)));
3718   }
[80654d]3719
[a36e78]3720   if(deg(h1)==0){return(list(g1,k));} //in characteristic 0 we return here
[80654d]3721
[a36e78]3722   k++;
[80654d]3723
[a36e78]3724   ideal ma=maxideal(1);
3725   ma[i]=var(i)^char(R);
3726   map phi=R,ma;
3727   ideal hh=h;    //this is technical because preimage works only for ideals
[80654d]3728
[a36e78]3729   poly u=preimage(R,phi,hh)[1]; //h=u(x(i)^p)
[80654d]3730
[a36e78]3731   list g2=sep(u,i,k);           //we consider u(t(1)^(p^-1),...,t(m)^(p^-1))
3732   g1=powerCoeffs(g1,g2[2]-k+1); //to have g1 over the same field as g2[1]
[80654d]3733
[a36e78]3734   list g3=sep(g1*g2[1],i,g2[2]);
3735   return(g3);
[80654d]3736}
3737example
3738{ "EXAMPLE:"; echo = 2;
3739   ring R=(5,t,s),(x,y,z),dp;
3740   poly f=(x^25-t*x^5+t)*(x^3+s);
3741   sep(f,1);
3742}
3743
3744///////////////////////////////////////////////////////////////////////////////
[24f458]3745 proc zeroRad(ideal I,list #)
[80654d]3746"USAGE:  zeroRad(I) , I a zero-dimensional ideal
3747 RETURN: the radical of I
3748 NOTE:  Algorithm of Kemper
3749 EXAMPLE: example zeroRad; shows an example
3750{
[a36e78]3751   if(homog(I)==1){return(maxideal(1));}
3752   //I needs to be a reduced standard basis
3753   def R=basering;
3754   int m=npars(R);
3755   int n=nvars(R);
3756   int p=char(R);
3757   int d=vdim(I);
3758   int i,k;
3759   list l;
3760   if(((p==0)||(p>d))&&(d==deg(I[1])))
3761   {
3762     intvec e=leadexp(I[1]);
3763     for(i=1;i<=nvars(basering);i++)
3764     {
3765       if(e[i]!=0) break;
3766     }
3767     I[1]=sep(I[1],i)[1];
3768     return(interred(I));
3769   }
3770   intvec op=option(get);
[80654d]3771
[a36e78]3772   option(redSB);
3773   ideal F=finduni(I);//F[i] generates I intersected with K[var(i)]
[25c431]3774
[a36e78]3775   option(set,op);
3776   if(size(#)>0){I=#[1];}
[80654d]3777
[a36e78]3778   for(i=1;i<=n;i++)
3779   {
3780      l[i]=sep(F[i],i);
3781      F[i]=l[i][1];
3782      if(l[i][2]>k){k=l[i][2];}  //computation of the maximal k
3783   }
[80654d]3784
[a90eb0]3785   if((k==0)||(m==0)) //the separable case
3786   {
3787    intvec save=option(get);option(redSB);
3788    I=interred(I+F);option(set,save);return(I);
3789   }
[80654d]3790
[a36e78]3791   for(i=1;i<=n;i++)             //consider all polynomials over
3792   {                             //Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3793      F[i]=powerCoeffs(F[i],k-l[i][2]);
3794   }
[24f458]3795
[a36e78]3796   string cR="ring @R="+string(p)+",("+parstr(R)+","+varstr(R)+"),dp;";
3797   execute(cR);
3798   ideal F=imap(R,F);
[24f458]3799
[a36e78]3800   string nR="ring @S="+string(p)+",(y(1..m),"+varstr(R)+","+parstr(R)+"),dp;";
3801   execute(nR);
[80654d]3802
[a36e78]3803   ideal G=fetch(@R,F);    //G[i](t(1)^(p^-k),...,t(m)^(p^-k),x(i))=sep(F[i])
[24f458]3804
[a36e78]3805   ideal I=imap(R,I);
3806   ideal J=I+G;
3807   poly el=1;
3808   k=p^k;
3809   for(i=1;i<=m;i++)
3810   {
3811      J=J,var(i)^k-var(m+n+i);
3812      el=el*y(i);
3813   }
[80654d]3814
[a36e78]3815   J=eliminate(J,el);
3816   setring R;
3817   ideal J=imap(@S,J);
3818   return(J);
[80654d]3819}
3820example
3821{ "EXAMPLE:"; echo = 2;
3822   ring R=(5,t),(x,y),dp;
3823   ideal I=x^5-t,y^5-t;
[24f458]3824   zeroRad(I);
[80654d]3825}
3826
[ebecf83]3827///////////////////////////////////////////////////////////////////////////////
[67bd4c]3828
[07c623]3829proc radicalEHV(ideal i)
3830"USAGE:   radicalEHV(i); i ideal.
3831RETURN:  ideal, the radical of i.
[7a7df90]3832NOTE:    Uses the algorithm of Eisenbud/Huneke/Vasconcelos, which
[50cbdc]3833         reduces the computation to the complete intersection case,
[7a7df90]3834         by taking, in the general case, a generic linear combination
3835         of the input.
[07c623]3836         Works only in characteristic 0 or p large.
3837EXAMPLE: example radicalEHV; shows an example
3838"
[67bd4c]3839{
[a36e78]3840   if(attrib(basering,"global")!=1)
3841   {
3842      ERROR(
[07c623]3843      "// Not implemented for this ordering, please change to global ordering."
[a36e78]3844      );
3845   }
3846   if((char(basering)<100)&&(char(basering)!=0))
3847   {
3848      "WARNING: The characteristic is too small, the result may be wrong";
3849   }
3850   ideal J,I,I0,radI0,L,radI1,I2,radI2;
3851   int l,n;
3852   intvec op=option(get);
3853   matrix M;
3854
3855   option(redSB);
3856   list m=mstd(i);
3857        I=m[2];
3858   option(set,op);
3859
3860   int cod=nvars(basering)-dim(m[1]);
3861   //-------------------complete intersection case:----------------------
3862   if(cod==size(m[2]))
3863   {
3864     J=minor(jacob(I),cod);
3865     return(quotient(I,J));
3866   }
3867   //-----first codim elements of I are a complete intersection:---------
3868   for(l=1;l<=cod;l++)
3869   {
3870      I0[l]=I[l];
3871   }
3872   n=dim(std(I0))+cod-nvars(basering);
3873   //-----last codim elements of I are a complete intersection:----------
3874   if(n!=0)
3875   {
3876      for(l=1;l<=cod;l++)
3877      {
3878         I0[l]=I[size(I)-l+1];
3879      }
3880      n=dim(std(I0))+cod-nvars(basering);
3881   }
3882   //-----taking a generic linear combination of the input:--------------
3883   if(n!=0)
3884   {
3885      M=transpose(sparsetriag(size(m[2]),cod,95,1));
3886      I0=ideal(M*transpose(I));
3887      n=dim(std(I0))+cod-nvars(basering);
3888   }
3889   //-----taking a more generic linear combination of the input:---------
3890   if(n!=0)
3891   {
3892      M=transpose(sparsetriag(size(m[2]),cod,0,100));
3893      I0=ideal(M*transpose(I));
3894      n=dim(std(I0))+cod-nvars(basering);
3895   }
3896   if(n==0)
3897   {
3898      J=minor(jacob(I0),cod);
3899      radI0=quotient(I0,J);
3900      L=quotient(radI0,I);
3901      radI1=quotient(radI0,L);
[67bd4c]3902
[a36e78]3903      if(size(reduce(radI1,m[1],1))==0)
3904      {
3905         return(I);
3906      }
[70ab73]3907
[a36e78]3908      I2=sat(I,radI1)[1];
3909
3910      if(deg(I2[1])<=0)
3911      {
3912         return(radI1);
3913      }
3914      return(intersect(radI1,radicalEHV(I2)));
3915   }
3916   //---------------------general case-------------------------------------
3917   return(radical(I));
[67bd4c]3918}
[07c623]3919example
3920{ "EXAMPLE:";  echo = 2;
3921   ring  r = 0,(x,y,z),dp;
3922   poly  p = z2+1;
3923   poly  q = z3+2;
3924   ideal i = p*q^2,y-z2;
3925   ideal pr= radicalEHV(i);
3926   pr;
3927}
3928
[ebecf83]3929///////////////////////////////////////////////////////////////////////////////
[67bd4c]3930
[24f458]3931proc Ann(module M)
[76aca2]3932"USAGE:   Ann(M);  M module
3933RETURN:  ideal, the annihilator of coker(M)
3934NOTE:    The output is the ideal of all elements a of the basering R such that
3935         a * R^m is contained in M  (m=number of rows of M).
3936EXAMPLE: example Ann; shows an example
3937"
[67bd4c]3938{
3939  M=prune(M);  //to obtain a small embedding
[d950c5]3940  ideal ann=quotient1(M,freemodule(nrows(M)));
[e801fe]3941  return(ann);
[67bd4c]3942}
[76aca2]3943example
3944{ "EXAMPLE:"; echo = 2;
3945   ring  r = 0,(x,y,z),lp;
3946   module M = x2-y2,z3;
3947   Ann(M);
3948   M = [1,x2],[y,x];
3949   Ann(M);
3950   qring Q=std(xy-1);
3951   module M=imap(r,M);
3952   Ann(M);
3953}
3954
[ebecf83]3955///////////////////////////////////////////////////////////////////////////////
[67bd4c]3956
3957//computes the equidimensional part of the ideal i of codimension e
[07c623]3958static proc int_ass_primary_e(ideal i, int e)
[67bd4c]3959{
3960  if(homog(i)!=1)
3961  {
[a36e78]3962     i=std(i);
[67bd4c]3963  }
3964  list re=sres(i,0);                   //the resolution
3965  re=minres(re);                       //minimized resolution
3966  ideal ann=AnnExt_R(e,re);
3967  if(nvars(basering)-dim(std(ann))!=e)
3968  {
3969    return(ideal(1));
3970  }
3971  return(ann);
[3939bc]3972}
3973
[ebecf83]3974///////////////////////////////////////////////////////////////////////////////
[67bd4c]3975
3976//computes the annihilator of Ext^n(R/i,R) with given resolution re
3977//n is not necessarily the number of variables
[07c623]3978static proc AnnExt_R(int n,list re)
[67bd4c]3979{
3980  if(n<nvars(basering))
3981  {
[a36e78]3982     matrix f=transpose(re[n+1]);      //Hom(_,R)
3983     module k=nres(f,2)[2];            //the kernel
3984     matrix g=transpose(re[n]);        //the image of Hom(_,R)
[d950c5]3985
[a36e78]3986     ideal ann=quotient1(g,k);           //the anihilator
[67bd4c]3987  }
3988  else
3989  {
[a36e78]3990     ideal ann=Ann(transpose(re[n]));
[67bd4c]3991  }
[3939bc]3992  return(ann);
[e801fe]3993}
[ebecf83]3994///////////////////////////////////////////////////////////////////////////////
[e801fe]3995
[07c623]3996static proc analyze(list pr)
[3939bc]3997{
[a36e78]3998   int ii,jj;
3999   for(ii=1;ii<=size(pr)/2;ii++)
4000   {
4001      dim(std(pr[2*ii]));
4002      idealsEqual(pr[2*ii-1],pr[2*ii]);
4003      "===========================";
4004   }
[e801fe]4005
[a36e78]4006   for(ii=size(pr)/2;ii>1;ii--)
4007   {
4008      for(jj=1;jj<ii;jj++)
[e801fe]4009      {
[a36e78]4010         if(size(reduce(pr[2*jj],std(pr[2*ii],1)))==0)
4011         {
4012            "eingebette Komponente";
4013            jj;
4014            ii;
4015         }
[e801fe]4016      }
[a36e78]4017   }
[e801fe]4018}
4019
[ebecf83]4020///////////////////////////////////////////////////////////////////////////////
4021//
4022//                  Shimoyama-Yokoyama
4023//
4024///////////////////////////////////////////////////////////////////////////////
[e801fe]4025
[07c623]4026static proc simplifyIdeal(ideal i)
[e801fe]4027{
4028  def r=basering;
[3939bc]4029
[e801fe]4030  int j,k;
4031  map phi;
4032  poly p;
[3939bc]4033
[e801fe]4034  ideal iwork=i;
4035  ideal imap1=maxideal(1);
4036  ideal imap2=maxideal(1);
[3939bc]4037
[e801fe]4038
4039  for(j=1;j<=nvars(basering);j++)
4040  {
[a36e78]4041    for(k=1;k<=size(i);k++)
[e801fe]4042    {
4043      if(deg(iwork[k]/var(j))==0)
4044      {
4045        p=-1/leadcoef(iwork[k]/var(j))*iwork[k];
4046        imap1[j]=p+2*var(j);
4047        phi=r,imap1;
4048        iwork=phi(iwork);
4049        iwork=subst(iwork,var(j),0);
4050        iwork[k]=var(j);
4051        imap1=maxideal(1);
[3939bc]4052        imap2[j]=-p;
[e801fe]4053        break;
4054      }
4055    }
4056  }
4057  return(iwork,imap2);
4058}
4059
[3939bc]4060
[e801fe]4061///////////////////////////////////////////////////////
4062// ini_mod
4063// input: a polynomial p
4064// output: the initial term of p as needed
4065// in the context of characteristic sets
4066//////////////////////////////////////////////////////
4067
[07c623]4068static proc ini_mod(poly p)
[e801fe]4069{
4070  if (p==0)
4071  {
4072    return(0);
4073  }
4074  int n; matrix m;
[70ab73]4075  for( n=nvars(basering); n>0; n--)
[e801fe]4076  {
4077    m=coef(p,var(n));
4078    if(m[1,1]!=1)
4079    {
4080      p=m[2,1];
4081      break;
4082    }
4083  }
4084  if(deg(p)==0)
4085  {
4086    p=0;
4087  }
4088  return(p);
4089}
4090///////////////////////////////////////////////////////
4091// min_ass_prim_charsets
4092// input: generators of an ideal PS and an integer cho
4093// If cho=0, the given ordering of the variables is used.
4094// Otherwise, the system tries to find an "optimal ordering",
4095// which in some cases may considerably speed up the algorithm
4096// output: the minimal associated primes of PS
4097// algorithm: via characteriostic sets
4098//////////////////////////////////////////////////////
4099
4100
[07c623]4101static proc min_ass_prim_charsets (ideal PS, int cho)
[e801fe]4102{
4103  if((cho<0) and (cho>1))
4104  {
[a36e78]4105    ERROR("<int> must be 0 or 1");
[e801fe]4106  }
[70ab73]4107  option(notWarnSB);
[e801fe]4108  if(cho==0)
4109  {
4110    return(min_ass_prim_charsets0(PS));
4111  }
4112  else
4113  {
[a36e78]4114     return(min_ass_prim_charsets1(PS));
[e801fe]4115  }
[67bd4c]4116}
[e801fe]4117///////////////////////////////////////////////////////
4118// min_ass_prim_charsets0
4119// input: generators of an ideal PS
4120// output: the minimal associated primes of PS
4121// algorithm: via characteristic sets
4122// the given ordering of the variables is used
4123//////////////////////////////////////////////////////
[67bd4c]4124
[e801fe]4125
[07c623]4126static proc min_ass_prim_charsets0 (ideal PS)
[e801fe]4127{
[466f80]4128  intvec op;
[e801fe]4129  matrix m=char_series(PS);  // We compute an irreducible
4130                             // characteristic series
4131  int i,j,k;
4132  list PSI;
4133  list PHI;  // the ideals given by the characteristic series
4134  for(i=nrows(m);i>=1; i--)
4135  {
[70ab73]4136    PHI[i]=ideal(m[i,1..ncols(m)]);
[e801fe]4137  }
4138  // We compute the radical of each ideal in PHI
4139  ideal I,JS,II;
4140  int sizeJS, sizeII;
4141  for(i=size(PHI);i>=1; i--)
4142  {
[70ab73]4143    I=0;
4144    for(j=size(PHI[i]);j>0;j--)
4145    {
4146      I=I+ini_mod(PHI[i][j]);
4147    }
4148    JS=std(PHI[i]);
[a36e78]4149    sizeJS=size(JS);
4150    for(j=size(I);j>0;j--)
[70ab73]4151    {
4152      II=0;
4153      sizeII=0;
4154      k=0;
4155      while(k<=sizeII)                  // successive saturation
4156      {
4157        op=option(get);
4158        option(returnSB);
4159        II=quotient(JS,I[j]);
4160        option(set,op);
[a36e78]4161        sizeII=size(II);
[70ab73]4162        if(sizeII==sizeJS)
4163        {
4164          for(k=1;k<=sizeII;k++)
4165          {
4166            if(leadexp(II[k])!=leadexp(JS[k])) break;
4167          }
4168        }
4169        JS=II;
4170        sizeJS=sizeII;
4171      }
[e801fe]4172    }
4173    PSI=insert(PSI,JS);
4174  }
4175  int sizePSI=size(PSI);
4176  // We eliminate redundant ideals
4177  for(i=1;i<sizePSI;i++)
4178  {
4179    for(j=i+1;j<=sizePSI;j++)
4180    {
4181      if(size(PSI[i])!=0)
4182      {
4183        if(size(PSI[j])!=0)
4184        {
4185          if(size(NF(PSI[i],PSI[j],1))==0)
4186          {
4187            PSI[j]=ideal(0);
4188          }
4189          else
4190          {
4191            if(size(NF(PSI[j],PSI[i],1))==0)
4192            {
4193              PSI[i]=ideal(0);
4194            }
4195          }
4196        }
4197      }
4198    }
4199  }
4200  for(i=sizePSI;i>=1;i--)
4201  {
4202    if(size(PSI[i])==0)
4203    {
4204      PSI=delete(PSI,i);
4205    }
4206  }
4207  return (PSI);
4208}
4209
4210///////////////////////////////////////////////////////
4211// min_ass_prim_charsets1
4212// input: generators of an ideal PS
4213// output: the minimal associated primes of PS
4214// algorithm: via characteristic sets
4215// input: generators of an ideal PS and an integer i
4216// The system tries to find an "optimal ordering" of
4217// the variables
4218//////////////////////////////////////////////////////
4219
4220
[07c623]4221static proc min_ass_prim_charsets1 (ideal PS)
[e801fe]4222{
[466f80]4223  intvec op;
[e801fe]4224  def oldring=basering;
4225  string n=system("neworder",PS);
[2d2cad9]4226  execute("ring r=("+charstr(oldring)+"),("+n+"),dp;");
[e801fe]4227  ideal PS=imap(oldring,PS);
4228  matrix m=char_series(PS);  // We compute an irreducible
4229                             // characteristic series
4230  int i,j,k;
4231  ideal I;
4232  list PSI;
4233  list PHI;    // the ideals given by the characteristic series
4234  list ITPHI;  // their initial terms
4235  for(i=nrows(m);i>=1; i--)
4236  {
[70ab73]4237    PHI[i]=ideal(m[i,1..ncols(m)]);
4238    I=0;
4239    for(j=size(PHI[i]);j>0;j=j-1)
4240    {
4241      I=I,ini_mod(PHI[i][j]);
4242    }
4243    I=I[2..ncols(I)];
4244    ITPHI[i]=I;
[e801fe]4245  }
4246  setring oldring;
4247  matrix m=imap(r,m);
4248  list PHI=imap(r,PHI);
4249  list ITPHI=imap(r,ITPHI);
4250  // We compute the radical of each ideal in PHI
4251  ideal I,JS,II;
4252  int sizeJS, sizeII;
4253  for(i=size(PHI);i>=1; i--)
4254  {
[70ab73]4255    I=0;
4256    for(j=size(PHI[i]);j>0;j--)
4257    {
4258      I=I+ITPHI[i][j];
4259    }
4260    JS=std(PHI[i]);
4261    sizeJS=size(JS);
[a36e78]4262    for(j=size(I);j>0;j--)
[70ab73]4263    {
4264      II=0;
4265      sizeII=0;
4266      k=0;
4267      while(k<=sizeII)                  // successive iteration
4268      {
4269        op=option(get);
4270        option(returnSB);
4271        II=quotient(JS,I[j]);
4272        option(set,op);
[e801fe]4273//std
[a36e78]4274//         II=std(II);
4275        sizeII=size(II);
[70ab73]4276        if(sizeII==sizeJS)
4277        {
4278          for(k=1;k<=sizeII;k++)
4279          {
4280            if(leadexp(II[k])!=leadexp(JS[k])) break;
4281          }
4282        }
4283        JS=II;
4284        sizeJS=sizeII;
4285      }
[e801fe]4286    }
4287    PSI=insert(PSI,JS);
4288  }
4289  int sizePSI=size(PSI);
4290  // We eliminate redundant ideals
4291  for(i=1;i<sizePSI;i++)
4292  {
4293    for(j=i+1;j<=sizePSI;j++)
4294    {
4295      if(size(PSI[i])!=0)
4296      {
4297        if(size(PSI[j])!=0)
4298        {
4299          if(size(NF(PSI[i],PSI[j],1))==0)
4300          {
4301            PSI[j]=ideal(0);
4302          }
4303          else
4304          {
4305            if(size(NF(PSI[j],PSI[i],1))==0)
4306            {
4307              PSI[i]=ideal(0);
4308            }
4309          }
4310        }
4311      }
4312    }
4313  }
4314  for(i=sizePSI;i>=1;i--)
4315  {
4316    if(size(PSI[i])==0)
4317    {
4318      PSI=delete(PSI,i);
4319    }
4320  }
4321  return (PSI);
4322}
4323
4324
4325/////////////////////////////////////////////////////
4326// proc prim_dec
4327// input:  generators of an ideal I and an integer choose
4328// If choose=0, min_ass_prim_charsets with the given
4329// ordering of the variables is used.
4330// If choose=1, min_ass_prim_charsets with the "optimized"
4331// ordering of the variables is used.
4332// If choose=2, minAssPrimes from primdec.lib is used
4333// If choose=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4334// output: a primary decomposition of I, i.e., a list
4335// of pairs consisting of a standard basis of a primary component
4336// of I and a standard basis of the corresponding associated prime.
4337// To compute the minimal associated primes of a given ideal
4338// min_ass_prim_l is called, i.e., the minimal associated primes
4339// are computed via characteristic sets.
4340// In the homogeneous case, the performance of the procedure
4341// will be improved if I is already given by a minimal set of
4342// generators. Apply minbase if necessary.
4343//////////////////////////////////////////////////////////
4344
4345
[07c623]4346static proc prim_dec(ideal I, int choose)
[e801fe]4347{
[70ab73]4348  if((choose<0) or (choose>3))
4349  {
4350    ERROR("ERROR: <int> must be 0 or 1 or 2 or 3");
4351  }
4352  option(notWarnSB);
[e801fe]4353  ideal H=1; // The intersection of the primary components
4354  list U;    // the leaves of the decomposition tree, i.e.,
4355             // pairs consisting of a primary component of I
4356             // and the corresponding associated prime
4357  list W;    // the non-leaf vertices in the decomposition tree.
4358             // every entry has 6 components:
4359                // 1- the vertex itself , i.e., a standard bais of the
4360                //    given ideal I (type 1), or a standard basis of a
4361                //    pseudo-primary component arising from
4362                //    pseudo-primary decomposition (type 2), or a
4363                //    standard basis of a remaining component arising from
4364                //    pseudo-primary decomposition or extraction (type 3)
4365                // 2- the type of the vertex as indicated above
4366                // 3- the weighted_tree_depth of the vertex
4367                // 4- the tester of the vertex
4368                // 5- a standard basis of the associated prime
4369                //    of a vertex of type 2, or 0 otherwise
4370                // 6- a list of pairs consisting of a standard
4371                //    basis of a minimal associated prime ideal
4372                //    of the father of the vertex and the
4373                //    irreducible factors of the "minimal
4374                //    divisor" of the seperator or extractor
4375                //    corresponding to the prime ideal
4376                //    as computed by the procedure minsat,
4377                //    if the vertex is of type 3, or
4378                //    the empty list otherwise
4379  ideal SI=std(I);
[333b889]4380  if(SI[1]==1)  // primdecSY(ideal(1))
4381  {
4382    return(list());
4383  }
[e801fe]4384  int ncolsSI=ncols(SI);
4385  int ncolsH=1;
4386  W[1]=list(I,1,0,poly(1),ideal(0),list()); // The root of the tree
4387  int weighted_tree_depth;
4388  int i,j;
4389  int check;
4390  list V;  // current vertex
4391  list VV; // new vertex
4392  list QQ;
4393  list WI;
4394  ideal Qi,SQ,SRest,fac;
4395  poly tester;
4396
4397  while(1)
4398  {
4399    i=1;
4400    while(1)
4401    {
4402      while(i<=size(W)) // find vertex V of smallest weighted tree-depth
4403      {
4404        if (W[i][3]<=weighted_tree_depth) break;
4405        i++;
4406      }
4407      if (i<=size(W)) break;
4408      i=1;
4409      weighted_tree_depth++;
4410    }
4411    V=W[i];
4412    W=delete(W,i); // delete V from W
4413
4414    // now proceed by type of vertex V
4415
4416    if (V[2]==2)  // extraction needed
4417    {
4418      SQ,SRest,fac=extraction(V[1],V[5]);
4419                        // standard basis of primary component,
4420                        // standard basis of remaining component,
4421                        // irreducible factors of
4422                        // the "minimal divisor" of the extractor
4423                        // as computed by the procedure minsat,
4424      check=0;
4425      for(j=1;j<=ncolsH;j++)
4426      {
4427        if (NF(H[j],SQ,1)!=0) // Q is not redundant
4428        {
4429          check=1;
4430          break;
4431        }
4432      }
4433      if(check==1)             // Q is not redundant
4434      {
4435        QQ=list();
4436        QQ[1]=list(SQ,V[5]);  // primary component, associated prime,
4437                              // i.e., standard bases thereof
4438        U=U+QQ;
[d950c5]4439        H=intersect(H,SQ);
[e801fe]4440        H=std(H);
4441        ncolsH=ncols(H);
4442        check=0;
4443        if(ncolsH==ncolsSI)
4444        {
4445          for(j=1;j<=ncolsSI;j++)
4446          {
4447            if(leadexp(H[j])!=leadexp(SI[j]))
4448            {
4449              check=1;
4450              break;
4451            }
4452          }
4453        }
4454        else
4455        {
4456          check=1;
4457        }
4458        if(check==0) // H==I => U is a primary decomposition
4459        {
4460          return(U);
4461        }
4462      }
4463      if (SRest[1]!=1)        // the remaining component is not
4464                              // the whole ring
4465      {
4466        if (rad_con(V[4],SRest)==0) // the new vertex is not the
4467                                    // root of a redundant subtree
4468        {
4469          VV[1]=SRest;     // remaining component
4470          VV[2]=3;         // pseudoprimdec_special
4471          VV[3]=V[3]+1;    // weighted depth
4472          VV[4]=V[4];      // the tester did not change
4473          VV[5]=ideal(0);
4474          VV[6]=list(list(V[5],fac));
4475          W=insert(W,VV,size(W));
4476        }
4477      }
4478    }
4479    else
4480    {
4481      if (V[2]==3) // pseudo_prim_dec_special is needed
4482      {
4483        QQ,SRest=pseudo_prim_dec_special_charsets(V[1],V[6],choose);
4484                         // QQ = quadruples:
4485                         // standard basis of pseudo-primary component,
4486                         // standard basis of corresponding prime,
4487                         // seperator, irreducible factors of
4488                         // the "minimal divisor" of the seperator
4489                         // as computed by the procedure minsat,
4490                         // SRest=standard basis of remaining component
4491      }
4492      else     // V is the root, pseudo_prim_dec is needed
4493      {
4494        QQ,SRest=pseudo_prim_dec_charsets(I,SI,choose);
4495                         // QQ = quadruples:
4496                         // standard basis of pseudo-primary component,
4497                         // standard basis of corresponding prime,
4498                         // seperator, irreducible factors of
4499                         // the "minimal divisor" of the seperator
4500                         // as computed by the procedure minsat,
4501                         // SRest=standard basis of remaining component
4502
4503      }
[091424]4504      //check
[e801fe]4505      for(i=size(QQ);i>=1;i--)
4506      //for(i=1;i<=size(QQ);i++)
4507      {
4508        tester=QQ[i][3]*V[4];
4509        Qi=QQ[i][2];
4510        if(NF(tester,Qi,1)!=0)  // the new vertex is not the
4511                                // root of a redundant subtree
4512        {
4513          VV[1]=QQ[i][1];
4514          VV[2]=2;
4515          VV[3]=V[3]+1;
4516          VV[4]=tester;      // the new tester as computed above
4517          VV[5]=Qi;          // QQ[i][2];
4518          VV[6]=list();
4519          W=insert(W,VV,size(W));
4520        }
4521      }
4522      if (SRest[1]!=1)        // the remaining component is not
4523                              // the whole ring
4524      {
4525        if (rad_con(V[4],SRest)==0) // the vertex is not the root
4526                                    // of a redundant subtree
4527        {
4528          VV[1]=SRest;
4529          VV[2]=3;
4530          VV[3]=V[3]+2;
4531          VV[4]=V[4];      // the tester did not change
4532          VV[5]=ideal(0);
4533          WI=list();
4534          for(i=1;i<=size(QQ);i++)
4535          {
4536            WI=insert(WI,list(QQ[i][2],QQ[i][4]));
4537          }
4538          VV[6]=WI;
4539          W=insert(W,VV,size(W));
4540        }
4541      }
4542    }
4543  }
4544}
4545
4546//////////////////////////////////////////////////////////////////////////
4547// proc pseudo_prim_dec_charsets
4548// input: Generators of an arbitrary ideal I, a standard basis SI of I,
4549// and an integer choo
4550// If choo=0, min_ass_prim_charsets with the given
4551// ordering of the variables is used.
4552// If choo=1, min_ass_prim_charsets with the "optimized"
4553// ordering of the variables is used.
4554// If choo=2, minAssPrimes from primdec.lib is used
4555// If choo=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4556// output: a pseudo primary decomposition of I, i.e., a list
4557// of pseudo primary components together with a standard basis of the
4558// remaining component. Each pseudo primary component is
4559// represented by a quadrupel: A standard basis of the component,
4560// a standard basis of the corresponding associated prime, the
4561// seperator of the component, and the irreducible factors of the
4562// "minimal divisor" of the seperator as computed by the procedure minsat,
4563// calls  proc pseudo_prim_dec_i
4564//////////////////////////////////////////////////////////////////////////
4565
4566
[07c623]4567static proc pseudo_prim_dec_charsets (ideal I, ideal SI, int choo)
[e801fe]4568{
4569  list L;          // The list of minimal associated primes,
4570                   // each one given by a standard basis
4571  if((choo==0) or (choo==1))
[70ab73]4572  {
4573    L=min_ass_prim_charsets(I,choo);
4574  }
4575  else
4576  {
4577    if(choo==2)
[e801fe]4578    {
[70ab73]4579      L=minAssPrimes(I);
[e801fe]4580    }
[70ab73]4581    else
[e801fe]4582    {
[70ab73]4583      L=minAssPrimes(I,1);
[e801fe]4584    }
[70ab73]4585    for(int i=size(L);i>=1;i--)
4586    {
4587      L[i]=std(L[i]);
4588    }
4589  }
[e801fe]4590  return (pseudo_prim_dec_i(SI,L));
4591}
4592
4593////////////////////////////////////////////////////////////////
4594// proc pseudo_prim_dec_special_charsets
4595// input: a standard basis of an ideal I whose radical is the
4596// intersection of the radicals of ideals generated by one prime ideal
4597// P_i together with one polynomial f_i, the list V6 must be the list of
4598// pairs (standard basis of P_i, irreducible factors of f_i),
4599// and an integer choo
4600// If choo=0, min_ass_prim_charsets with the given
4601// ordering of the variables is used.
4602// If choo=1, min_ass_prim_charsets with the "optimized"
4603// ordering of the variables is used.
4604// If choo=2, minAssPrimes from primdec.lib is used
4605// If choo=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4606// output: a pseudo primary decomposition of I, i.e., a list
4607// of pseudo primary components together with a standard basis of the
4608// remaining component. Each pseudo primary component is
4609// represented by a quadrupel: A standard basis of the component,
4610// a standard basis of the corresponding associated prime, the
4611// seperator of the component, and the irreducible factors of the
4612// "minimal divisor" of the seperator as computed by the procedure minsat,
4613// calls  proc pseudo_prim_dec_i
4614////////////////////////////////////////////////////////////////
4615
4616
[07c623]4617static proc pseudo_prim_dec_special_charsets (ideal SI,list V6, int choo)
[e801fe]4618{
4619  int i,j,l;
4620  list m;
4621  list L;
4622  int sizeL;
4623  ideal P,SP; ideal fac;
4624  int dimSP;
4625  for(l=size(V6);l>=1;l--)   // creates a list of associated primes
4626                             // of I, possibly redundant
4627  {
4628    P=V6[l][1];
4629    fac=V6[l][2];
4630    for(i=ncols(fac);i>=1;i--)
4631    {
4632      SP=P+fac[i];
4633      SP=std(SP);
4634      if(SP[1]!=1)
4635      {
4636        if((choo==0) or (choo==1))
4637        {
4638          m=min_ass_prim_charsets(SP,choo);  // a list of SB
4639        }
4640        else
4641        {
4642          if(choo==2)
4643          {
4644            m=minAssPrimes(SP);
4645          }
4646          else
4647          {
4648            m=minAssPrimes(SP,1);
4649          }
4650          for(j=size(m);j>=1;j=j-1)
[a36e78]4651            {
4652              m[j]=std(m[j]);
4653            }
[e801fe]4654        }
[3939bc]4655        dimSP=dim(SP);
[e801fe]4656        for(j=size(m);j>=1; j--)
4657        {
4658          if(dim(m[j])==dimSP)
4659          {
4660            L=insert(L,m[j],size(L));
4661          }
4662        }
4663      }
4664    }
4665  }
4666  sizeL=size(L);
4667  for(i=1;i<sizeL;i++)     // get rid of redundant primes
4668  {
4669    for(j=i+1;j<=sizeL;j++)
4670    {
4671      if(size(L[i])!=0)
4672      {
4673        if(size(L[j])!=0)
4674        {
4675          if(size(NF(L[i],L[j],1))==0)
4676          {
4677            L[j]=ideal(0);
4678          }
4679          else
4680          {
4681            if(size(NF(L[j],L[i],1))==0)
4682            {
4683              L[i]=ideal(0);
4684            }
4685          }
4686        }
4687      }
4688    }
4689  }
4690  for(i=sizeL;i>=1;i--)
4691  {
4692    if(size(L[i])==0)
4693    {
4694      L=delete(L,i);
4695    }
4696  }
4697  return (pseudo_prim_dec_i(SI,L));
4698}
4699
4700
4701////////////////////////////////////////////////////////////////
4702// proc pseudo_prim_dec_i
4703// input: A standard basis of an arbitrary ideal I, and standard bases
4704// of the minimal associated primes of I
4705// output: a pseudo primary decomposition of I, i.e., a list
4706// of pseudo primary components together with a standard basis of the
4707// remaining component. Each pseudo primary component is
4708// represented by a quadrupel: A standard basis of the component Q_i,
4709// a standard basis of the corresponding associated prime P_i, the
4710// seperator of the component, and the irreducible factors of the
4711// "minimal divisor" of the seperator as computed by the procedure minsat,
4712////////////////////////////////////////////////////////////////
4713
4714
[07c623]4715static proc pseudo_prim_dec_i (ideal SI, list L)
[e801fe]4716{
4717  list Q;
4718  if (size(L)==1)               // one minimal associated prime only
4719                                // the ideal is already pseudo primary
4720  {
4721    Q=SI,L[1],1;
4722    list QQ;
4723    QQ[1]=Q;
4724    return (QQ,ideal(1));
4725  }
4726
4727  poly f0,f,g;
4728  ideal fac;
4729  int i,j,k,l;
4730  ideal SQi;
4731  ideal I'=SI;
4732  list QP;
4733  int sizeL=size(L);
4734  for(i=1;i<=sizeL;i++)
4735  {
4736    fac=0;
4737    for(j=1;j<=sizeL;j++)           // compute the seperator sep_i
4738                                    // of the i-th component
4739    {
4740      if (i!=j)                       // search g not in L[i], but L[j]
4741      {
4742        for(k=1;k<=ncols(L[j]);k++)
4743        {
4744          if(NF(L[j][k],L[i],1)!=0)
4745          {
4746            break;
4747          }
4748        }
4749        fac=fac+L[j][k];
4750      }
4751    }
4752    // delete superfluous polynomials
[7f38f4]4753    fac=simplify(fac,8+2);
[e801fe]4754    // saturation
4755    SQi,f0,f,fac=minsat_ppd(SI,fac);
4756    I'=I',f;
4757    QP=SQi,L[i],f0,fac;
4758             // the quadrupel:
4759             // a standard basis of Q_i,
4760             // a standard basis of P_i,
4761             // sep_i,
4762             // irreducible factors of
4763             // the "minimal divisor" of the seperator
4764             //  as computed by the procedure minsat,
4765    Q[i]=QP;
4766  }
4767  I'=std(I');
4768  return (Q, I');
4769                   // I' = remaining component
4770}
4771
4772
4773////////////////////////////////////////////////////////////////
4774// proc extraction
4775// input: A standard basis of a pseudo primary ideal I, and a standard
4776// basis of the unique minimal associated prime P of I
4777// output: an extraction of I, i.e., a standard basis of the primary
4778// component Q of I with associated prime P, a standard basis of the
4779// remaining component, and the irreducible factors of the
4780// "minimal divisor" of the extractor as computed by the procedure minsat
4781////////////////////////////////////////////////////////////////
4782
4783
[07c623]4784static proc extraction (ideal SI, ideal SP)
[e801fe]4785{
[aa3811c]4786  list indsets=indepSet(SP,0);
[e801fe]4787  poly f;
4788  if(size(indsets)!=0)      //check, whether dim P != 0
4789  {
4790    intvec v;               // a maximal independent set of variables
4791                            // modulo P
4792    string U;               // the independent variables
4793    string A;               // the dependent variables
4794    int j,k;
4795    int a;                  //  the size of A
4796    int degf;
4797    ideal g;
4798    list polys;
4799    int sizepolys;
4800    list newpoly;
4801    def R=basering;
4802    //intvec hv=hilb(SI,1);
4803    for (k=1;k<=size(indsets);k++)
4804    {
4805      v=indsets[k];
4806      for (j=1;j<=nvars(R);j++)
4807      {
4808        if (v[j]==1)
4809        {
4810          U=U+varstr(j)+",";
4811        }
4812        else
4813        {
4814          A=A+varstr(j)+",";
4815          a++;
4816        }
4817      }
4818
4819      U[size(U)]=")";           // we compute the extractor of I (w.r.t. U)
[24f458]4820      execute("ring RAU=("+charstr(basering)+"),("+A+U+",(dp("+string(a)+"),dp);");
[e801fe]4821      ideal I=imap(R,SI);
4822      //I=std(I,hv);            // the standard basis in (R[U])[A]
4823      I=std(I);            // the standard basis in (R[U])[A]
4824      A[size(A)]=")";
[2d2cad9]4825      execute("ring Rloc=("+charstr(basering)+","+U+",("+A+",dp;");
[e801fe]4826      ideal I=imap(RAU,I);
4827      //"std in lokalisierung:"+newline,I;
4828      ideal h;
4829      for(j=ncols(I);j>=1;j--)
4830      {
4831        h[j]=leadcoef(I[j]);  // consider I in (R(U))[A]
4832      }
4833      setring R;
4834      g=imap(Rloc,h);
4835      kill RAU,Rloc;
4836      U="";
4837      A="";
4838      a=0;
4839      f=lcm(g);
4840      newpoly[1]=f;
4841      polys=polys+newpoly;
4842      newpoly=list();
4843    }
4844    f=polys[1];
4845    degf=deg(f);
4846    sizepolys=size(polys);
4847    for (k=2;k<=sizepolys;k++)
4848    {
4849      if (deg(polys[k])<degf)
4850      {
4851        f=polys[k];
[3939bc]4852        degf=deg(f);
[e801fe]4853      }
4854    }
4855  }
4856  else
4857  {
4858    f=1;
4859  }
4860  poly f0,h0; ideal SQ; ideal fac;
4861  if(f!=1)
4862  {
4863    SQ,f0,h0,fac=minsat(SI,f);
4864    return(SQ,std(SI+h0),fac);
4865             // the tripel
4866             // a standard basis of Q,
4867             // a standard basis of remaining component,
4868             // irreducible factors of
4869             // the "minimal divisor" of the extractor
4870             // as computed by the procedure minsat
4871  }
4872  else
4873  {
4874    return(SI,ideal(1),ideal(1));
4875  }
4876}
4877
4878/////////////////////////////////////////////////////
4879// proc minsat
4880// input:  a standard basis of an ideal I and a polynomial p
4881// output: a standard basis IS of the saturation of I w.r. to p,
4882// the maximal squarefree factor f0 of p,
4883// the "minimal divisor" f of f0 such that the saturation of
4884// I w.r. to f equals the saturation of I w.r. to f0 (which is IS),
4885// the irreducible factors of f
4886//////////////////////////////////////////////////////////
4887
4888
[07c623]4889static proc minsat(ideal SI, poly p)
[e801fe]4890{
4891  ideal fac=factorize(p,1);       //the irreducible factors of p
4892  fac=sort(fac)[1];
4893  int i,k;
4894  poly f0=1;
4895  for(i=ncols(fac);i>=1;i--)
4896  {
4897    f0=f0*fac[i];
4898  }
4899  poly f=1;
4900  ideal iold;
4901  list quotM;
4902  quotM[1]=SI;
4903  quotM[2]=fac;
4904  quotM[3]=f0;
4905  // we deal seperately with the first quotient;
4906  // factors, which do not contribute to this one,
4907  // are omitted
4908  iold=quotM[1];
4909  quotM=minquot(quotM);
4910  fac=quotM[2];
4911  if(quotM[3]==1)
[a36e78]4912    {
4913      return(quotM[1],f0,f,fac);
4914    }
[e801fe]4915  while(special_ideals_equal(iold,quotM[1])==0)
[a36e78]4916    {
4917      f=f*quotM[3];
4918      iold=quotM[1];
4919      quotM=minquot(quotM);
4920    }
[e801fe]4921  return(quotM[1],f0,f,fac);           // the quadrupel ((I:p),f0,f, irr. factors of f)
4922}
4923
4924/////////////////////////////////////////////////////
4925// proc minsat_ppd
4926// input:  a standard basis of an ideal I and a polynomial p
4927// output: a standard basis IS of the saturation of I w.r. to p,
4928// the maximal squarefree factor f0 of p,
4929// the "minimal divisor" f of f0 such that the saturation of
4930// I w.r. to f equals the saturation of I w.r. to f0 (which is IS),
4931// the irreducible factors of f
4932//////////////////////////////////////////////////////////
4933
4934
[07c623]4935static proc minsat_ppd(ideal SI, ideal fac)
[e801fe]4936{
4937  fac=sort(fac)[1];
4938  int i,k;
4939  poly f0=1;
4940  for(i=ncols(fac);i>=1;i--)
4941  {
4942    f0=f0*fac[i];
4943  }
4944  poly f=1;
4945  ideal iold;
4946  list quotM;
4947  quotM[1]=SI;
4948  quotM[2]=fac;
4949  quotM[3]=f0;
4950  // we deal seperately with the first quotient;
4951  // factors, which do not contribute to this one,
4952  // are omitted
4953  iold=quotM[1];
4954  quotM=minquot(quotM);
4955  fac=quotM[2];
4956  if(quotM[3]==1)
[a36e78]4957    {
4958      return(quotM[1],f0,f,fac);
4959    }
[e801fe]4960  while(special_ideals_equal(iold,quotM[1])==0)
4961  {
4962    f=f*quotM[3];
4963    iold=quotM[1];
4964    quotM=minquot(quotM);
4965    k++;
4966  }
[a36e78]4967  return(quotM[1],f0,f,fac);           // the quadrupel ((I:p),f0,f, irr. factors of f)
[e801fe]4968}
4969/////////////////////////////////////////////////////////////////
4970// proc minquot
4971// input: a list with 3 components: a standard basis
4972// of an ideal I, a set of irreducible polynomials, and
4973// there product f0
4974// output: a standard basis of the ideal (I:f0), the irreducible
4975// factors of the "minimal divisor" f of f0 with (I:f0) = (I:f),
4976// the "minimal divisor" f
4977/////////////////////////////////////////////////////////////////
4978
[07c623]4979static proc minquot(list tsil)
[e801fe]4980{
[a36e78]4981   intvec op;
4982   int i,j,k,action;
4983   ideal verg;
4984   list l;
4985   poly g;
4986   ideal laedi=tsil[1];
4987   ideal fac=tsil[2];
4988   poly f=tsil[3];
[e801fe]4989
4990//std
4991//   ideal star=quotient(laedi,f);
4992//   star=std(star);
[a36e78]4993   op=option(get);
4994   option(returnSB);
4995   ideal star=quotient(laedi,f);
4996   option(set,op);
4997   if(special_ideals_equal(laedi,star)==1)
4998     {
4999       return(laedi,ideal(1),1);
5000     }
5001   action=1;
5002   while(action==1)
5003   {
5004      if(size(fac)==1)
[e801fe]5005      {
[a36e78]5006         action=0;
5007         break;
[e801fe]5008      }
[a36e78]5009      for(i=1;i<=size(fac);i++)
5010      {
5011        g=1;
5012         for(j=1;j<=size(fac);j++)
5013         {
5014            if(i!=j)
5015            {
5016               g=g*fac[j];
5017            }
5018         }
[e801fe]5019//std
5020//         verg=quotient(laedi,g);
5021//         verg=std(verg);
[a36e78]5022         op=option(get);
5023         option(returnSB);
5024         verg=quotient(laedi,g);
5025         option(set,op);
5026         if(special_ideals_equal(verg,star)==1)
5027         {
5028            f=g;
5029            fac[i]=0;
5030            fac=simplify(fac,2);
5031            break;
5032         }
5033         if(i==size(fac))
5034         {
5035            action=0;
5036         }
[70ab73]5037      }
[a36e78]5038   }
5039   l=star,fac,f;
5040   return(l);
[e801fe]5041}
5042/////////////////////////////////////////////////
5043// proc special_ideals_equal
5044// input: standard bases of ideal k1 and k2 such that
5045// k1 is contained in k2, or k2 is contained ink1
5046// output: 1, if k1 equals k2, 0 otherwise
5047//////////////////////////////////////////////////
5048
[07c623]5049static proc special_ideals_equal( ideal k1, ideal k2)
[e801fe]5050{
[a36e78]5051   int j;
5052   if(size(k1)==size(k2))
5053   {
5054      for(j=1;j<=size(k1);j++)
[e801fe]5055      {
[a36e78]5056         if(leadexp(k1[j])!=leadexp(k2[j]))
5057         {
5058            return(0);
5059         }
[70ab73]5060      }
[a36e78]5061      return(1);
5062   }
5063   return(0);
[e801fe]5064}
[3939bc]5065
5066
[ebecf83]5067///////////////////////////////////////////////////////////////////////////////
5068
[07c623]5069static proc convList(list l)
[ebecf83]5070{
[a36e78]5071   int i;
5072   list re,he;
5073   for(i=1;i<=size(l)/2;i++)
5074   {
5075      he=l[2*i-1],l[2*i];
5076      re[i]=he;
5077   }
5078   return(re);
[ebecf83]5079}
5080///////////////////////////////////////////////////////////////////////////////
5081
[07c623]5082static proc reconvList(list l)
[ebecf83]5083{
[a36e78]5084   int i;
5085   list re;
5086   for(i=1;i<=size(l);i++)
5087   {
5088      re[2*i-1]=l[i][1];
5089      re[2*i]=l[i][2];
5090   }
5091   return(re);
[ebecf83]5092}
5093
5094///////////////////////////////////////////////////////////////////////////////
5095//
5096//     The main procedures
5097//
5098///////////////////////////////////////////////////////////////////////////////
5099
5100proc primdecGTZ(ideal i)
[091424]5101"USAGE:   primdecGTZ(i); i ideal
[07c623]5102RETURN:  a list pr of primary ideals and their associated primes:
[367e88]5103@format
[7b3971]5104   pr[i][1]   the i-th primary component,
5105   pr[i][2]   the i-th prime component.
5106@end format
5107NOTE:    Algorithm of Gianni/Trager/Zacharias.
[b9b906]5108         Designed for characteristic 0, works also in char k > 0, if it
[091424]5109         terminates (may result in an infinite loop in small characteristic!)
[ebecf83]5110EXAMPLE: example primdecGTZ; shows an example
5111"
5112{
[a36e78]5113   if(attrib(basering,"global")!=1)
5114   {
5115      ERROR(
[07c623]5116      "// Not implemented for this ordering, please change to global ordering."
[a36e78]5117      );
5118   }
5119   if(minpoly!=0)
5120   {
5121      return(algeDeco(i,0));
5122      ERROR(
[24f458]5123      "// Not implemented yet for algebraic extensions.Simulate the ring extension by adding the minpoly to the ideal"
[a36e78]5124      );
5125   }
[24f458]5126  return(convList(decomp(i)));
[ebecf83]5127}
5128example
5129{ "EXAMPLE:";  echo = 2;
[07c623]5130   ring  r = 0,(x,y,z),lp;
[ebecf83]5131   poly  p = z2+1;
[07c623]5132   poly  q = z3+2;
5133   ideal i = p*q^2,y-z2;
[091424]5134   list pr = primdecGTZ(i);
[ebecf83]5135   pr;
5136}
5137///////////////////////////////////////////////////////////////////////////////
[6fa3af]5138proc absPrimdecGTZ(ideal I)
5139"USAGE:   absPrimdecGTZ(I); I ideal
5140ASSUME:  Ground field has characteristic 0.
5141RETURN:  a ring containing two lists: @code{absolute_primes} (the absolute
5142         prime components of I) and @code{primary_decomp} (the output of
5143         @code{primdecGTZ(I)}).
5144         The list absolute_primes has to be interpreted as follows:
5145         each entry describes a class of conjugated absolute primes,
5146@format
[326dba]5147   absolute_primes[i][1]   the absolute prime component,
[6fa3af]5148   absolute_primes[i][2]   the number of conjugates.
5149@end format
5150         The first entry of @code{absolute_primes[i][1]} is the minimal
5151         polynomial of a minimal finite field extension over which the
5152         absolute prime component is defined.
5153NOTE:    Algorithm of Gianni/Trager/Zacharias combined with the
5154         @code{absFactorize} command.
5155SEE ALSO: primdecGTZ; absFactorize
5156EXAMPLE: example absPrimdecGTZ; shows an example
5157"
5158{
[70ab73]5159  if (char(basering) != 0)
5160  {
[6fa3af]5161    ERROR("primdec.lib::absPrimdecGTZ is only implemented for "+
5162           +"characteristic 0");
5163  }
5164
[70ab73]5165  if(attrib(basering,"global")!=1)
5166  {
5167    ERROR(
[6fa3af]5168      "// Not implemented for this ordering, please change to global ordering."
[70ab73]5169    );
5170  }
5171  if(minpoly!=0)
5172  {
5173    //return(algeDeco(i,0));
5174    ERROR(
[6fa3af]5175      "// Not implemented yet for algebraic extensions.Simulate the ring extension by adding the minpoly to the ideal"
[70ab73]5176    );
5177  }
[6fa3af]5178  def R=basering;
5179  int n=nvars(R);
5180  list L=decomp(I,3);
[4719f0]5181  string newvar=L[1][3];
[6fa3af]5182  int k=find(newvar,",",find(newvar,",")+1);
5183  newvar=newvar[k+1..size(newvar)];
5184  list lR=ringlist(R);
[1d430ab]5185  int i,de,ii;
5186  intvec vv=1:n;
5187  //for(i=1;i<=n;i++){vv[i]=1;}
[6fa3af]5188
5189  list orst;
5190  orst[1]=list("dp",vv);
5191  orst[2]=list("dp",intvec(1));
5192  orst[3]=list("C",0);
5193  lR[3]=orst;
5194  lR[2][n+1] = newvar;
5195  def Rz = ring(lR);
5196  setring Rz;
5197  list L=imap(R,L);
5198  list absolute_primes,primary_decomp;
5199  ideal I,M,N,K;
5200  M=maxideal(1);
5201  N=maxideal(1);
5202  poly p,q,f,g;
5203  map phi,psi;
[1d430ab]5204  string tvar;
[6fa3af]5205  for(i=1;i<=size(L);i++)
5206  {
[1d430ab]5207    tvar=L[i][4];
5208    ii=find(tvar,"+");
5209    while(ii)
5210    {
5211      tvar=tvar[ii+1..size(tvar)];
5212      ii=find(tvar,"+");
5213    }
5214    for(ii=1;ii<=nvars(basering);ii++)
5215    {
5216      if(tvar==string(var(ii))) break;
5217    }
[6fa3af]5218    I=L[i][2];
5219    execute("K="+L[i][3]+";");
5220    p=K[1];
5221    q=K[2];
5222    execute("f="+L[i][4]+";");
[1d430ab]5223    g=2*var(ii)-f;
5224    M[ii]=f;
5225    N[ii]=g;
[9d7c01]5226    de=deg(p);
[1d430ab]5227    psi=Rz,M;
5228    phi=Rz,N;
[6fa3af]5229    I=phi(I),p,q;
5230    I=std(I);
[9d7c01]5231    absolute_primes[i]=list(psi(I),de);
[6fa3af]5232    primary_decomp[i]=list(L[i][1],L[i][2]);
5233  }
5234  export(primary_decomp);
5235  export(absolute_primes);
5236  setring R;
5237  dbprint( printlevel-voice+3,"
5238// 'absPrimdecGTZ' created a ring, in which two lists absolute_primes (the
5239// absolute prime components) and primary_decomp (the primary and prime
5240// components over the current basering) are stored.
5241// To access the list of absolute prime components, type (if the name S was
5242// assigned to the return value):
5243        setring S; absolute_primes; ");
5244
5245  return(Rz);
5246}
5247example
5248{ "EXAMPLE:";  echo = 2;
5249   ring  r = 0,(x,y,z),lp;
5250   poly  p = z2+1;
5251   poly  q = z3+2;
5252   ideal i = p*q^2,y-z2;
5253   def S = absPrimdecGTZ(i);
5254   setring S;
5255   absolute_primes;
5256}
[1d430ab]5257
[6fa3af]5258///////////////////////////////////////////////////////////////////////////////
5259
[7b3971]5260proc primdecSY(ideal i, list #)
[7f7c25e]5261"USAGE:   primdecSY(I, c); I ideal, c int (optional)
[07c623]5262RETURN:  a list pr of primary ideals and their associated primes:
[367e88]5263@format
[7b3971]5264   pr[i][1]   the i-th primary component,
5265   pr[i][2]   the i-th prime component.
5266@end format
5267NOTE:    Algorithm of Shimoyama/Yokoyama.
5268@format
5269   if c=0,  the given ordering of the variables is used,
[7f7c25e]5270   if c=1,  minAssChar tries to use an optimal ordering (default),
[7b3971]5271   if c=2,  minAssGTZ is used,
5272   if c=3,  minAssGTZ and facstd are used.
5273@end format
[ebecf83]5274EXAMPLE: example primdecSY; shows an example
5275"
5276{
[a36e78]5277   if(attrib(basering,"global")!=1)
5278   {
5279      ERROR(
[07c623]5280      "// Not implemented for this ordering, please change to global ordering."
[a36e78]5281      );
5282   }
5283   i=simplify(i,2);
5284   if ((i[1]==0)||(i[1]==1))
5285   {
5286     list L=list(ideal(i[1]),ideal(i[1]));
5287     return(list(L));
5288   }
5289   if(minpoly!=0)
5290   {
5291      return(algeDeco(i,1));
5292   }
5293   if (size(#)==1)
5294   { return(prim_dec(i,#[1])); }
5295   else
5296   { return(prim_dec(i,1)); }
[ebecf83]5297}
5298example
5299{ "EXAMPLE:";  echo = 2;
[07c623]5300   ring  r = 0,(x,y,z),lp;
[ebecf83]5301   poly  p = z2+1;
[07c623]5302   poly  q = z3+2;
5303   ideal i = p*q^2,y-z2;
[091424]5304   list pr = primdecSY(i);
[ebecf83]5305   pr;
5306}
5307///////////////////////////////////////////////////////////////////////////////
[25c431]5308proc minAssGTZ(ideal i,list #)
[7f7c25e]5309"USAGE:    minAssGTZ(I[, l]); I ideal, l list (optional)
5310   @* Optional parameters in list l (can be entered in any order):
5311   @* 0, \"facstd\" -> uses facstd to first decompose the ideal (default)
5312   @* 1, \"noFacstd\" -> does not use facstd
5313   @* \"GTZ\" -> the original algorithm by Gianni, Trager and Zacharias is used
5314   @* \"SL\" -> GTZ algorithm with modificiations by Laplagne is used (default)
5315
5316RETURN:  a list, the minimal associated prime ideals of I.
[24f458]5317NOTE:    Designed for characteristic 0, works also in char k > 0 based
5318         on an algorithm of Yokoyama
[ebecf83]5319EXAMPLE: example minAssGTZ; shows an example
5320"
5321{
[70ab73]5322  int j;
5323  string algorithm;
5324  string facstdOption;
5325  int useFac;
[808a9f3]5326
[70ab73]5327  // Set input parameters
5328  algorithm = "SL";         // Default: SL algorithm
5329  facstdOption = "facstd";
5330  if(size(#) > 0)
5331  {
5332    int valid;
5333    for(j = 1; j <= size(#); j++)
5334    {
5335      valid = 0;
5336      if((typeof(#[j]) == "int") or (typeof(#[j]) == "number"))
5337      {
5338        if (#[j] == 1) {facstdOption = "noFacstd"; valid = 1;}    // If #[j] == 1, facstd is not used.
5339        if (#[j] == 0) {facstdOption = "facstd";   valid = 1;}    // If #[j] == 0, facstd is used.
5340      }
5341      if(typeof(#[j]) == "string")
5342      {
5343        if((#[j] == "GTZ") || (#[j] == "SL"))
5344        {
5345          algorithm = #[j];
5346          valid = 1;
5347        }
5348        if((#[j] == "noFacstd") || (#[j] == "facstd"))
5349        {
5350          facstdOption = #[j];
5351          valid = 1;
5352        }
5353      }
5354      if(valid == 0)
5355      {
5356        dbprint(1, "Warning! The following input parameter was not recognized:", #[j]);
5357      }
5358    }
5359  }
5360
5361  if(attrib(basering,"global")!=1)
5362  {
5363    ERROR(
[07c623]5364      "// Not implemented for this ordering, please change to global ordering."
[70ab73]5365    );
5366  }
5367  if(minpoly!=0)
5368  {
5369    return(algeDeco(i,2));
5370  }
[808a9f3]5371
[70ab73]5372  list result = minAssPrimes(i, facstdOption, algorithm);
5373  return(result);
[ebecf83]5374}
5375example
5376{ "EXAMPLE:";  echo = 2;
[07c623]5377   ring  r = 0,(x,y,z),dp;
[ebecf83]5378   poly  p = z2+1;
[07c623]5379   poly  q = z3+2;
5380   ideal i = p*q^2,y-z2;
5381   list pr = minAssGTZ(i);
[ebecf83]5382   pr;
5383}
5384
5385///////////////////////////////////////////////////////////////////////////////
[2d3c9b]5386proc minAssChar(ideal i, list #)
[7f7c25e]5387"USAGE:   minAssChar(I[,c]); i ideal, c int (optional).
[7b3971]5388RETURN:  list, the minimal associated prime ideals of i.
5389NOTE:    If c=0, the given ordering of the variables is used. @*
[2d3c9b]5390         Otherwise, the system tries to find an optimal ordering,
[7b3971]5391         which in some cases may considerably speed up the algorithm. @*
5392         Due to a bug in the factorization, the result may be not completely
[07c623]5393         decomposed in small characteristic.
[9050ca]5394EXAMPLE: example minAssChar; shows an example
[22c0fc9]5395"
5396{
[a36e78]5397   if(attrib(basering,"global")!=1)
5398   {
5399      ERROR(
[07c623]5400      "// Not implemented for this ordering, please change to global ordering."
[a36e78]5401      );
5402   }
5403   if (size(#)==1)
5404   { return(min_ass_prim_charsets(i,#[1])); }
5405   else
5406   { return(min_ass_prim_charsets(i,1)); }
[22c0fc9]5407}
5408example
5409{ "EXAMPLE:";  echo = 2;
[07c623]5410   ring  r = 0,(x,y,z),dp;
[22c0fc9]5411   poly  p = z2+1;
[07c623]5412   poly  q = z3+2;
5413   ideal i = p*q^2,y-z2;
5414   list pr = minAssChar(i);
[22c0fc9]5415   pr;
5416}
[ebecf83]5417///////////////////////////////////////////////////////////////////////////////
5418proc equiRadical(ideal i)
[7f7c25e]5419"USAGE:   equiRadical(I); I ideal
5420RETURN:  ideal, intersection of associated primes of I of maximal dimension.
5421NOTE:    A combination of the algorithms of Krick/Logar (with modifications by Laplagne) and Kemper is used.
[07c623]5422         Works also in positive characteristic (Kempers algorithm).
[ebecf83]5423EXAMPLE: example equiRadical; shows an example
5424"
5425{
[d88470]5426  if(attrib(basering,"global")!=1)
5427  {
[a36e78]5428     ERROR(
[d88470]5429     "// Not implemented for this ordering, please change to global ordering."
[a36e78]5430     );
[d88470]5431  }
5432  return(radical(i, 1));
[ebecf83]5433}
5434example
5435{ "EXAMPLE:";  echo = 2;
[07c623]5436   ring  r = 0,(x,y,z),dp;
[ebecf83]5437   poly  p = z2+1;
[07c623]5438   poly  q = z3+2;
5439   ideal i = p*q^2,y-z2;
[ebecf83]5440   ideal pr= equiRadical(i);
5441   pr;
5442}
[fc5095]5443
[ebecf83]5444///////////////////////////////////////////////////////////////////////////////
[f0daaa2]5445proc radical(ideal i, list #)
[7f7c25e]5446"USAGE: radical(I[, l]); I ideal, l list (optional)
5447 @*  Optional parameters in list l (can be entered in any order):
5448 @*  0, \"fullRad\" -> full radical is computed (default)
5449 @*  1, \"equiRad\" -> equiRadical is computed
5450 @*  \"KL\" -> Krick/Logar algorithm is used
5451 @*  \"SL\" -> modifications by Laplagne are used (default)
5452 @*  \"facstd\" -> uses facstd to first decompose the ideal (default for non homogeneous ideals)
5453 @*  \"noFacstd\" -> does not use facstd (default for homogeneous ideals)
5454RETURN:  ideal, the radical of I (or the equiradical if required in the input parameters)
5455NOTE:    A combination of the algorithms of Krick/Logar (with modifications by Laplagne) and Kemper is used.
[07c623]5456         Works also in positive characteristic (Kempers algorithm).
[ebecf83]5457EXAMPLE: example radical; shows an example
5458"
5459{
[d88470]5460  dbprint(printlevel - voice, "Radical, version 2006.05.08");
5461  if(attrib(basering,"global")!=1)
5462  {
[70ab73]5463    ERROR(
[d88470]5464     "// Not implemented for this ordering, please change to global ordering."
[70ab73]5465    );
[d88470]5466  }
5467  if(size(i) == 0){return(ideal(0));}
5468  int j;
5469  def P0 = basering;
5470  list Pl=ringlist(P0);
5471  intvec dp_w;
5472  for(j=nvars(P0);j>0;j--) {dp_w[j]=1;}
5473  Pl[3]=list(list("dp",dp_w),list("C",0));
5474  def @P=ring(Pl);
5475  setring @P;
5476  ideal i=imap(P0,i);
5477
5478  int il;
5479  string algorithm;
5480  int useFac;
5481
5482  // Set input parameters
5483  algorithm = "SL";                                 // Default: SL algorithm
5484  il = 0;                                           // Default: Full radical (not only equiRadical)
5485  if (homog(i) == 1)
5486  {   // Default: facStd is used, except if the ideal is homogeneous.
[70ab73]5487    useFac = 0;
5488  }
5489  else
5490  {
5491    useFac = 1;
[d88470]5492  }
[70ab73]5493  if(size(#) > 0)
5494  {
[d88470]5495    int valid;
5496    for(j = 1; j <= size(#); j++)
5497    {
5498      valid = 0;
5499      if((typeof(#[j]) == "int") or (typeof(#[j]) == "number"))
5500      {
5501        il = #[j];          // If il == 1, equiRadical is computed
5502        valid = 1;
[7f7c25e]5503      }
[70ab73]5504      if(typeof(#[j]) == "string")
5505      {
5506        if(#[j] == "KL")
5507        {
[d88470]5508          algorithm = "KL";
5509          valid = 1;
5510        }
[70ab73]5511        if(#[j] == "SL")
5512        {
[d88470]5513          algorithm = "SL";
5514          valid = 1;
5515        }
[70ab73]5516        if(#[j] == "noFacstd")
5517        {
[d88470]5518          useFac = 0;
[70ab73]5519          valid = 1;
5520        }
5521        if(#[j] == "facstd")
5522        {
[d88470]5523          useFac = 1;
[70ab73]5524          valid = 1;
5525        }
5526        if(#[j] == "equiRad")
5527        {
[d88470]5528          il = 1;
[70ab73]5529          valid = 1;
5530        }
5531        if(#[j] == "fullRad")
5532        {
[d88470]5533          il = 0;
[70ab73]5534          valid = 1;
5535        }
[d88470]5536      }
5537      if(valid == 0)
5538      {
5539        dbprint(1, "Warning! The following input parameter was not recognized:", #[j]);
5540      }
5541    }
5542  }
[f0daaa2]5543
[d88470]5544  ideal rad = 1;
5545  intvec op = option(get);
5546  list qr = simplifyIdeal(i);
5547  map phi = @P, qr[2];
[0c33fb]5548
[d88470]5549  option(redSB);
5550  i = groebner(qr[1]);
5551  option(set, op);
5552  int di = dim(i);
[0c33fb]5553
[d88470]5554  if(di == 0)
5555  {
5556    i = zeroRad(i, qr[1]);
[a90eb0]5557    option(redSB);
[d88470]5558    i=interred(phi(i));
[a90eb0]5559    option(set, op);
[d88470]5560    setring(P0);
5561    i=imap(@P,i);
5562    return(i);
5563  }
[0c33fb]5564
[d88470]5565  option(redSB);
5566  list pr;
5567  if(useFac == 1)
5568  {
5569    pr = facstd(i);
[70ab73]5570  }
5571  else
5572  {
[d88470]5573    pr = i;
5574  }
5575  option(set, op);
5576  int s = size(pr);
[70ab73]5577  if(useFac == 1)
5578  {
[d88470]5579    dbprint(printlevel - voice, "Number of components returned by facstd: ", s);
5580  }
5581  for(j = 1; j <= s; j++)
5582  {
5583    attrib(pr[s + 1 - j], "isSB", 1);
5584    if((size(reduce(rad, pr[s + 1 - j], 1)) != 0) && ((dim(pr[s + 1 - j]) == di) || !il))
5585    {
5586      // SL Debug messages
5587      dbprint(printlevel-voice, "We shall compute the radical of ", pr[s + 1 - j]);
5588      dbprint(printlevel-voice, "The dimension is: ", dim(pr[s+1-j]));
[f0daaa2]5589
[d88470]5590      if(algorithm == "KL")
[0266ac]5591      {
[d88470]5592        rad = intersect(rad, radicalKL(pr[s + 1 - j], rad, il));
[7f7c25e]5593      }
[70ab73]5594      if(algorithm == "SL")
5595      {
[d88470]5596        rad = intersect(rad, radicalSL(pr[s + 1 - j], il));
5597      }
5598    }
5599    else
5600    {
5601      // SL Debug
5602      dbprint(printlevel-voice, "The radical of this component is not needed.");
5603      dbprint(printlevel-voice, "size(reduce(rad, pr[s + 1 - j], 1))",
5604              size(reduce(rad, pr[s + 1 - j], 1)));
5605      dbprint(printlevel-voice, "dim(pr[s + 1 - j])", dim(pr[s + 1 - j]));
5606      dbprint(printlevel-voice, "il", il);
5607    }
5608  }
5609  rad=interred(phi(rad));
5610  setring(P0);
5611  i=imap(@P,rad);
5612  return(i);
[1918008]5613}
[ebecf83]5614example
5615{ "EXAMPLE:";  echo = 2;
[07c623]5616   ring  r = 0,(x,y,z),dp;
[ebecf83]5617   poly  p = z2+1;
[07c623]5618   poly  q = z3+2;
5619   ideal i = p*q^2,y-z2;
[f0daaa2]5620   ideal pr = radical(i);
[ebecf83]5621   pr;
5622}
[f0daaa2]5623
5624///////////////////////////////////////////////////////////////////////////////
5625//
5626// Computes the radical of I using KL algorithm.
[7d56875]5627// The only difference with the previous implementation of KL algorithm is
[f0daaa2]5628// that now it uses block dp instead of lp ordering for the reduction to the
5629// zerodimensional case.
[f995aa]5630// The reduction step has been moved to the new routine radicalReduction, so that it can be
5631// used also by radicalSL procedure.
[f0daaa2]5632//
[70ab73]5633static proc radicalKL(ideal I, ideal ser, list #)
5634{
[f3c6e5]5635// ideal I     The ideal for which the radical is computed
5636// ideal ser   Used to reduce components already obtained
5637// list #      If #[1] = 1, equiradical is computed.
[f0daaa2]5638
[70ab73]5639  // I needs to be a Groebner basis.
5640  if (attrib(I, "isSB") != 1)
5641  {
5642    I = groebner(I);
5643  }
[f0daaa2]5644
[70ab73]5645  ideal rad;                                // The radical
5646  int allIndep = 1;                // All max independent sets are used
[0266ac]5647
[70ab73]5648  list result = radicalReduction(I, ser, allIndep, #);
5649  int done = result[3];
5650  rad = result[1];
5651  if (done == 0)
5652  {
5653    rad = intersect(rad, radicalKL(result[2], ideal(1), #));
5654  }
5655  return(rad);
5656}
[f0daaa2]5657
5658
5659///////////////////////////////////////////////////////////////////////////////
5660//
[f995aa]5661// Computes the radical of I via Laplagne algorithm, using zerodimensional radical in
[f0daaa2]5662// the zero dimensional case.
5663// For the reduction to the zerodimensional case, it uses the procedure
[f995aa]5664// radical, with some modifications to avoid the recursion.
[f0daaa2]5665//
[f995aa]5666static proc radicalSL(ideal I, list #)
[f0daaa2]5667// Input = I, ideal
5668//         #, list. If #[1] = 1, then computes only the equiradical.
5669// Output = (P, primaryDec) where P = rad(I) and primaryDec is the list of the radicals
5670// obtained in intermediate steps.
5671{
[70ab73]5672  ideal rad = 1;
5673  ideal equiRad = 1;
5674  list primes;
5675  int k;                        // Counter
5676  int il;                 // If il = 1, only the equiradical is required.
5677  int iDim;                // The dimension of I
5678  int stop = 0;   // Checks if the radical has been obtained
5679
5680  if (attrib(I, "isSB") != 1)
5681  {
5682    I = groebner(I);
5683  }
5684  iDim = dim(I);
5685
5686  // Checks if only equiradical is required
5687  if (size(#) > 0)
5688  {
5689    il = #[1];
5690  }
5691
5692  while(stop == 0)
5693  {
5694    dbprint (printlevel-voice, "// We call radLoopR to find new prime ideals.");
5695    primes = radicalSLIteration(I, rad);                         // A list of primes or intersections of primes, not included in P
5696    dbprint (printlevel - voice, "// Output of Iteration Step:");
5697    dbprint (printlevel - voice, primes);
5698    if (size(primes) > 0)
5699    {
5700      dbprint (printlevel - voice, "// We intersect P with the ideal just obtained.");
5701      for(k = 1; k <= size(primes); k++)
5702      {
5703        rad = intersect(rad, primes[k]);
5704        if (il == 1)
5705        {
5706          if (attrib(primes[k], "isSB") != 1)
5707          {
5708            primes[k] = groebner(primes[k]);
5709          }
5710          if (iDim == dim(primes[k]))
5711          {
5712            equiRad = intersect(equiRad, primes[k]);
5713          }
[7f7c25e]5714        }
[70ab73]5715      }
[7f7c25e]5716    }
[70ab73]5717    else
5718    {
5719      stop = 1;
[7f7c25e]5720    }
[70ab73]5721  }
5722  if (il == 0)
5723  {
5724    return(rad);
5725  }
5726  else
5727  {
5728    return(equiRad);
5729  }
5730}
[f0daaa2]5731
5732//////////////////////////////////////////////////////////////////////////
5733// Based on radicalKL.
[f995aa]5734// It contains all of old version of proc radicalKL except the recursion call.
[a36e78]5735//
[f0daaa2]5736// Output:
5737// #1 -> output ideal, the part of the radical that has been computed
5738// #2 -> complementary ideal, the part of the ideal I whose radical remains to be computed
5739//       = (I, h) in KL algorithm
5740//       This is not used in the new algorithm. It is part of KL algorithm
5741// #3 -> done, 1: output = radical, there is no need to continue
5742//                   0: radical = output \cap \sqrt{complementary ideal}
5743//       This is not used in the new algorithm. It is part of KL algorithm
5744
[70ab73]5745static proc radicalReduction(ideal I, ideal ser, int allIndep, list #)
5746{
[6fd3a2]5747// allMaximal      1 -> Indicates that the reduction to the zerodim case
5748//                    must be done for all indep set of the leading terms ideal
5749//                 0 -> Otherwise
5750// ideal ser       Only for radicalKL. (Same as in radicalKL)
[7d56875]5751// list #          Only for radicalKL (If #[1] = 1,
[6fd3a2]5752//                    only equiradical is required.
5753//                    It is used to set the value of done.)
[f0daaa2]5754
[70ab73]5755  attrib(I, "isSB", 1);   // I needs to be a reduced standard basis
5756  list indep, fett;
5757  intvec @w, @hilb, op;
5758  int @wr, @n, @m, lauf, di;
5759  ideal fac, @h, collectrad, lsau;
5760  poly @q;
5761  string @va, quotring;
5762
5763  def @P = basering;
5764  int jdim = dim(I);               // Computes the dimension of I
5765  int  homo = homog(I);            // Finds out if I is homogeneous
5766  ideal rad = ideal(1);            // The unit ideal
5767  ideal te = ser;
5768  if(size(#) > 0)
5769  {
5770    @wr = #[1];
5771  }
5772  if(homo == 1)
5773  {
5774    for(@n = 1; @n <= nvars(basering); @n++)
5775    {
5776      @w[@n] = ord(var(@n));
5777    }
5778    @hilb = hilb(I, 1, @w);
5779  }
[f0daaa2]5780
[70ab73]5781  // SL 2006.04.11 1 Debug messages
5782  dbprint(printlevel-voice, "//Computes the radical of the ideal:", I);
5783  // SL 2006.04.11 2 Debug messages
[f0daaa2]5784
5785  //---------------------------------------------------------------------------
5786  //j is the ring
5787  //---------------------------------------------------------------------------
5788
[70ab73]5789  if (jdim==-1)
5790  {
5791    return(ideal(1), ideal(1), 1);
5792  }
[f0daaa2]5793
5794  //---------------------------------------------------------------------------
5795  //the zero-dimensional case
5796  //---------------------------------------------------------------------------
5797
[70ab73]5798  if (jdim==0)
5799  {
5800    return(zeroRad(I), ideal(1), 1);
5801  }
[f0daaa2]5802
[70ab73]5803  //-------------------------------------------------------------------------
5804  //search for a maximal independent set indep,i.e.
5805  //look for subring such that the intersection with the ideal is zero
5806  //j intersected with K[var(indep[3]+1),...,var(nvar)] is zero,
5807  //indep[1] is the new varstring, indep[2] the string for the block-ordering
5808  //-------------------------------------------------------------------------
5809
[6fd3a2]5810  // SL 2006-04-24 1   If allIndep = 0, then it only computes one maximal
5811  //                     independent set.
5812  //                     This looks better for the new algorithm but not for KL
5813  //                     algorithm
[70ab73]5814  list parameters = allIndep;
5815  indep = newMaxIndependSetDp(I, parameters);
5816  // SL 2006-04-24 2
5817
5818  for(@m = 1; @m <= size(indep); @m++)
5819  {
5820    if((indep[@m][1] == varstr(basering)) && (@m == 1))
5821    //this is the good case, nothing to do, just to have the same notations
5822    //change the ring
5823    {
5824      execute("ring gnir1 = ("+charstr(basering)+"),("+varstr(basering)+"),("
[f0daaa2]5825                              +ordstr(basering)+");");
[70ab73]5826      ideal @j = fetch(@P, I);
5827      attrib(@j, "isSB", 1);
5828    }
5829    else
5830    {
5831      @va = string(maxideal(1));
[f0daaa2]5832
[70ab73]5833      execute("ring gnir1 = (" + charstr(basering) + "), (" + indep[@m][1] + "),("
[f0daaa2]5834                              + indep[@m][2] + ");");
[70ab73]5835      execute("map phi = @P," + @va + ";");
5836      if(homo == 1)
5837      {
5838        ideal @j = std(phi(I), @hilb, @w);
[0266ac]5839      }
5840      else
5841      {
[70ab73]5842        ideal @j = groebner(phi(I));
5843      }
5844    }
5845    if((deg(@j[1]) == 0) || (dim(@j) < jdim))
5846    {
5847      setring @P;
5848      break;
5849    }
5850    for (lauf = 1; lauf <= size(@j); lauf++)
5851    {
5852      fett[lauf] = size(@j[lauf]);
5853    }
5854    //------------------------------------------------------------------------
5855    // We have now the following situation:
5856    // j intersected with K[var(nnp+1),..,var(nva)] is zero so we may pass
5857    // to this quotientring, j is there still a standardbasis, the
5858    // leading coefficients of the polynomials there (polynomials in
5859    // K[var(nnp+1),..,var(nva)]) are collected in the list h,
5860    // we need their LCM, gh, because of the following:
5861    // let (j:gh^n)=(j:gh^infinity) then j*K(var(nnp+1),..,var(nva))[..rest..]
5862    // intersected with K[var(1),...,var(nva)] is (j:gh^n)
5863    // on the other hand j = ((j, gh^n) intersected with (j : gh^n))
5864
5865    //------------------------------------------------------------------------
5866    // The arrangement for the quotientring K(var(nnp+1),..,var(nva))[..rest..]
5867    // and the map phi:K[var(1),...,var(nva)] ----->
5868    // K(var(nnpr+1),..,var(nva))[..the rest..]
5869    //------------------------------------------------------------------------
5870    quotring = prepareQuotientRingDp(nvars(basering) - indep[@m][3]);
5871    //------------------------------------------------------------------------
5872    // We pass to the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
5873    //------------------------------------------------------------------------
5874
5875    execute(quotring);
5876
5877    // @j considered in the quotientring
5878    ideal @j = imap(gnir1, @j);
5879
5880    kill gnir1;
5881
5882    // j is a standardbasis in the quotientring but usually not minimal
5883    // here it becomes minimal
5884
5885    @j = clearSB(@j, fett);
5886
5887    // We need later LCM(h[1],...) = gh for saturation
5888    ideal @h;
5889    if(deg(@j[1]) > 0)
5890    {
5891      for(@n = 1; @n <= size(@j); @n++)
5892      {
5893        @h[@n] = leadcoef(@j[@n]);
[0266ac]5894      }
[70ab73]5895      op = option(get);
5896      option(redSB);
[6fd3a2]5897      @j = std(@j);  //to obtain a reduced standardbasis
[70ab73]5898      option(set, op);
5899
5900      // SL 1 Debug messages
5901      dbprint(printlevel - voice, "zero_rad", basering, @j, dim(groebner(@j)));
5902      ideal zero_rad = zeroRad(@j);
5903      dbprint(printlevel - voice, "zero_rad passed");
5904      // SL 2
5905    }
5906    else
5907    {
5908      ideal zero_rad = ideal(1);
5909    }
[f0daaa2]5910
[70ab73]5911    // We need the intersection of the ideals in the list quprimary with the
5912    // polynomialring, i.e. let q=(f1,...,fr) in the quotientring such an ideal
5913    // but fi polynomials, then the intersection of q with the polynomialring
5914    // is the saturation of the ideal generated by f1,...,fr with respect to
5915    // h which is the lcm of the leading coefficients of the fi considered in
5916    // the quotientring: this is coded in saturn
[f0daaa2]5917
[70ab73]5918    zero_rad = std(zero_rad);
[f0daaa2]5919
[70ab73]5920    ideal hpl;
[f0daaa2]5921
[70ab73]5922    for(@n = 1; @n <= size(zero_rad); @n++)
5923    {
5924      hpl = hpl, leadcoef(zero_rad[@n]);
5925    }
[f0daaa2]5926
[70ab73]5927    //------------------------------------------------------------------------
5928    // We leave  the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
5929    // back to the polynomialring
5930    //------------------------------------------------------------------------
5931    setring @P;
[f0daaa2]5932
[70ab73]5933    collectrad = imap(quring, zero_rad);
5934    lsau = simplify(imap(quring, hpl), 2);
5935    @h = imap(quring, @h);
[f0daaa2]5936
[70ab73]5937    kill quring;
[f0daaa2]5938
[70ab73]5939    // Here the intersection with the polynomialring
5940    // mentioned above is really computed
[f0daaa2]5941
[70ab73]5942    collectrad = sat2(collectrad, lsau)[1];
5943    if(deg(@h[1])>=0)
5944    {
5945      fac = ideal(0);
5946      for(lauf = 1; lauf <= ncols(@h); lauf++)
[f0daaa2]5947      {
[70ab73]5948        if(deg(@h[lauf]) > 0)
5949        {
5950          fac = fac + factorize(@h[lauf], 1);
5951        }
[f0daaa2]5952      }
[70ab73]5953      fac = simplify(fac, 6);
5954      @q = 1;
5955      for(lauf = 1; lauf <= size(fac); lauf++)
[f0daaa2]5956      {
[70ab73]5957        @q = @q * fac[lauf];
[f0daaa2]5958      }
[70ab73]5959      op = option(get);
5960      option(returnSB);
5961      option(redSB);
5962      I = quotient(I + ideal(@q), rad);
5963      attrib(I, "isSB", 1);
5964      option(set, op);
5965    }
5966    if((deg(rad[1]) > 0) && (deg(collectrad[1]) > 0))
5967    {
5968      rad = intersect(rad, collectrad);
5969      te = intersect(te, collectrad);
5970      te = simplify(reduce(te, I, 1), 2);
5971    }
5972    else
5973    {
5974      if(deg(collectrad[1]) > 0)
[f0daaa2]5975      {
[70ab73]5976        rad = collectrad;
5977        te = intersect(te, collectrad);
5978        te = simplify(reduce(te, I, 1), 2);
[f0daaa2]5979      }
[70ab73]5980    }
[f0daaa2]5981
[70ab73]5982    if((dim(I) < jdim)||(size(te) == 0))
5983    {
5984      break;
5985    }
5986    if(homo==1)
5987    {
5988      @hilb = hilb(I, 1, @w);
5989    }
5990  }
[f0daaa2]5991
[70ab73]5992  // SL 2006.04.11 1 Debug messages
5993  dbprint (printlevel-voice, "// Part of the Radical already computed:", rad);
5994  dbprint (printlevel-voice, "// Dimension:", dim(groebner(rad)));
5995  // SL 2006.04.11 2 Debug messages
[f0daaa2]5996
[6fd3a2]5997  // SL 2006.04.21 1    New variable "done".
5998  //                      It tells if the radical is already computed or
5999  //                      if it still has to be computed the radical of the new ideal I
[70ab73]6000  int done;
6001  if(((@wr == 1) && (dim(I)<jdim)) || (deg(I[1])==0) || (size(te) == 0))
6002  {
6003    done = 1;
6004  }
6005  else
6006  {
6007    done = 0;
6008  }
6009  // SL 2006.04.21 2
[f0daaa2]6010
[6fd3a2]6011  // SL 2006.04.21 1     See details of the output at the beginning of this proc.
[70ab73]6012  list result = rad, I, done;
6013  return(result);
6014  // SL 2006.04.21 2
6015}
[f0daaa2]6016
6017///////////////////////////////////////////////////////////////////////////////
6018// Given an ideal I and an ideal P (intersection of some minimal prime ideals
6019// associated to I), it calculates the intersection of new minimal prime ideals
6020// associated to I which where not used to calculate P.
6021// This version uses ZD Radical in the zerodimensional case.
[f995aa]6022static proc radicalSLIteration (ideal I, ideal P);
[f0daaa2]6023// Input: I, ideal. The ideal from which new prime components will be obtained.
6024//        P, ideal. Intersection of some prime ideals of I.
6025// Output: ideal. Intersection of some primes of I different from the ones in P.
6026{
[6fd3a2]6027  int k = 1;                     // Counter
6028  int good  = 0;                 // Checks if an element of P is in rad(I)
[70ab73]6029
6030  dbprint (printlevel-voice, "// We search for an element in P - sqrt(I).");
6031  while ((k <= size(P)) and (good == 0))
6032  {
6033    dbprint (printlevel-voice, "// We try with:", P[k]);
6034    good = 1 - rad_con(P[k], I);
6035    k++;
6036  }
6037  k--;
6038  if (good == 0)
6039  {
6040    dbprint (printlevel-voice, "// No element was found, P = sqrt(I).");
6041    list emptyList = list();
6042    return (emptyList);
6043  }
6044  dbprint(printlevel - voice, "// That one was good!");
6045  dbprint(printlevel - voice, "// We saturate I with respect to this element.");
6046  if (P[k] != 1)
6047  {
[6fd3a2]6048    intvec oo=option(get);
6049    option(redSB);
[70ab73]6050    ideal J = sat(I, P[k])[1];
[6fd3a2]6051    option(set,oo);
6052
[a36e78]6053  }
6054  else
6055  {
6056    dbprint(printlevel - voice, "// The polynomial is 1, the saturation in not actually computed.");
6057    ideal J = I;
6058  }
[7f7c25e]6059
[a36e78]6060  // We now call proc radicalNew;
6061  dbprint(printlevel - voice, "// We do the reduction to the zerodimensional case, via radical.");
6062  dbprint(printlevel - voice, "// The ideal is ", J);
6063  dbprint(printlevel - voice, "// The dimension is ", dim(groebner(J)));
[7f7c25e]6064
[6fd3a2]6065  int allMaximal = 0;   // Compute the zerodim reduction for only one indep set.
6066  ideal re = 1;         // No reduction is need,
6067                        //    there are not redundant components.
6068  list emptyList = list();   // Look for primes of any dimension,
6069                             //   not only of max dimension.
[a36e78]6070  list result = radicalReduction(J, re, allMaximal, emptyList);
[f0daaa2]6071
[a36e78]6072  return(result[1]);
[70ab73]6073}
[f0daaa2]6074
6075///////////////////////////////////////////////////////////////////////////////////
6076// Based on maxIndependSet
6077// Added list # as parameter
6078// If the first element of # is 0, the output is only 1 max indep set.
6079// If no list is specified or #[1] = 1, the output is all the max indep set of the
6080// leading terms ideal. This is the original output of maxIndependSet
6081
6082// The ordering given in the output has been changed to block dp instead of lp.
6083
[f995aa]6084proc newMaxIndependSetDp(ideal j, list #)
[7f7c25e]6085"USAGE:   newMaxIndependentSetDp(I); I ideal (returns all maximal independent sets of the corresponding leading terms ideal)
6086          newMaxIndependentSetDp(I, 0); I ideal (returns only one maximal independent set)
[f0daaa2]6087RETURN:  list = #1. new varstring with the maximal independent set at the end,
[f995aa]6088                #2. ordstring with the corresponding dp block ordering,
[f0daaa2]6089                #3. the number of independent variables
6090NOTE:
[f995aa]6091EXAMPLE: example newMaxIndependentSetDp; shows an example
[f0daaa2]6092"
6093{
[70ab73]6094  int n, k, di;
6095  list resu, hilf;
6096  string var1, var2;
6097  list v = indepSet(j, 0);
6098
6099  // SL 2006.04.21 1 Lines modified to use only one independent Set
6100  int allMaximal;
6101  if (size(#) > 0)
6102  {
6103    allMaximal = #[1];
[a36e78]6104  }
6105  else
6106  {
6107    allMaximal = 1;
6108  }
[f0daaa2]6109
[a36e78]6110  int nMax;
6111  if (allMaximal == 1)
6112  {
6113    nMax = size(v);
6114  }
6115  else
6116  {
6117    nMax = 1;
6118  }
[f0daaa2]6119
[a36e78]6120  for(n = 1; n <= nMax; n++)
6121  // SL 2006.04.21 2
6122  {
6123    di = 0;
6124    var1 = "";
6125    var2 = "";
6126    for(k = 1; k <= size(v[n]); k++)
6127    {
6128     if(v[n][k] != 0)
6129      {
6130        di++;
6131        var2 = var2 + "var(" + string(k) + "), ";
6132      }
6133      else
6134      {
6135        var1 = var1 + "var(" + string(k) + "), ";
6136      }
6137    }
6138    if(di > 0)
6139    {
6140      var1 = var1 + var2;
6141      var1 = var1[1..size(var1) - 2];                         // The "- 2" removes the trailer comma
6142      hilf[1] = var1;
6143      // SL 2006.21.04 1 The order is now block dp instead of lp
6144      hilf[2] = "dp(" + string(nvars(basering) - di) + "), dp(" + string(di) + ")";
6145      // SL 2006.21.04 2
6146      hilf[3] = di;
6147      resu[n] = hilf;
6148    }
6149    else
6150    {
6151      resu[n] = varstr(basering), ordstr(basering), 0;
6152    }
6153  }
6154  return(resu);
[f0daaa2]6155}
6156example
6157{ "EXAMPLE:"; echo = 2;
6158   ring s1 = (0, x, y), (a, b, c, d, e, f, g), lp;
6159   ideal i = ea - fbg, fa + be, ec - fdg, fc + de;
6160   i = std(i);
[f995aa]6161   list l = newMaxIndependSetDp(i);
[f0daaa2]6162   l;
6163   i = i, g;
[f995aa]6164   l = newMaxIndependSetDp(i);
[f0daaa2]6165   l;
6166
6167   ring s = 0, (x, y, z), lp;
6168   ideal i = z, yx;
[f995aa]6169   list l = newMaxIndependSetDp(i);
[f0daaa2]6170   l;
6171}
6172
6173
6174///////////////////////////////////////////////////////////////////////////////
6175// based on prepareQuotientring
6176// The order returned is now (C, dp) instead of (C, lp)
6177
[f995aa]6178static proc prepareQuotientRingDp (int nnp)
6179"USAGE:   prepareQuotientRingDp(nnp); nnp int
[f0daaa2]6180RETURN:  string = to define Kvar(nnp+1),...,var(nvars)[..rest ]
6181NOTE:
[f995aa]6182EXAMPLE: example prepareQuotientRingDp; shows an example
[f0daaa2]6183"
6184{
6185  ideal @ih,@jh;
6186  int npar=npars(basering);
6187  int @n;
6188
6189  string quotring= "ring quring = ("+charstr(basering);
6190  for(@n = nnp + 1; @n <= nvars(basering); @n++)
6191  {
[a36e78]6192     quotring = quotring + ", var(" + string(@n) + ")";
6193     @ih = @ih + var(@n);
[f0daaa2]6194  }
6195
6196  quotring = quotring+"),(var(1)";
6197  @jh = @jh + var(1);
6198  for(@n = 2; @n <= nnp; @n++)
6199  {
6200    quotring = quotring + ", var(" + string(@n) + ")";
6201    @jh = @jh + var(@n);
6202  }
6203  // SL 2006-04-21 1 The order returned is now (C, dp) instead of (C, lp)
6204  quotring = quotring + "), (C, dp);";
6205  // SL 2006-04-21 2
6206
6207  return(quotring);
6208}
6209example
6210{ "EXAMPLE:"; echo = 2;
6211   ring s1=(0,x),(a,b,c,d,e,f,g),lp;
6212   def @Q=basering;
[f995aa]6213   list l= prepareQuotientRingDp(3);
[f0daaa2]6214   l;
6215   execute(l[1]);
6216   execute(l[2]);
6217   basering;
6218   phi;
6219   setring @Q;
[a36e78]6220
[f0daaa2]6221}
6222
[ebecf83]6223///////////////////////////////////////////////////////////////////////////////
6224proc prepareAss(ideal i)
[7f7c25e]6225"USAGE:   prepareAss(I); I ideal
6226RETURN:  list, the radicals of the maximal dimensional components of I.
[7b3971]6227NOTE:    Uses algorithm of Eisenbud/Huneke/Vasconcelos.
[ebecf83]6228EXAMPLE: example prepareAss; shows an example
6229"
6230{
[d88470]6231  if(attrib(basering,"global")!=1)
[07c623]6232  {
[a36e78]6233      ERROR(
[07c623]6234      "// Not implemented for this ordering, please change to global ordering."
[a36e78]6235      );
[07c623]6236  }
[ebecf83]6237  ideal j=std(i);
[d950c5]6238  int cod=nvars(basering)-dim(j);
[ebecf83]6239  int e;
6240  list er;
6241  ideal ann;
6242  if(homog(i)==1)
6243  {
[a36e78]6244     list re=sres(j,0);                   //the resolution
6245     re=minres(re);                       //minimized resolution
[ebecf83]6246  }
6247  else
6248  {
[3939bc]6249    list re=mres(i,0);
6250  }
[ebecf83]6251  for(e=cod;e<=nvars(basering);e++)
6252  {
[a36e78]6253     ann=AnnExt_R(e,re);
[d950c5]6254
[a36e78]6255     if(nvars(basering)-dim(std(ann))==e)
6256     {
6257        er[size(er)+1]=equiRadical(ann);
6258     }
[ebecf83]6259  }
6260  return(er);
[3939bc]6261}
[ebecf83]6262example
6263{ "EXAMPLE:";  echo = 2;
[07c623]6264   ring  r = 0,(x,y,z),dp;
[ebecf83]6265   poly  p = z2+1;
[07c623]6266   poly  q = z3+2;
6267   ideal i = p*q^2,y-z2;
6268   list pr = prepareAss(i);
[ebecf83]6269   pr;
6270}
[03f29c]6271///////////////////////////////////////////////////////////////////////////////
6272proc equidimMaxEHV(ideal i)
[7f7c25e]6273"USAGE:  equidimMaxEHV(I); I ideal
6274RETURN:  ideal, the equidimensional component (of maximal dimension) of I.
[07c623]6275NOTE:    Uses algorithm of Eisenbud, Huneke and Vasconcelos.
[03f29c]6276EXAMPLE: example equidimMaxEHV; shows an example
6277"
6278{
[d88470]6279  if(attrib(basering,"global")!=1)
[07c623]6280  {
[a36e78]6281      ERROR(
[07c623]6282      "// Not implemented for this ordering, please change to global ordering."
[a36e78]6283      );
[07c623]6284  }
[0ad359]6285  ideal j=groebner(i);
[03f29c]6286  int cod=nvars(basering)-dim(j);
6287  int e;
6288  ideal ann;
6289  if(homog(i)==1)
6290  {
[a36e78]6291     list re=sres(j,0);                   //the resolution
6292     re=minres(re);                       //minimized resolution
[03f29c]6293  }
6294  else
6295  {
6296    list re=mres(i,0);
6297  }
6298  ann=AnnExt_R(cod,re);
6299  return(ann);
6300}
6301example
6302{ "EXAMPLE:";  echo = 2;
[07c623]6303   ring  r = 0,(x,y,z),dp;
[03f29c]6304   ideal i=intersect(ideal(z),ideal(x,y),ideal(x2,z2),ideal(x5,y5,z5));
6305   equidimMaxEHV(i);
6306}
[ebecf83]6307
[838d37]6308proc testPrimary(list pr, ideal k)
[7b3971]6309"USAGE:   testPrimary(pr,k); pr a list, k an ideal.
6310ASSUME:  pr is the result of primdecGTZ(k) or primdecSY(k).
6311RETURN:  int, 1 if the intersection of the ideals in pr is k, 0 if not
[091424]6312EXAMPLE: example testPrimary; shows an example
[ebecf83]6313"
6314{
[a36e78]6315   int i;
6316   pr=reconvList(pr);
6317   ideal j=pr[1];
6318   for (i=2;i<=size(pr)/2;i++)
6319   {
6320       j=intersect(j,pr[2*i-1]);
6321   }
6322   return(idealsEqual(j,k));
[ebecf83]6323}
6324example
6325{ "EXAMPLE:";  echo = 2;
6326   ring  r = 32003,(x,y,z),dp;
6327   poly  p = z2+1;
6328   poly  q = z4+2;
6329   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
[091424]6330   list pr = primdecGTZ(i);
[ebecf83]6331   testPrimary(pr,i);
6332}
6333
[55fcff]6334///////////////////////////////////////////////////////////////////////////////
[7f24dd7]6335proc zerodec(ideal I)
6336"USAGE:   zerodec(I); I ideal
[7b3971]6337ASSUME:  I is zero-dimensional, the characteristic of the ground field is 0
6338RETURN:  list of primary ideals, the zero-dimensional decomposition of I
6339NOTE:    The algorithm (of Monico), works well only for a small total number
[367e88]6340         of solutions (@code{vdim(std(I))} should be < 100) and without
6341         parameters. In practice, it works also in large characteristic p>0
[7b3971]6342         but may fail for small p.
6343@*       If printlevel > 0 (default = 0) additional information is displayed.
[55fcff]6344EXAMPLE: example zerodec; shows an example
[7f24dd7]6345"
6346{
[d88470]6347  if(attrib(basering,"global")!=1)
6348  {
6349    ERROR(
6350    "// Not implemented for this ordering, please change to global ordering."
6351    );
6352  }
6353  def R=basering;
6354  poly q;
6355  int j,time;
6356  matrix m;
6357  list re;
6358  poly va=var(1);
6359  ideal J=groebner(I);
6360  ideal ba=kbase(J);
6361  int d=vdim(J);
6362  dbprint(printlevel-voice+2,"// multiplicity of ideal : "+ string(d));
[55fcff]6363//------ compute matrix of multiplication on R/I with generic element p -----
[d88470]6364  int e=nvars(basering);
6365  poly p=randomLast(100)[e]+random(-50,50);     //the generic element
6366  matrix n[d][d];
6367  time = timer;
6368  for(j=2;j<=e;j++)
6369  {
6370    va=va*var(j);
6371  }
6372  for(j=1;j<=d;j++)
6373  {
6374    q=reduce(p*ba[j],J);
6375    m=coeffs(q,ba,va);
6376    n[j,1..d]=m[1..d,1];
6377  }
6378  dbprint(printlevel-voice+2,
6379    "// time for computing multiplication matrix (with generic element) : "+
6380    string(timer-time));
[55fcff]6381//---------------- compute characteristic polynomial of matrix --------------
[d88470]6382  execute("ring P1=("+charstr(R)+"),T,dp;");
6383  matrix n=imap(R,n);
6384  time = timer;
6385  poly charpol=det(n-T*freemodule(d));
6386  dbprint(printlevel-voice+2,"// time for computing char poly: "+
6387         string(timer-time));
[55fcff]6388//------------------- factorize characteristic polynomial -------------------
[b9b906]6389//check first if constant term of charpoly is != 0 (which is true for
[55fcff]6390//sufficiently generic element)
[d88470]6391  if(charpol[size(charpol)]!=0)
6392  {
6393    time = timer;
6394    list fac=factor(charpol);
6395    testFactor(fac,charpol);
6396    dbprint(printlevel-voice+2,"// time for factorizing char poly: "+
6397            string(timer-time));
6398    int f=size(fac[1]);
[55fcff]6399//--------------------------- the irreducible case --------------------------
[d88470]6400    if(f==1)
6401    {
6402      setring R;
6403      re=I;
6404      return(re);
6405    }
[55fcff]6406//---------------------------- the reducible case ---------------------------
[b9b906]6407//if f_i are the irreducible factors of charpoly, mult=ri, then <I,g_i^ri>
6408//are the primary components where g_i = f_i(p). However, substituting p in
6409//f_i may result in a huge object although the final result may be small.
6410//Hence it is better to simultaneously reduce with I. For this we need a new
[55fcff]6411//ring.
[d88470]6412    execute("ring P=("+charstr(R)+"),(T,"+varstr(R)+"),(dp(1),dp);");
6413    list rfac=imap(P1,fac);
6414    intvec ov=option(get);;
6415    option(redSB);
6416    list re1;
6417    ideal new = T-imap(R,p),imap(R,J);
6418    attrib(new, "isSB",1);    //we know that new is a standard basis
6419    for(j=1;j<=f;j++)
6420    {
6421      re1[j]=reduce(rfac[1][j]^rfac[2][j],new);
6422    }
6423    setring R;
6424    re = imap(P,re1);
6425    for(j=1;j<=f;j++)
6426    {
6427      J=I,re[j];
6428      re[j]=interred(J);
6429    }
6430    option(set,ov);
6431    return(re);
[7f24dd7]6432  }
6433  else
[55fcff]6434//------------------- choice of generic element failed -------------------
[7f24dd7]6435  {
[d88470]6436    dbprint(printlevel-voice+2,"// try new generic element!");
6437    setring R;
6438    return(zerodec(I));
[7f24dd7]6439  }
6440}
6441example
6442{ "EXAMPLE:";  echo = 2;
[07c623]6443   ring r  = 0,(x,y),dp;
6444   ideal i = x2-2,y2-2;
6445   list pr = zerodec(i);
[7f24dd7]6446   pr;
6447}
[808a9f3]6448///////////////////////////////////////////////////////////////////////////////
6449static proc newDecompStep(ideal i, list #)
6450"USAGE:  newDecompStep(i); i ideal  (for primary decomposition)
6451         newDecompStep(i,1);        (for the associated primes of dimension of i)
6452         newDecompStep(i,2);        (for the minimal associated primes)
[f995aa]6453         newDecompStep(i,3);        (for the absolute primary decomposition (not tested!))
[808a9f3]6454         "oneIndep";        (for using only one max indep set)
6455         "intersect";        (returns alse the intersection of the components founded)
6456
6457RETURN:  list = list of primary ideals and their associated primes
6458         (at even positions in the list)
6459         (resp. a list of the minimal associated primes)
6460NOTE:    Algorithm of Gianni/Trager/Zacharias
6461EXAMPLE: example newDecompStep; shows an example
6462"
6463{
6464  intvec op,@vv;
6465  def  @P = basering;
6466  list primary,indep,ltras;
6467  intvec @vh,isat,@w;
6468  int @wr,@k,@n,@m,@n1,@n2,@n3,homo,seri,keepdi,abspri,ab,nn;
6469  ideal peek=i;
6470  ideal ser,tras;
6471  list data;
6472  list result;
6473  intvec @hilb;
6474  int isS=(attrib(i,"isSB")==1);
6475
6476  // Debug
6477  dbprint(printlevel - voice, "newDecompStep, v2.0");
6478
6479  string indepOption = "allIndep";
6480  string intersectOption = "noIntersect";
6481
6482  if(size(#)>0)
6483  {
[70ab73]6484    int count = 1;
6485    if(typeof(#[count]) == "string")
6486    {
6487      if ((#[count] == "oneIndep") or (#[count] == "allIndep"))
6488      {
6489        indepOption = #[count];
6490        count++;
[7f7c25e]6491      }
[70ab73]6492    }
6493    if(typeof(#[count]) == "string")
6494    {
6495      if ((#[count] == "intersect") or (#[count] == "noIntersect"))
[7f7c25e]6496      {
[70ab73]6497        intersectOption = #[count];
6498        count++;
[7f7c25e]6499      }
[70ab73]6500    }
6501    if((typeof(#[count]) == "int") or (typeof(#[count]) == "number"))
6502    {
6503      if ((#[count]==1)||(#[count]==2)||(#[count]==3))
[7f7c25e]6504      {
[70ab73]6505        @wr=#[count];
6506        if(@wr==3){abspri = 1; @wr = 0;}
6507        count++;
[7f7c25e]6508      }
[70ab73]6509    }
6510    if(size(#)>count)
6511    {
6512      seri=1;
6513      peek=#[count + 1];
6514      ser=#[count + 2];
6515    }
6516  }
6517  if(abspri)
6518  {
6519    list absprimary,abskeep,absprimarytmp,abskeeptmp;
6520  }
6521  homo=homog(i);
6522  if(homo==1)
6523  {
6524    if(attrib(i,"isSB")!=1)
6525    {
6526      //ltras=mstd(i);
6527      tras=groebner(i);
6528      ltras=tras,tras;
6529      attrib(ltras[1],"isSB",1);
6530    }
6531    else
6532    {
6533      ltras=i,i;
6534      attrib(ltras[1],"isSB",1);
6535    }
6536    tras = ltras[1];
6537    attrib(tras,"isSB",1);
6538    if(dim(tras)==0)
6539    {
6540      primary[1]=ltras[2];
6541      primary[2]=maxideal(1);
6542      if(@wr>0)
6543      {
6544        list l;
6545        l[2]=maxideal(1);
6546        l[1]=maxideal(1);
6547        if (intersectOption == "intersect")
[808a9f3]6548        {
[70ab73]6549          return(list(l, maxideal(1)));
[808a9f3]6550        }
[70ab73]6551        else
6552        {
6553          return(l);
[7f7c25e]6554        }
[70ab73]6555      }
6556      if (intersectOption == "intersect")
6557      {
6558        return(list(primary, primary[1]));
6559      }
6560      else
6561      {
6562        return(primary);
6563      }
6564    }
6565    for(@n=1;@n<=nvars(basering);@n++)
6566    {
6567      @w[@n]=ord(var(@n));
6568    }
6569    @hilb=hilb(tras,1,@w);
6570    intvec keephilb=@hilb;
[808a9f3]6571  }
6572
6573  //----------------------------------------------------------------
6574  //i is the zero-ideal
6575  //----------------------------------------------------------------
6576
6577  if(size(i)==0)
6578  {
[7f7c25e]6579    primary=i,i;
[70ab73]6580    if (intersectOption == "intersect")
6581    {
6582      return(list(primary, i));
6583    }
6584    else
6585    {
6586      return(primary);
[7f7c25e]6587    }
[808a9f3]6588  }
6589
6590  //----------------------------------------------------------------
6591  //pass to the lexicographical ordering and compute a standardbasis
6592  //----------------------------------------------------------------
6593
6594  int lp=islp();
6595
6596  execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),(C,lp);");
6597  op=option(get);
6598  option(redSB);
6599
6600  ideal ser=fetch(@P,ser);
6601  if(homo==1)
6602  {
[70ab73]6603    if(!lp)
6604    {
6605      ideal @j=std(fetch(@P,i),@hilb,@w);
6606    }
6607    else
6608    {
6609      ideal @j=fetch(@P,tras);
6610      attrib(@j,"isSB",1);
6611    }
[808a9f3]6612  }
6613  else
6614  {
[70ab73]6615    if(lp&&isS)
6616    {
6617      ideal @j=fetch(@P,i);
6618      attrib(@j,"isSB",1);
6619    }
6620    else
6621    {
6622      ideal @j=groebner(fetch(@P,i));
6623    }
[808a9f3]6624  }
6625  option(set,op);
6626  if(seri==1)
6627  {
6628    ideal peek=fetch(@P,peek);
6629    attrib(peek,"isSB",1);
6630  }
6631  else
6632  {
6633    ideal peek=@j;
6634  }
6635  if((size(ser)==0)&&(!abspri))
6636  {
6637    ideal fried;
6638    @n=size(@j);
6639    for(@k=1;@k<=@n;@k++)
6640    {
6641      if(deg(lead(@j[@k]))==1)
6642      {
6643        fried[size(fried)+1]=@j[@k];
6644        @j[@k]=0;
6645      }
6646    }
6647    if(size(fried)==nvars(basering))
6648    {
[70ab73]6649      setring @P;
6650      primary[1]=i;
6651      primary[2]=i;
6652      if (intersectOption == "intersect")
6653      {
6654        return(list(primary, i));
6655      }
6656      else
6657      {
6658        return(primary);
6659      }
[808a9f3]6660    }
6661    if(size(fried)>0)
6662    {
[70ab73]6663      string newva;
6664      string newma;
6665      for(@k=1;@k<=nvars(basering);@k++)
6666      {
6667        @n1=0;
6668        for(@n=1;@n<=size(fried);@n++)
6669        {
6670          if(leadmonom(fried[@n])==var(@k))
[808a9f3]6671          {
[70ab73]6672            @n1=1;
6673            break;
[808a9f3]6674          }
[70ab73]6675        }
6676        if(@n1==0)
6677        {
6678          newva=newva+string(var(@k))+",";
6679          newma=newma+string(var(@k))+",";
6680        }
6681        else
6682        {
6683          newma=newma+string(0)+",";
6684        }
6685      }
6686      newva[size(newva)]=")";
6687      newma[size(newma)]=";";
6688      execute("ring @deirf=("+charstr(gnir)+"),("+newva+",lp;");
6689      execute("map @kappa=gnir,"+newma);
6690      ideal @j= @kappa(@j);
6691      @j=simplify(@j, 2);
6692      attrib(@j,"isSB",1);
6693      result = newDecompStep(@j, indepOption, intersectOption, @wr);
6694      if (intersectOption == "intersect")
6695      {
[a36e78]6696       list pr = result[1];
6697       ideal intersection = result[2];
[70ab73]6698      }
6699      else
6700      {
6701        list pr = result;
6702      }
[808a9f3]6703
[70ab73]6704      setring gnir;
6705      list pr=imap(@deirf,pr);
6706      for(@k=1;@k<=size(pr);@k++)
6707      {
6708        @j=pr[@k]+fried;
6709        pr[@k]=@j;
6710      }
6711      if (intersectOption == "intersect")
6712      {
6713        ideal intersection = imap(@deirf, intersection);
6714        @j = intersection + fried;
6715        intersection = @j;
6716      }
6717      setring @P;
6718      if (intersectOption == "intersect")
6719      {
6720        return(list(imap(gnir,pr), imap(gnir,intersection)));
6721      }
6722      else
6723      {
6724        return(imap(gnir,pr));
6725      }
[808a9f3]6726    }
6727  }
6728  //----------------------------------------------------------------
6729  //j is the ring
6730  //----------------------------------------------------------------
6731
6732  if (dim(@j)==-1)
6733  {
6734    setring @P;
6735    primary=ideal(1),ideal(1);
[70ab73]6736    if (intersectOption == "intersect")
6737    {
[7f7c25e]6738      return(list(primary, ideal(1)));
[70ab73]6739    }
6740    else
6741    {
[7f7c25e]6742      return(primary);
6743    }
[808a9f3]6744  }
6745
6746  //----------------------------------------------------------------
6747  //  the case of one variable
6748  //----------------------------------------------------------------
6749
6750  if(nvars(basering)==1)
6751  {
[70ab73]6752    list fac=factor(@j[1]);
6753    list gprimary;
6754    poly generator;
6755    ideal gIntersection;
6756    for(@k=1;@k<=size(fac[1]);@k++)
6757    {
6758      if(@wr==0)
6759      {
6760        gprimary[2*@k-1]=ideal(fac[1][@k]^fac[2][@k]);
6761        gprimary[2*@k]=ideal(fac[1][@k]);
6762      }
6763      else
6764      {
6765        gprimary[2*@k-1]=ideal(fac[1][@k]);
6766        gprimary[2*@k]=ideal(fac[1][@k]);
6767      }
6768      if (intersectOption == "intersect")
6769      {
6770        generator = generator * fac[1][@k];
6771      }
6772    }
6773    if (intersectOption == "intersect")
6774    {
6775      gIntersection = generator;
6776    }
6777    setring @P;
6778    primary=fetch(gnir,gprimary);
6779    if (intersectOption == "intersect")
6780    {
6781      ideal intersection = fetch(gnir,gIntersection);
6782    }
[808a9f3]6783
6784//HIER
6785    if(abspri)
6786    {
[70ab73]6787      list resu,tempo;
6788      string absotto;
6789      for(ab=1;ab<=size(primary)/2;ab++)
6790      {
6791        absotto= absFactorize(primary[2*ab][1],77);
6792        tempo=primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
6793        resu[ab]=tempo;
6794      }
6795      primary=resu;
6796      intersection = 1;
6797      for(ab=1;ab<=size(primary);ab++)
6798      {
6799        intersection = intersect(intersection, primary[ab][2]);
6800      }
6801    }
6802    if (intersectOption == "intersect")
6803    {
6804      return(list(primary, intersection));
6805    }
6806    else
6807    {
6808      return(primary);
6809    }
[808a9f3]6810  }
6811
6812 //------------------------------------------------------------------
6813 //the zero-dimensional case
6814 //------------------------------------------------------------------
6815  if (dim(@j)==0)
6816  {
6817    op=option(get);
6818    option(redSB);
6819    list gprimary= newZero_decomp(@j,ser,@wr);
6820
6821    setring @P;
6822    primary=fetch(gnir,gprimary);
6823
6824    if(size(ser)>0)
6825    {
6826      primary=cleanPrimary(primary);
6827    }
6828//HIER
6829    if(abspri)
6830    {
[70ab73]6831      list resu,tempo;
6832      string absotto;
6833      for(ab=1;ab<=size(primary)/2;ab++)
6834      {
6835        absotto= absFactorize(primary[2*ab][1],77);
6836        tempo=primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
6837        resu[ab]=tempo;
6838      }
6839      primary=resu;
[808a9f3]6840    }
[70ab73]6841    if (intersectOption == "intersect")
6842    {
[7f7c25e]6843      return(list(primary, fetch(gnir,@j)));
[70ab73]6844    }
6845    else
6846    {
[7f7c25e]6847      return(primary);
6848    }
[808a9f3]6849  }
6850
6851  poly @gs,@gh,@p;
6852  string @va,quotring;
6853  list quprimary,htprimary,collectprimary,lsau,lnew,allindep,restindep;
6854  ideal @h;
6855  int jdim=dim(@j);
6856  list fett;
6857  int lauf,di,newtest;
6858  //------------------------------------------------------------------
6859  //search for a maximal independent set indep,i.e.
6860  //look for subring such that the intersection with the ideal is zero
6861  //j intersected with K[var(indep[3]+1),...,var(nvar] is zero,
6862  //indep[1] is the new varstring and indep[2] the string for block-ordering
6863  //------------------------------------------------------------------
6864  if(@wr!=1)
6865  {
[70ab73]6866    allindep = newMaxIndependSetLp(@j, indepOption);
6867    for(@m=1;@m<=size(allindep);@m++)
6868    {
6869      if(allindep[@m][3]==jdim)
6870      {
6871        di++;
6872        indep[di]=allindep[@m];
6873      }
6874      else
6875      {
6876        lauf++;
6877        restindep[lauf]=allindep[@m];
6878      }
6879    }
6880  }
6881  else
6882  {
6883    indep = newMaxIndependSetLp(@j, indepOption);
6884  }
[808a9f3]6885
6886  ideal jkeep=@j;
6887  if(ordstr(@P)[1]=="w")
6888  {
[70ab73]6889    execute("ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),("+ordstr(@P)+");");
[808a9f3]6890  }
6891  else
6892  {
[70ab73]6893    execute( "ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),(C,dp);");
[808a9f3]6894  }
6895
6896  if(homo==1)
6897  {
6898    if((ordstr(@P)[3]=="d")||(ordstr(@P)[1]=="d")||(ordstr(@P)[1]=="w")
6899       ||(ordstr(@P)[3]=="w"))
6900    {
6901      ideal jwork=imap(@P,tras);
6902      attrib(jwork,"isSB",1);
6903    }
6904    else
6905    {
6906      ideal jwork=std(imap(gnir,@j),@hilb,@w);
6907    }
6908  }
6909  else
6910  {
6911    ideal jwork=groebner(imap(gnir,@j));
6912  }
6913  list hquprimary;
6914  poly @p,@q;
6915  ideal @h,fac,ser;
6916//Aenderung================
6917  ideal @Ptest=1;
6918//=========================
6919  di=dim(jwork);
6920  keepdi=di;
6921
6922  ser = 1;
6923
6924  setring gnir;
6925  for(@m=1; @m<=size(indep); @m++)
6926  {
6927    data[1] = indep[@m];
6928    result = newReduction(@j, ser, @hilb, @w, jdim, abspri, @wr, data);
6929    quprimary = quprimary + result[1];
[70ab73]6930    if(abspri)
6931    {
[808a9f3]6932      absprimary = absprimary + result[2];
6933      abskeep = abskeep + result[3];
[7f7c25e]6934    }
[808a9f3]6935    @h = result[5];
6936    ser = result[4];
[7f7c25e]6937    if(size(@h)>0)
6938    {
[70ab73]6939      //---------------------------------------------------------------
6940      //we change to @Phelp to have the ordering dp for saturation
6941      //---------------------------------------------------------------
[808a9f3]6942
[70ab73]6943      setring @Phelp;
6944      @h=imap(gnir,@h);
[808a9f3]6945//Aenderung==================================
[70ab73]6946      if(defined(@LL)){kill @LL;}
6947      list @LL=minSat(jwork,@h);
6948      @Ptest=intersect(@Ptest,@LL[1]);
6949      ser = intersect(ser, @LL[1]);
[808a9f3]6950//===========================================
6951
[70ab73]6952      if(@wr!=1)
6953      {
[808a9f3]6954//Aenderung==================================
[70ab73]6955        @q=@LL[2];
[808a9f3]6956//===========================================
[70ab73]6957        //@q=minSat(jwork,@h)[2];
6958      }
6959      else
6960      {
6961        fac=ideal(0);
6962        for(lauf=1;lauf<=ncols(@h);lauf++)
[808a9f3]6963        {
[70ab73]6964          if(deg(@h[lauf])>0)
6965          {
6966            fac=fac+factorize(@h[lauf],1);
6967          }
[808a9f3]6968        }
[70ab73]6969        fac=simplify(fac,6);
6970        @q=1;
6971        for(lauf=1;lauf<=size(fac);lauf++)
[808a9f3]6972        {
[70ab73]6973          @q=@q*fac[lauf];
[808a9f3]6974        }
[70ab73]6975      }
6976      jwork = std(jwork,@q);
6977      keepdi = dim(jwork);
6978      if(keepdi < di)
6979      {
[808a9f3]6980        setring gnir;
6981        @j = imap(@Phelp, jwork);
[70ab73]6982        ser = imap(@Phelp, ser);
6983        break;
6984      }
6985      if(homo == 1)
6986      {
6987        @hilb = hilb(jwork, 1, @w);
6988      }
6989
6990      setring gnir;
6991      ser = imap(@Phelp, ser);
6992      @j = imap(@Phelp, jwork);
6993    }
[808a9f3]6994  }
6995
6996  if((size(quprimary)==0)&&(@wr==1))
6997  {
[a36e78]6998     @j=ideal(1);
6999     quprimary[1]=ideal(1);
7000     quprimary[2]=ideal(1);
[808a9f3]7001  }
7002  if((size(quprimary)==0))
7003  {
7004    keepdi = di - 1;
7005    quprimary[1]=ideal(1);
7006    quprimary[2]=ideal(1);
7007  }
7008  //---------------------------------------------------------------
7009  //notice that j=sat(j,gh) intersected with (j,gh^n)
7010  //we finished with sat(j,gh) and have to start with (j,gh^n)
7011  //---------------------------------------------------------------
7012  if((deg(@j[1])!=0)&&(@wr!=1))
7013  {
[a36e78]7014     if(size(quprimary)>0)
7015     {
7016        setring @Phelp;
7017        ser=imap(gnir,ser);
[808a9f3]7018
[a36e78]7019        hquprimary=imap(gnir,quprimary);
7020        if(@wr==0)
7021        {
[808a9f3]7022//Aenderung====================================================
7023//HIER STATT DURCHSCHNITT SATURIEREN!
[a36e78]7024           ideal htest=@Ptest;
[808a9f3]7025/*
[a36e78]7026           ideal htest=hquprimary[1];
7027           for (@n1=2;@n1<=size(hquprimary)/2;@n1++)
7028           {
7029              htest=intersect(htest,hquprimary[2*@n1-1]);
7030           }
[808a9f3]7031*/
7032//=============================================================
7033        }
7034        else
7035        {
[a36e78]7036           ideal htest=hquprimary[2];
[808a9f3]7037
[a36e78]7038           for (@n1=2;@n1<=size(hquprimary)/2;@n1++)
7039           {
7040              htest=intersect(htest,hquprimary[2*@n1]);
7041           }
[808a9f3]7042        }
[70ab73]7043
[a36e78]7044        if(size(ser)>0)
[808a9f3]7045        {
[a36e78]7046           ser=intersect(htest,ser);
[808a9f3]7047        }
[a36e78]7048        else
[808a9f3]7049        {
[a36e78]7050          ser=htest;
[70ab73]7051        }
7052        setring gnir;
[a36e78]7053        ser=imap(@Phelp,ser);
7054     }
7055     if(size(reduce(ser,peek,1))!=0)
7056     {
7057        for(@m=1;@m<=size(restindep);@m++)
7058        {
7059         // if(restindep[@m][3]>=keepdi)
7060         // {
7061           isat=0;
7062           @n2=0;
7063
7064           if(restindep[@m][1]==varstr(basering))
7065           //the good case, nothing to do, just to have the same notations
7066           //change the ring
7067           {
7068              execute("ring gnir1 = ("+charstr(basering)+"),("+
7069                varstr(basering)+"),("+ordstr(basering)+");");
7070              ideal @j=fetch(gnir,jkeep);
7071              attrib(@j,"isSB",1);
7072           }
7073           else
7074           {
7075              @va=string(maxideal(1));
7076              execute("ring gnir1 = ("+charstr(basering)+"),("+
7077                      restindep[@m][1]+"),(" +restindep[@m][2]+");");
7078              execute("map phi=gnir,"+@va+";");
7079              op=option(get);
7080              option(redSB);
7081              if(homo==1)
7082              {
7083                 ideal @j=std(phi(jkeep),keephilb,@w);
7084              }
7085              else
7086              {
7087                ideal @j=groebner(phi(jkeep));
7088              }
7089              ideal ser=phi(ser);
7090              option(set,op);
7091           }
7092
7093           for (lauf=1;lauf<=size(@j);lauf++)
7094           {
7095              fett[lauf]=size(@j[lauf]);
7096           }
7097           //------------------------------------------------------------------
7098           //we have now the following situation:
7099           //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may
7100           //pass to this quotientring, j is their still a standardbasis, the
7101           //leading coefficients of the polynomials  there (polynomials in
7102           //K[var(nnp+1),..,var(nva)]) are collected in the list h,
7103           //we need their ggt, gh, because of the following:
7104           //let (j:gh^n)=(j:gh^infinity) then
7105           //j*K(var(nnp+1),..,var(nva))[..the rest..]
7106           //intersected with K[var(1),...,var(nva)] is (j:gh^n)
7107           //on the other hand j=(j,gh^n) intersected with (j:gh^n)
7108
7109           //------------------------------------------------------------------
7110
7111           //the arrangement for the quotientring
7112           // K(var(nnp+1),..,var(nva))[..the rest..]
7113           //and the map phi:K[var(1),...,var(nva)] ---->
7114           //--->K(var(nnpr+1),..,var(nva))[..the rest..]
7115           //------------------------------------------------------------------
7116
7117           quotring=prepareQuotientring(nvars(basering)-restindep[@m][3]);
7118
7119           //------------------------------------------------------------------
7120           //we pass to the quotientring  K(var(nnp+1),..,var(nva))[..rest..]
7121           //------------------------------------------------------------------
7122
7123           execute(quotring);
7124
7125           // @j considered in the quotientring
7126           ideal @j=imap(gnir1,@j);
7127           ideal ser=imap(gnir1,ser);
7128
7129           kill gnir1;
7130
7131           //j is a standardbasis in the quotientring but usually not minimal
7132           //here it becomes minimal
7133           @j=clearSB(@j,fett);
7134           attrib(@j,"isSB",1);
7135
7136           //we need later ggt(h[1],...)=gh for saturation
7137           ideal @h;
7138
7139           for(@n=1;@n<=size(@j);@n++)
7140           {
7141              @h[@n]=leadcoef(@j[@n]);
7142           }
7143           //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..rest..]
7144
7145           op=option(get);
7146           option(redSB);
7147           list uprimary= newZero_decomp(@j,ser,@wr);
7148//HIER
7149           if(abspri)
7150           {
7151              ideal II;
7152              ideal jmap;
7153              map sigma;
7154              nn=nvars(basering);
7155              map invsigma=basering,maxideal(1);
7156              for(ab=1;ab<=size(uprimary)/2;ab++)
7157              {
7158                 II=uprimary[2*ab];
7159                 attrib(II,"isSB",1);
7160                 if(deg(II[1])!=vdim(II))
7161                 {
7162                    jmap=randomLast(50);
7163                    sigma=basering,jmap;
7164                    jmap[nn]=2*var(nn)-jmap[nn];
7165                    invsigma=basering,jmap;
7166                    II=groebner(sigma(II));
7167                  }
7168                  absprimarytmp[ab]= absFactorize(II[1],77);
7169                  II=var(nn);
7170                  abskeeptmp[ab]=string(invsigma(II));
7171                  invsigma=basering,maxideal(1);
7172              }
7173           }
7174           option(set,op);
7175
7176           //we need the intersection of the ideals in the list quprimary with
7177           //the polynomialring, i.e. let q=(f1,...,fr) in the quotientring
7178           //such an ideal but fi polynomials, then the intersection of q with
7179           //the polynomialring is the saturation of the ideal generated by
7180           //f1,...,fr with respect toh which is the lcm of the leading
7181           //coefficients of the fi considered in the quotientring:
7182           //this is coded in saturn
7183
7184           list saturn;
7185           ideal hpl;
7186
7187           for(@n=1;@n<=size(uprimary);@n++)
7188           {
7189              hpl=0;
7190              for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
7191              {
7192                 hpl=hpl,leadcoef(uprimary[@n][@n1]);
7193              }
7194              saturn[@n]=hpl;
7195           }
7196           //------------------------------------------------------------------
7197           //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..rest..]
7198           //back to the polynomialring
7199           //------------------------------------------------------------------
7200           setring gnir;
7201           collectprimary=imap(quring,uprimary);
7202           lsau=imap(quring,saturn);
7203           @h=imap(quring,@h);
7204
7205           kill quring;
7206
7207
7208           @n2=size(quprimary);
[808a9f3]7209//================NEU=========================================
[a36e78]7210           if(deg(quprimary[1][1])<=0){ @n2=0; }
[808a9f3]7211//============================================================
7212
[a36e78]7213           @n3=@n2;
7214
7215           for(@n1=1;@n1<=size(collectprimary)/2;@n1++)
7216           {
7217              if(deg(collectprimary[2*@n1][1])>0)
7218              {
7219                 @n2++;
7220                 quprimary[@n2]=collectprimary[2*@n1-1];
7221                 lnew[@n2]=lsau[2*@n1-1];
7222                 @n2++;
7223                 lnew[@n2]=lsau[2*@n1];
7224                 quprimary[@n2]=collectprimary[2*@n1];
7225                 if(abspri)
7226                 {
7227                   absprimary[@n2/2]=absprimarytmp[@n1];
7228                   abskeep[@n2/2]=abskeeptmp[@n1];
7229                 }
7230              }
7231           }
7232
7233
7234           //here the intersection with the polynomialring
7235           //mentioned above is really computed
7236
7237           for(@n=@n3/2+1;@n<=@n2/2;@n++)
7238           {
7239              if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
7240              {
7241                 quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7242                 quprimary[2*@n]=quprimary[2*@n-1];
7243              }
7244              else
7245              {
7246                 if(@wr==0)
7247                 {
7248                    quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7249                 }
7250                 quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
7251              }
7252           }
7253           if(@n2>=@n3+2)
7254           {
7255              setring @Phelp;
7256              ser=imap(gnir,ser);
7257              hquprimary=imap(gnir,quprimary);
7258              for(@n=@n3/2+1;@n<=@n2/2;@n++)
7259              {
7260                if(@wr==0)
7261                {
7262                   ser=intersect(ser,hquprimary[2*@n-1]);
7263                }
7264                else
7265                {
7266                   ser=intersect(ser,hquprimary[2*@n]);
7267                }
7268              }
7269              setring gnir;
7270              ser=imap(@Phelp,ser);
7271           }
[808a9f3]7272
[a36e78]7273         // }
[808a9f3]7274        }
[a36e78]7275//HIER
7276        if(abspri)
[808a9f3]7277        {
[a36e78]7278          list resu,tempo;
7279          for(ab=1;ab<=size(quprimary)/2;ab++)
[70ab73]7280          {
[a36e78]7281             if (deg(quprimary[2*ab][1])!=0)
7282             {
7283               tempo=quprimary[2*ab-1],quprimary[2*ab],
7284                         absprimary[ab],abskeep[ab];
7285               resu[ab]=tempo;
7286             }
[808a9f3]7287          }
[a36e78]7288          quprimary=resu;
7289          @wr=3;
[808a9f3]7290        }
[a36e78]7291        if(size(reduce(ser,peek,1))!=0)
[808a9f3]7292        {
[a36e78]7293           if(@wr>0)
7294           {
7295              // The following line was dropped to avoid the recursion step:
7296              //htprimary=newDecompStep(@j,@wr,peek,ser);
7297              htprimary = list();
7298           }
7299           else
7300           {
7301              // The following line was dropped to avoid the recursion step:
7302              //htprimary=newDecompStep(@j,peek,ser);
7303              htprimary = list();
7304           }
7305           // here we collect now both results primary(sat(j,gh))
7306           // and primary(j,gh^n)
7307           @n=size(quprimary);
7308           if (deg(quprimary[1][1])<=0) { @n=0; }
7309           for (@k=1;@k<=size(htprimary);@k++)
7310           {
7311              quprimary[@n+@k]=htprimary[@k];
7312           }
[808a9f3]7313        }
[a36e78]7314     }
7315   }
7316   else
7317   {
[808a9f3]7318      if(abspri)
7319      {
7320        list resu,tempo;
7321        for(ab=1;ab<=size(quprimary)/2;ab++)
7322        {
[a36e78]7323           tempo=quprimary[2*ab-1],quprimary[2*ab],
7324                   absprimary[ab],abskeep[ab];
7325           resu[ab]=tempo;
[808a9f3]7326        }
7327        quprimary=resu;
[70ab73]7328      }
[a36e78]7329   }
[808a9f3]7330  //---------------------------------------------------------------------------
7331  //back to the ring we started with
7332  //the final result: primary
7333  //---------------------------------------------------------------------------
7334
7335  setring @P;
7336  primary=imap(gnir,quprimary);
7337
[70ab73]7338  if (intersectOption == "intersect")
7339  {
[a36e78]7340     return(list(primary, imap(gnir, ser)));
[70ab73]7341  }
7342  else
7343  {
7344    return(primary);
7345  }
[808a9f3]7346}
7347example
7348{ "EXAMPLE:"; echo = 2;
7349   ring  r = 32003,(x,y,z),lp;
7350   poly  p = z2+1;
7351   poly  q = z4+2;
7352   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
7353   list pr= newDecompStep(i);
7354   pr;
7355   testPrimary( pr, i);
7356}
7357
[7f7c25e]7358// This was part of proc decomp.
7359// In proc newDecompStep, used for the computation of the minimal associated primes,
7360// this part was separated as a soubrutine to make the code more clear.
7361// Also, since the reduction is performed twice in proc newDecompStep, it should use both times this routine.
7362// This is not yet implemented, since the reduction is not exactly the same and some changes should be made.
7363static proc newReduction(ideal @j, ideal ser, intvec @hilb, intvec @w, int jdim, int abspri, int @wr, list data)
[808a9f3]7364{
[a36e78]7365   string @va;
7366   string quotring;
7367   intvec op;
7368   intvec @vv;
7369   def gnir = basering;
7370   ideal isat=0;
7371   int @n;
7372   int @n1 = 0;
7373   int @n2 = 0;
7374   int @n3 = 0;
7375   int homo = homog(@j);
7376   int lauf;
7377   int @k;
7378   list fett;
7379   int keepdi;
7380   list collectprimary;
7381   list lsau;
7382   list lnew;
7383   ideal @h;
7384
7385   list indepInfo = data[1];
7386   list quprimary = list();
7387
7388   //if(abspri)
7389   //{
[808a9f3]7390     int ab;
7391     list absprimarytmp,abskeeptmp;
7392     list absprimary, abskeep;
[a36e78]7393   //}
7394   // Debug
7395   dbprint(printlevel - voice, "newReduction, v2.0");
[808a9f3]7396
[a36e78]7397   if((indepInfo[1]==varstr(basering)))  // &&(@m==1)
7398   //this is the good case, nothing to do, just to have the same notations
7399   //change the ring
7400   {
7401     execute("ring gnir1 = ("+charstr(basering)+"),("+varstr(basering)+"),("
[808a9f3]7402                              +ordstr(basering)+");");
[a36e78]7403     ideal @j = fetch(gnir, @j);
7404     attrib(@j,"isSB",1);
7405     ideal ser = fetch(gnir, ser);
7406   }
7407   else
7408   {
7409     @va=string(maxideal(1));
[808a9f3]7410//Aenderung==============
[a36e78]7411     //if(@m==1)
7412     //{
7413     //  @j=fetch(@P,i);
7414     //}
[808a9f3]7415//=======================
[a36e78]7416     execute("ring gnir1 = ("+charstr(basering)+"),("+indepInfo[1]+"),("
[808a9f3]7417                              +indepInfo[2]+");");
[a36e78]7418     execute("map phi=gnir,"+@va+";");
7419     op=option(get);
7420     option(redSB);
7421     if(homo==1)
7422     {
7423       ideal @j=std(phi(@j),@hilb,@w);
7424     }
7425     else
7426     {
7427       ideal @j=groebner(phi(@j));
7428     }
7429     ideal ser=phi(ser);
[808a9f3]7430
[a36e78]7431     option(set,op);
7432   }
7433   if((deg(@j[1])==0)||(dim(@j)<jdim))
7434   {
7435     setring gnir;
7436     break;
7437   }
7438   for (lauf=1;lauf<=size(@j);lauf++)
7439   {
7440     fett[lauf]=size(@j[lauf]);
7441   }
7442   //------------------------------------------------------------------------
7443   //we have now the following situation:
7444   //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may pass
7445   //to this quotientring, j is their still a standardbasis, the
7446   //leading coefficients of the polynomials  there (polynomials in
7447   //K[var(nnp+1),..,var(nva)]) are collected in the list h,
7448   //we need their ggt, gh, because of the following: let
7449   //(j:gh^n)=(j:gh^infinity) then j*K(var(nnp+1),..,var(nva))[..the rest..]
7450   //intersected with K[var(1),...,var(nva)] is (j:gh^n)
7451   //on the other hand j=(j,gh^n) intersected with (j:gh^n)
7452
7453   //------------------------------------------------------------------------
7454
7455   //arrangement for quotientring K(var(nnp+1),..,var(nva))[..the rest..] and
7456   //map phi:K[var(1),...,var(nva)] --->K(var(nnpr+1),..,var(nva))[..rest..]
7457   //------------------------------------------------------------------------
7458
7459   quotring=prepareQuotientring(nvars(basering)-indepInfo[3]);
7460
7461   //---------------------------------------------------------------------
7462   //we pass to the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
7463   //---------------------------------------------------------------------
7464
7465   ideal @jj=lead(@j);               //!! vorn vereinbaren
7466   execute(quotring);
7467
7468   ideal @jj=imap(gnir1,@jj);
7469   @vv=clearSBNeu(@jj,fett);  //!! vorn vereinbaren
7470   setring gnir1;
7471   @k=size(@j);
7472   for (lauf=1;lauf<=@k;lauf++)
7473   {
7474     if(@vv[lauf]==1)
7475     {
7476       @j[lauf]=0;
7477     }
7478   }
7479   @j=simplify(@j,2);
7480   setring quring;
7481   // @j considered in the quotientring
7482   ideal @j=imap(gnir1,@j);
[808a9f3]7483
[a36e78]7484   ideal ser=imap(gnir1,ser);
[808a9f3]7485
[a36e78]7486   kill gnir1;
[808a9f3]7487
[a36e78]7488   //j is a standardbasis in the quotientring but usually not minimal
7489   //here it becomes minimal
[808a9f3]7490
[a36e78]7491   attrib(@j,"isSB",1);
[808a9f3]7492
[a36e78]7493   //we need later ggt(h[1],...)=gh for saturation
7494   ideal @h;
7495   if(deg(@j[1])>0)
7496   {
7497     for(@n=1;@n<=size(@j);@n++)
7498     {
7499       @h[@n]=leadcoef(@j[@n]);
7500     }
7501     //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..the rest..]
7502     op=option(get);
7503     option(redSB);
[808a9f3]7504
[a36e78]7505     int zeroMinAss = @wr;
7506     if (@wr == 2) {zeroMinAss = 1;}
7507     list uprimary= newZero_decomp(@j, ser, zeroMinAss);
[808a9f3]7508
[a36e78]7509//HIER
7510     if(abspri)
7511     {
7512       ideal II;
7513       ideal jmap;
7514       map sigma;
7515       nn=nvars(basering);
7516       map invsigma=basering,maxideal(1);
7517       for(ab=1;ab<=size(uprimary)/2;ab++)
7518       {
7519         II=uprimary[2*ab];
7520         attrib(II,"isSB",1);
7521         if(deg(II[1])!=vdim(II))
7522         {
7523           jmap=randomLast(50);
7524           sigma=basering,jmap;
7525           jmap[nn]=2*var(nn)-jmap[nn];
7526           invsigma=basering,jmap;
7527           II=groebner(sigma(II));
7528         }
7529         absprimarytmp[ab]= absFactorize(II[1],77);
7530         II=var(nn);
7531         abskeeptmp[ab]=string(invsigma(II));
7532         invsigma=basering,maxideal(1);
7533       }
7534     }
7535     option(set,op);
7536   }
7537   else
7538   {
7539     list uprimary;
7540     uprimary[1]=ideal(1);
7541     uprimary[2]=ideal(1);
7542   }
7543   //we need the intersection of the ideals in the list quprimary with the
7544   //polynomialring, i.e. let q=(f1,...,fr) in the quotientring such an ideal
7545   //but fi polynomials, then the intersection of q with the polynomialring
7546   //is the saturation of the ideal generated by f1,...,fr with respect to
7547   //h which is the lcm of the leading coefficients of the fi considered in
7548   //in the quotientring: this is coded in saturn
[70ab73]7549
[a36e78]7550   list saturn;
7551   ideal hpl;
[70ab73]7552
[a36e78]7553   for(@n=1;@n<=size(uprimary);@n++)
7554   {
7555     uprimary[@n]=interred(uprimary[@n]); // temporary fix
7556     hpl=0;
7557     for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
7558     {
7559       hpl=hpl,leadcoef(uprimary[@n][@n1]);
7560     }
7561     saturn[@n]=hpl;
7562   }
[808a9f3]7563
[a36e78]7564   //--------------------------------------------------------------------
7565   //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
7566   //back to the polynomialring
7567   //---------------------------------------------------------------------
7568   setring gnir;
[808a9f3]7569
[a36e78]7570   collectprimary=imap(quring,uprimary);
7571   lsau=imap(quring,saturn);
7572   @h=imap(quring,@h);
[808a9f3]7573
[a36e78]7574   kill quring;
[808a9f3]7575
[a36e78]7576   @n2=size(quprimary);
7577   @n3=@n2;
[808a9f3]7578
[a36e78]7579   for(@n1=1;@n1<=size(collectprimary)/2;@n1++)
7580   {
7581     if(deg(collectprimary[2*@n1][1])>0)
7582     {
7583       @n2++;
7584       quprimary[@n2]=collectprimary[2*@n1-1];
7585       lnew[@n2]=lsau[2*@n1-1];
7586       @n2++;
7587       lnew[@n2]=lsau[2*@n1];
7588       quprimary[@n2]=collectprimary[2*@n1];
7589       if(abspri)
7590       {
7591         absprimary[@n2/2]=absprimarytmp[@n1];
7592         abskeep[@n2/2]=abskeeptmp[@n1];
7593       }
7594     }
7595   }
[808a9f3]7596
[a36e78]7597   //here the intersection with the polynomialring
7598   //mentioned above is really computed
7599   for(@n=@n3/2+1;@n<=@n2/2;@n++)
7600   {
7601     if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
7602     {
7603       quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7604       quprimary[2*@n]=quprimary[2*@n-1];
7605     }
7606     else
7607     {
7608       if(@wr==0)
7609       {
7610         quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7611       }
7612       quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
7613     }
7614   }
[808a9f3]7615
[a36e78]7616   return(quprimary, absprimary, abskeep, ser, @h);
7617}
[808a9f3]7618
7619
[a36e78]7620////////////////////////////////////////////////////////////////////////////
[808a9f3]7621
7622
7623
7624
7625///////////////////////////////////////////////////////////////////////////////
7626// Based on minAssGTZ
7627
[f995aa]7628proc minAss(ideal i,list #)
[7f7c25e]7629"USAGE:   minAss(I[, l]); i ideal, l list (optional) of parameters, same as minAssGTZ
7630RETURN:  a list, the minimal associated prime ideals of I.
[808a9f3]7631NOTE:    Designed for characteristic 0, works also in char k > 0 based
7632         on an algorithm of Yokoyama
[f995aa]7633EXAMPLE: example minAss; shows an example
[808a9f3]7634"
7635{
[70ab73]7636  return(minAssGTZ(i,#));
[808a9f3]7637}
7638example
7639{ "EXAMPLE:";  echo = 2;
7640   ring  r = 0, (x, y, z), dp;
7641   poly  p = z2 + 1;
7642   poly  q = z3 + 2;
7643   ideal i = p * q^2, y - z2;
[f995aa]7644   list pr = minAss(i);
[808a9f3]7645   pr;
7646}
7647
7648
7649///////////////////////////////////////////////////////////////////////////////
7650//
[f995aa]7651// Computes the minimal associated primes of I via Laplagne algorithm,
[808a9f3]7652// using primary decomposition in the zero dimensional case.
7653// For reduction to the zerodimensional case, it uses the procedure
[f995aa]7654// decomp, with some modifications to avoid the recursion.
[808a9f3]7655//
7656
[f995aa]7657static proc minAssSL(ideal I)
[808a9f3]7658// Input = I, ideal
7659// Output = primaryDec where primaryDec is the list of the minimal
7660// associated primes and the primary components corresponding to these primes.
7661{
7662  ideal P = 1;
7663  list pd = list();
7664  int k;
7665  int stop = 0;
7666  list primaryDec = list();
7667
[70ab73]7668  while (stop == 0)
7669  {
[808a9f3]7670    // Debug
[f995aa]7671    dbprint(printlevel - voice, "// We call minAssSLIteration to find new prime ideals!");
7672    pd = minAssSLIteration(I, P);
[808a9f3]7673    // Debug
[f995aa]7674    dbprint(printlevel - voice, "// Output of minAssSLIteration:");
[808a9f3]7675    dbprint(printlevel - voice, pd);
[70ab73]7676    if (size(pd[1]) > 0)
7677    {
[808a9f3]7678      primaryDec = primaryDec + pd[1];
7679      // Debug
7680      dbprint(printlevel - voice, "// We intersect the prime ideals obtained.");
7681      P = intersect(P, pd[2]);
7682      // Debug
7683      dbprint(printlevel - voice, "// Intersection finished.");
[70ab73]7684    }
7685    else
7686    {
[f3c6e5]7687      stop = 1;
[7f7c25e]7688    }
7689  }
[f3c6e5]7690
[808a9f3]7691  // Returns only the primary components, not the radical.
7692  return(primaryDec);
[f3c6e5]7693}
[808a9f3]7694
7695///////////////////////////////////////////////////////////////////////////////
7696// Given an ideal I and an ideal P (intersection of some minimal prime ideals
7697// associated to I), it calculates new minimal prime ideals associated to I
7698// which were not used to calculate P.
7699// This version uses Primary Decomposition in the zerodimensional case.
[f995aa]7700static proc minAssSLIteration(ideal I, ideal P);
[808a9f3]7701{
7702  int k = 1;
7703  int good  = 0;
7704  list primaryDec = list();
7705  // Debug
7706  dbprint (printlevel-voice, "// We search for an element in P - sqrt(I).");
[70ab73]7707  while ((k <= size(P)) and (good == 0))
7708  {
[808a9f3]7709    good = 1 - rad_con(P[k], I);
7710    k++;
[7f7c25e]7711  }
[808a9f3]7712  k--;
[70ab73]7713  if (good == 0)
7714  {
[808a9f3]7715    // Debug
7716    dbprint (printlevel - voice, "// No element was found, P = sqrt(I).");
7717    return (list(primaryDec, ideal(0)));
[7f7c25e]7718  }
[808a9f3]7719  // Debug
7720  dbprint (printlevel - voice, "// We found h = ", P[k]);
7721  dbprint (printlevel - voice, "// We calculate the saturation of I with respect to the element just founded.");
7722  ideal J = sat(I, P[k])[1];
7723
7724  // Uses decomp from primdec, modified to avoid the recursion.
7725  // Debug
7726  dbprint(printlevel - voice, "// We do the reduction to the zerodimensional case, via decomp.");
7727
7728  primaryDec = newDecompStep(J, "oneIndep", "intersect", 2);
7729  // Debug
7730  dbprint(printlevel - voice, "// Proc decomp has found", size(primaryDec) / 2, "new primary components.");
7731
7732  return(primaryDec);
7733}
7734
7735
7736
7737///////////////////////////////////////////////////////////////////////////////////
7738// Based on maxIndependSet
7739// Added list # as parameter
7740// If the first element of # is 0, the output is only 1 max indep set.
7741// If no list is specified or #[1] = 1, the output is all the max indep set of the
7742// leading terms ideal. This is the original output of maxIndependSet
7743
7744proc newMaxIndependSetLp(ideal j, list #)
[f995aa]7745"USAGE:   newMaxIndependentSetLp(i); i ideal (returns all maximal independent sets of the corresponding leading terms ideal)
7746          newMaxIndependentSetLp(i, 0); i ideal (returns only one maximal independent set)
[808a9f3]7747RETURN:  list = #1. new varstring with the maximal independent set at the end,
[f995aa]7748                #2. ordstring with the lp ordering,
[808a9f3]7749                #3. the number of independent variables
7750NOTE:
[f995aa]7751EXAMPLE: example newMaxIndependentSetLp; shows an example
[808a9f3]7752"
7753{
[70ab73]7754  int n, k, di;
7755  list resu, hilf;
7756  string var1, var2;
7757  list v = indepSet(j, 0);
[808a9f3]7758
[70ab73]7759  // SL 2006.04.21 1 Lines modified to use only one independent Set
7760  string indepOption;
7761  if (size(#) > 0)
7762  {
7763    indepOption = #[1];
7764  }
7765  else
7766  {
7767    indepOption = "allIndep";
7768  }
[808a9f3]7769
[70ab73]7770  int nMax;
7771  if (indepOption == "allIndep")
7772  {
7773    nMax = size(v);
7774  }
7775  else
7776  {
7777    nMax = 1;
7778  }
7779
7780  for(n = 1; n <= nMax; n++)
7781  // SL 2006.04.21 2
7782  {
7783    di = 0;
7784    var1 = "";
7785    var2 = "";
7786    for(k = 1; k <= size(v[n]); k++)
7787    {
7788      if(v[n][k] != 0)
7789      {
7790        di++;
7791        var2 = var2 + "var(" + string(k) + "), ";
[808a9f3]7792      }
7793      else
7794      {
[70ab73]7795        var1 = var1 + "var(" + string(k) + "), ";
[808a9f3]7796      }
[70ab73]7797    }
7798    if(di > 0)
7799    {
7800      var1 = var1 + var2;
7801      var1 = var1[1..size(var1) - 2];       // The "- 2" removes the trailer comma
7802      hilf[1] = var1;
7803      // SL 2006.21.04 1 The order is now block dp instead of lp
7804      //hilf[2] = "dp(" + string(nvars(basering) - di) + "), dp(" + string(di) + ")";
7805      // SL 2006.21.04 2
7806      // For decomp, lp ordering is needed. Nothing is changed.
7807      hilf[2] = "lp";
7808      hilf[3] = di;
7809      resu[n] = hilf;
7810    }
7811    else
7812    {
7813      resu[n] = varstr(basering), ordstr(basering), 0;
7814    }
7815  }
7816  return(resu);
[808a9f3]7817}
7818example
7819{ "EXAMPLE:"; echo = 2;
7820   ring s1 = (0, x, y), (a, b, c, d, e, f, g), lp;
7821   ideal i = ea - fbg, fa + be, ec - fdg, fc + de;
7822   i = std(i);
7823   list l = newMaxIndependSetLp(i);
7824   l;
7825   i = i, g;
7826   l = newMaxIndependSetLp(i);
7827   l;
7828
7829   ring s = 0, (x, y, z), lp;
7830   ideal i = z, yx;
7831   list l = newMaxIndependSetLp(i);
7832   l;
7833}
7834
7835
7836///////////////////////////////////////////////////////////////////////////////
7837
7838proc newZero_decomp (ideal j, ideal ser, int @wr, list #)
7839"USAGE:   newZero_decomp(j,ser,@wr); j,ser ideals, @wr=0 or 1
[7f7c25e]7840         (@wr=0 for primary decomposition, @wr=1 for computation of associated
[808a9f3]7841         primes)
7842         if #[1] = "nest", then #[2] indicates the nest level (number of recursive calls)
7843         When the nest level is high it indicates that the computation is difficult,
7844         and different methods are applied.
7845RETURN:  list = list of primary ideals and their radicals (at even positions
7846         in the list) if the input is zero-dimensional and a standardbases
7847         with respect to lex-ordering
7848         If ser!=(0) and ser is contained in j or if j is not zero-dimen-
7849         sional then ideal(1),ideal(1) is returned
7850NOTE:    Algorithm of Gianni/Trager/Zacharias
7851EXAMPLE: example newZero_decomp; shows an example
7852"
7853{
7854  def   @P = basering;
7855  int uytrewq;
7856  int nva = nvars(basering);
7857  int @k,@s,@n,@k1,zz;
7858  list primary,lres0,lres1,act,@lh,@wh;
7859  map phi,psi,phi1,psi1;
7860  ideal jmap,jmap1,jmap2,helpprim,@qh,@qht,ser1;
7861  intvec @vh,@hilb;
7862  string @ri;
7863  poly @f;
7864
7865  // Debug
7866  dbprint(printlevel - voice, "proc newZero_decomp");
7867
7868  if (dim(j)>0)
7869  {
[70ab73]7870    primary[1]=ideal(1);
7871    primary[2]=ideal(1);
7872    return(primary);
[808a9f3]7873  }
7874  j=interred(j);
7875
7876  attrib(j,"isSB",1);
7877
7878  int nestLevel = 0;
[70ab73]7879  if (size(#) > 0)
7880  {
7881    if (typeof(#[1]) == "string")
7882    {
7883      if (#[1] == "nest")
7884      {
[808a9f3]7885        nestLevel = #[2];
[7f7c25e]7886      }
[808a9f3]7887      # = list();
[7f7c25e]7888    }
7889  }
[808a9f3]7890
7891  if(vdim(j)==deg(j[1]))
7892  {
[70ab73]7893    act=factor(j[1]);
7894    for(@k=1;@k<=size(act[1]);@k++)
7895    {
7896      @qh=j;
7897      if(@wr==0)
7898      {
7899        @qh[1]=act[1][@k]^act[2][@k];
7900      }
7901      else
7902      {
7903        @qh[1]=act[1][@k];
7904      }
7905      primary[2*@k-1]=interred(@qh);
7906      @qh=j;
7907      @qh[1]=act[1][@k];
7908      primary[2*@k]=interred(@qh);
7909      attrib( primary[2*@k-1],"isSB",1);
[808a9f3]7910
[70ab73]7911      if((size(ser)>0)&&(size(reduce(ser,primary[2*@k-1],1))==0))
7912      {
7913        primary[2*@k-1]=ideal(1);
7914        primary[2*@k]=ideal(1);
7915      }
7916    }
7917    return(primary);
[808a9f3]7918  }
7919
7920  if(homog(j)==1)
7921  {
[70ab73]7922    primary[1]=j;
7923    if((size(ser)>0)&&(size(reduce(ser,j,1))==0))
7924    {
7925      primary[1]=ideal(1);
7926      primary[2]=ideal(1);
7927      return(primary);
7928    }
7929    if(dim(j)==-1)
7930    {
7931      primary[1]=ideal(1);
7932      primary[2]=ideal(1);
7933    }
7934    else
7935    {
7936      primary[2]=maxideal(1);
7937    }
7938    return(primary);
[808a9f3]7939  }
7940
7941//the first element in the standardbase is factorized
7942  if(deg(j[1])>0)
7943  {
7944    act=factor(j[1]);
7945    testFactor(act,j[1]);
7946  }
7947  else
7948  {
[70ab73]7949    primary[1]=ideal(1);
7950    primary[2]=ideal(1);
7951    return(primary);
[808a9f3]7952  }
7953
7954//with the factors new ideals (hopefully the primary decomposition)
7955//are created
7956  if(size(act[1])>1)
7957  {
[70ab73]7958    if(size(#)>1)
7959    {
7960      primary[1]=ideal(1);
7961      primary[2]=ideal(1);
7962      primary[3]=ideal(1);
7963      primary[4]=ideal(1);
7964      return(primary);
7965    }
7966    for(@k=1;@k<=size(act[1]);@k++)
7967    {
7968      if(@wr==0)
7969      {
7970        primary[2*@k-1]=std(j,act[1][@k]^act[2][@k]);
7971      }
7972      else
7973      {
7974        primary[2*@k-1]=std(j,act[1][@k]);
7975      }
7976      if((act[2][@k]==1)&&(vdim(primary[2*@k-1])==deg(act[1][@k])))
7977      {
7978        primary[2*@k]   = primary[2*@k-1];
7979      }
7980      else
7981      {
7982        primary[2*@k]   = primaryTest(primary[2*@k-1],act[1][@k]);
7983      }
7984    }
[808a9f3]7985  }
7986  else
7987  {
[70ab73]7988    primary[1]=j;
7989    if((size(#)>0)&&(act[2][1]>1))
7990    {
7991      act[2]=1;
7992      primary[1]=std(primary[1],act[1][1]);
7993    }
7994    if(@wr!=0)
7995    {
7996      primary[1]=std(j,act[1][1]);
7997    }
7998    if((act[2][1]==1)&&(vdim(primary[1])==deg(act[1][1])))
7999    {
8000      primary[2]=primary[1];
8001    }
8002    else
8003    {
8004      primary[2]=primaryTest(primary[1],act[1][1]);
8005    }
[808a9f3]8006  }
8007
8008  if(size(#)==0)
8009  {
[70ab73]8010    primary=splitPrimary(primary,ser,@wr,act);
[808a9f3]8011  }
8012
8013  if((voice>=6)&&(char(basering)<=181))
8014  {
[70ab73]8015    primary=splitCharp(primary);
[808a9f3]8016  }
8017
8018  if((@wr==2)&&(npars(basering)>0)&&(voice>=6)&&(char(basering)>0))
8019  {
8020  //the prime decomposition of Yokoyama in characteristic p
[70ab73]8021    list ke,ek;
8022    @k=0;
8023    while(@k<size(primary)/2)
8024    {
8025      @k++;
8026      if(size(primary[2*@k])==0)
8027      {
8028        ek=insepDecomp(primary[2*@k-1]);
8029        primary=delete(primary,2*@k);
8030        primary=delete(primary,2*@k-1);
8031        @k--;
8032      }
8033      ke=ke+ek;
8034    }
8035    for(@k=1;@k<=size(ke);@k++)
8036    {
8037      primary[size(primary)+1]=ke[@k];
8038      primary[size(primary)+1]=ke[@k];
8039    }
[808a9f3]8040  }
8041
[7f7c25e]8042  if(nestLevel > 1){primary=extF(primary);}
[808a9f3]8043
8044//test whether all ideals in the decomposition are primary and
8045//in general position
8046//if not after a random coordinate transformation of the last
8047//variable the corresponding ideal is decomposed again.
8048  if((npars(basering)>0)&&(nestLevel > 1))
8049  {
[70ab73]8050    poly randp;
8051    for(zz=1;zz<nvars(basering);zz++)
8052    {
8053      randp=randp
[808a9f3]8054              +(random(0,5)*par(1)^2+random(0,5)*par(1)+random(0,5))*var(zz);
[70ab73]8055    }
8056    randp=randp+var(nvars(basering));
[808a9f3]8057  }
8058  @k=0;
8059  while(@k<(size(primary)/2))
8060  {
8061    @k++;
8062    if (size(primary[2*@k])==0)
8063    {
[70ab73]8064      for(zz=1;zz<size(primary[2*@k-1])-1;zz++)
8065      {
8066        attrib(primary[2*@k-1],"isSB",1);
8067        if(vdim(primary[2*@k-1])==deg(primary[2*@k-1][zz]))
8068        {
8069          primary[2*@k]=primary[2*@k-1];
8070        }
8071      }
[808a9f3]8072    }
8073  }
8074
8075  @k=0;
8076  ideal keep;
8077  while(@k<(size(primary)/2))
8078  {
8079    @k++;
8080    if (size(primary[2*@k])==0)
8081    {
[70ab73]8082      jmap=randomLast(100);
8083      jmap1=maxideal(1);
8084      jmap2=maxideal(1);
8085      @qht=primary[2*@k-1];
8086      if((npars(basering)>0)&&(nestLevel > 1))
8087      {
8088        jmap[size(jmap)]=randp;
8089      }
[808a9f3]8090
[70ab73]8091      for(@n=2;@n<=size(primary[2*@k-1]);@n++)
8092      {
8093        if(deg(lead(primary[2*@k-1][@n]))==1)
8094        {
8095          for(zz=1;zz<=nva;zz++)
[808a9f3]8096          {
[70ab73]8097            if(lead(primary[2*@k-1][@n])/var(zz)!=0)
8098            {
8099              jmap1[zz]=-1/leadcoef(primary[2*@k-1][@n])*primary[2*@k-1][@n]
[a36e78]8100                   +2/leadcoef(primary[2*@k-1][@n])*lead(primary[2*@k-1][@n]);
[70ab73]8101              jmap2[zz]=primary[2*@k-1][@n];
8102              @qht[@n]=var(zz);
8103            }
[808a9f3]8104          }
[70ab73]8105          jmap[nva]=subst(jmap[nva],lead(primary[2*@k-1][@n]),0);
8106        }
8107      }
8108      if(size(subst(jmap[nva],var(1),0)-var(nva))!=0)
8109      {
8110        // jmap[nva]=subst(jmap[nva],var(1),0);
8111        //hier geaendert +untersuchen!!!!!!!!!!!!!!
8112      }
8113      phi1=@P,jmap1;
8114      phi=@P,jmap;
8115      for(@n=1;@n<=nva;@n++)
8116      {
8117        jmap[@n]=-(jmap[@n]-2*var(@n));
8118      }
8119      psi=@P,jmap;
8120      psi1=@P,jmap2;
8121      @qh=phi(@qht);
[808a9f3]8122
8123//=================== the new part ============================
8124
[8992ed]8125      if (npars(basering)>1) { @qh=groebner(@qh,"par2var"); }
8126      else                   { @qh=groebner(@qh); }
[808a9f3]8127
8128//=============================================================
8129//       if(npars(@P)>0)
8130//       {
8131//          @ri= "ring @Phelp ="
8132//                  +string(char(@P))+",
8133//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
8134//       }
8135//       else
8136//       {
8137//          @ri= "ring @Phelp ="
8138//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
8139//       }
8140//       execute(@ri);
8141//       ideal @qh=homog(imap(@P,@qht),@t);
8142//
8143//       ideal @qh1=std(@qh);
8144//       @hilb=hilb(@qh1,1);
8145//       @ri= "ring @Phelp1 ="
8146//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
8147//       execute(@ri);
8148//       ideal @qh=homog(imap(@P,@qh),@t);
8149//       kill @Phelp;
8150//       @qh=std(@qh,@hilb);
8151//       @qh=subst(@qh,@t,1);
8152//       setring @P;
8153//       @qh=imap(@Phelp1,@qh);
8154//       kill @Phelp1;
8155//       @qh=clearSB(@qh);
8156//       attrib(@qh,"isSB",1);
8157//=============================================================
8158
[70ab73]8159      ser1=phi1(ser);
8160      @lh=newZero_decomp (@qh,phi(ser1),@wr, list("nest", nestLevel + 1));
[808a9f3]8161
[70ab73]8162      kill lres0;
8163      list lres0;
8164      if(size(@lh)==2)
8165      {
8166        helpprim=@lh[2];
8167        lres0[1]=primary[2*@k-1];
8168        ser1=psi(helpprim);
8169        lres0[2]=psi1(ser1);
8170        if(size(reduce(lres0[2],lres0[1],1))==0)
8171        {
8172          primary[2*@k]=primary[2*@k-1];
8173          continue;
8174        }
8175      }
8176      else
8177      {
8178        lres1=psi(@lh);
8179        lres0=psi1(lres1);
8180      }
[808a9f3]8181
8182//=================== the new part ============================
8183
[70ab73]8184      primary=delete(primary,2*@k-1);
8185      primary=delete(primary,2*@k-1);
8186      @k--;
8187      if(size(lres0)==2)
8188      {
[8992ed]8189        if (npars(basering)>1) { lres0[2]=groebner(lres0[2],"par2var"); }
8190        else                   { lres0[2]=groebner(lres0[2]); }
[70ab73]8191      }
8192      else
8193      {
8194        for(@n=1;@n<=size(lres0)/2;@n++)
8195        {
8196          if(specialIdealsEqual(lres0[2*@n-1],lres0[2*@n])==1)
[808a9f3]8197          {
[a36e78]8198            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
[70ab73]8199            lres0[2*@n]=lres0[2*@n-1];
8200            attrib(lres0[2*@n],"isSB",1);
[808a9f3]8201          }
[70ab73]8202          else
8203          {
[a36e78]8204            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
8205            lres0[2*@n]=groebner(lres0[2*@n]);
[70ab73]8206          }
8207        }
8208      }
8209      primary=primary+lres0;
[808a9f3]8210
8211//=============================================================
8212//       if(npars(@P)>0)
8213//       {
8214//          @ri= "ring @Phelp ="
8215//                  +string(char(@P))+",
8216//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
8217//       }
8218//       else
8219//       {
8220//          @ri= "ring @Phelp ="
8221//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
8222//       }
8223//       execute(@ri);
8224//       list @lvec;
8225//       list @lr=imap(@P,lres0);
8226//       ideal @lr1;
8227//
8228//       if(size(@lr)==2)
8229//       {
8230//          @lr[2]=homog(@lr[2],@t);
8231//          @lr1=std(@lr[2]);
8232//          @lvec[2]=hilb(@lr1,1);
8233//       }
8234//       else
8235//       {
8236//          for(@n=1;@n<=size(@lr)/2;@n++)
8237//          {
8238//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
8239//             {
8240//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
8241//                @lr1=std(@lr[2*@n-1]);
8242//                @lvec[2*@n-1]=hilb(@lr1,1);
8243//                @lvec[2*@n]=@lvec[2*@n-1];
8244//             }
8245//             else
8246//             {
8247//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
8248//                @lr1=std(@lr[2*@n-1]);
8249//                @lvec[2*@n-1]=hilb(@lr1,1);
8250//                @lr[2*@n]=homog(@lr[2*@n],@t);
8251//                @lr1=std(@lr[2*@n]);
8252//                @lvec[2*@n]=hilb(@lr1,1);
8253//
8254//             }
8255//         }
8256//       }
8257//       @ri= "ring @Phelp1 ="
8258//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
8259//       execute(@ri);
8260//       list @lr=imap(@Phelp,@lr);
8261//
8262//       kill @Phelp;
8263//       if(size(@lr)==2)
8264//      {
8265//          @lr[2]=std(@lr[2],@lvec[2]);
8266//          @lr[2]=subst(@lr[2],@t,1);
8267//
8268//       }
8269//       else
8270//       {
8271//          for(@n=1;@n<=size(@lr)/2;@n++)
8272//          {
8273//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
8274//             {
8275//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
8276//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
8277//                @lr[2*@n]=@lr[2*@n-1];
8278//                attrib(@lr[2*@n],"isSB",1);
8279//             }
8280//             else
8281//             {
8282//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
8283//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
8284//                @lr[2*@n]=std(@lr[2*@n],@lvec[2*@n]);
8285//                @lr[2*@n]=subst(@lr[2*@n],@t,1);
8286//             }
8287//          }
8288//       }
8289//       kill @lvec;
8290//       setring @P;
8291//       lres0=imap(@Phelp1,@lr);
8292//       kill @Phelp1;
8293//       for(@n=1;@n<=size(lres0);@n++)
8294//       {
8295//          lres0[@n]=clearSB(lres0[@n]);
8296//          attrib(lres0[@n],"isSB",1);
8297//       }
8298//
8299//       primary[2*@k-1]=lres0[1];
8300//       primary[2*@k]=lres0[2];
8301//       @s=size(primary)/2;
8302//       for(@n=1;@n<=size(lres0)/2-1;@n++)
8303//       {
8304//         primary[2*@s+2*@n-1]=lres0[2*@n+1];
8305//         primary[2*@s+2*@n]=lres0[2*@n+2];
8306//       }
8307//       @k--;
8308//=============================================================
[70ab73]8309    }
[808a9f3]8310  }
8311  return(primary);
8312}
8313example
8314{ "EXAMPLE:"; echo = 2;
8315   ring  r = 0,(x,y,z),lp;
8316   poly  p = z2+1;
8317   poly  q = z4+2;
8318   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
8319   i=std(i);
8320   list  pr= newZero_decomp(i,ideal(0),0);
8321   pr;
8322}
8323///////////////////////////////////////////////////////////////////////////////
8324
[55fcff]8325////////////////////////////////////////////////////////////////////////////
8326/*
8327//Beispiele Wenk-Dipl (in ~/Texfiles/Diplom/Wenk/Examples/)
8328//Zeiten: Singular/Singular/Singular -r123456789 -v :wilde13 (PentiumPro200)
8329//Singular for HPUX-9 version 1-3-8  (2000060214)  Jun  2 2000 15:31:26
8330//(wilde13)
8331
8332//1. vdim=20, 3  Komponenten
8333//zerodec-time:2(1)  (matrix:1 charpoly:0 factor:1)
8334//primdecGTZ-time: 1(0)
8335ring rs= 0,(a,b,c),dp;
8336poly f1= a^2*b*c + a*b^2*c + a*b*c^2 + a*b*c + a*b + a*c + b*c;
8337poly f2= a^2*b^2*c + a*b^2*c^2 + a^2*b*c + a*b*c + b*c + a + c;
8338poly f3= a^2*b^2*c^2 + a^2*b^2*c + a*b^2*c + a*b*c + a*c + c + 1;
8339ideal gls=f1,f2,f3;
8340int time=timer;
8341printlevel =1;
8342time=timer; list pr1=zerodec(gls); timer-time;size(pr1);
8343time=timer; list pr =primdecGTZ(gls); timer-time;size(pr);
[07c623]8344time=timer; ideal ra =radical(gls); timer-time;size(pr);
[55fcff]8345
8346//2.cyclic5  vdim=70, 20 Komponenten
8347//zerodec-time:36(28)  (matrix:1(0) charpoly:18(19) factor:17(9)
8348//primdecGTZ-time: 28(5)
[b9b906]8349//radical : 0
[55fcff]8350ring rs= 0,(a,b,c,d,e),dp;
8351poly f0= a + b + c + d + e + 1;
8352poly f1= a + b + c + d + e;
8353poly f2= a*b + b*c + c*d + a*e + d*e;
8354poly f3= a*b*c + b*c*d + a*b*e + a*d*e + c*d*e;
8355poly f4= a*b*c*d + a*b*c*e + a*b*d*e + a*c*d*e + b*c*d*e;
8356poly f5= a*b*c*d*e - 1;
8357ideal gls= f1,f2,f3,f4,f5;
8358
8359//3. random vdim=40, 1 Komponente
8360//zerodec-time:126(304)  (matrix:1 charpoly:115(298) factor:10(5))
[b9b906]8361//primdecGTZ-time:17 (11)
[55fcff]8362ring rs=0,(x,y,z),dp;
8363poly f1=2*x^2 + 4*x + 3*y^2 + 7*x*z + 9*y*z + 5*z^2;
8364poly f2=7*x^3 + 8*x*y + 12*y^2 + 18*x*z + 3*y^4*z + 10*z^3 + 12;
8365poly f3=3*x^4 + 1*x*y*z + 6*y^3 + 3*x*z^2 + 2*y*z^2 + 4*z^2 + 5;
8366ideal gls=f1,f2,f3;
8367
8368//4. introduction into resultants, sturmfels, vdim=28, 1 Komponente
8369//zerodec-time:4  (matrix:0 charpoly:0 factor:4)
[b9b906]8370//primdecGTZ-time:1
[55fcff]8371ring rs=0,(x,y),dp;
8372poly f1= x4+y4-1;
8373poly f2= x5y2-4x3y3+x2y5-1;
8374ideal gls=f1,f2;
8375
8376//5. 3 quadratic equations with random coeffs, vdim=8, 1 Komponente
8377//zerodec-time:0(0)  (matrix:0 charpoly:0 factor:0)
[b9b906]8378//primdecGTZ-time:1(0)
[55fcff]8379ring rs=0,(x,y,z),dp;
8380poly f1=2*x^2 + 4*x*y + 3*y^2 + 7*x*z + 9*y*z + 5*z^2 + 2;
8381poly f2=7*x^2 + 8*x*y + 12*y^2 + 18*x*z + 3*y*z + 10*z^2 + 12;
8382poly f3=3*x^2 + 1*x*y + 6*y^2 + 3*x*z + 2*y*z + 4*z^2 + 5;
8383ideal gls=f1,f2,f3;
8384
8385//6. 3 polys    vdim=24, 1 Komponente
8386// run("ex14",2);
8387//zerodec-time:5(4)  (matrix:0 charpoly:3(3) factor:2(1))
8388//primdecGTZ-time:4 (2)
8389ring rs=0,(x1,x2,x3,x4),dp;
8390poly f1=16*x1^2 + 3*x2^2 + 5*x3^4 - 1 - 4*x4 + x4^3;
8391poly f2=5*x1^3 + 3*x2^2 + 4*x3^2*x4 + 2*x1*x4 - 1 + x4 + 4*x1 + x2 + x3 + x4;
8392poly f3=-4*x1^2 + x2^2 + x3^2 - 3 + x4^2 + 4*x1 + x2 + x3 + x4;
8393poly f4=-4*x1 + x2 + x3 + x4;
8394ideal gls=f1,f2,f3,f4;
8395
8396//7. ex43, PoSSo, caprasse   vdim=56, 16 Komponenten
[b9b906]8397//zerodec-time:23(15)  (matrix:0 charpoly:16(13) factor:3(2))
[55fcff]8398//primdecGTZ-time:3 (2)
8399ring rs= 0,(y,z,x,t),dp;
8400ideal gls=y^2*z+2*y*x*t-z-2*x,
84014*y^2*z*x-z*x^3+2*y^3*t+4*y*x^2*t-10*y^2+4*z*x+4*x^2-10*y*t+2,
84022*y*z*t+x*t^2-2*z-x,
8403-z^3*x+4*y*z^2*t+4*z*x*t^2+2*y*t^3+4*z^2+4*z*x-10*y*t-10*t^2+2;
8404
8405//8. Arnborg-System, n=6 (II),    vdim=156, 90 Komponenten
8406//zerodec-time (char32003):127(45)(matrix:2(0) charpoly:106(37) factor:16(7))
8407//primdecGTZ-time(char32003) :81 (18)
8408//ring rs= 0,(a,b,c,d,x,f),dp;
8409ring rs= 32003,(a,b,c,d,x,f),dp;
[b9b906]8410ideal gls=a+b+c+d+x+f, ab+bc+cd+dx+xf+af, abc+bcd+cdx+d*xf+axf+abf,
8411abcd+bcdx+cd*xf+ad*xf+abxf+abcf, abcdx+bcd*xf+acd*xf+abd*xf+abcxf+abcdf,
[55fcff]8412abcd*xf-1;
8413
8414//9. ex42, PoSSo, Methan6_1, vdim=27, 2 Komponenten
8415//zerodec-time:610  (matrix:10 charpoly:557 factor:26)
8416//primdecGTZ-time: 118
8417//zerodec-time(char32003):2
8418//primdecGTZ-time(char32003):4
8419//ring rs= 0,(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10),dp;
8420ring rs= 32003,(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10),dp;
8421ideal gls=64*x2*x7-10*x1*x8+10*x7*x9+11*x7*x10-320000*x1,
8422-32*x2*x7-5*x2*x8-5*x2*x10+160000*x1-5000*x2,
8423-x3*x8+x6*x8+x9*x10+210*x6+1300000,
8424-x4*x8+700000,
8425x10^2-2*x5,
8426-x6*x8+x7*x9-210*x6,
8427-64*x2*x7-10*x7*x9-11*x7*x10+320000*x1-16*x7+7000000,
8428-10*x1*x8-10*x2*x8-10*x3*x8-10*x4*x8-10*x6*x8+10*x2*x10+11*x7*x10
8429    +20000*x2+14*x5,
8430x4*x8-x7*x9-x9*x10-410*x9,
843110*x2*x8+10*x3*x8+10*x6*x8+10*x7*x9-10*x2*x10-11*x7*x10-10*x9*x10
8432    -10*x10^2+1400*x6-4200*x10;
8433
8434//10. ex33, walk-s7, Diplomarbeit von Tim, vdim=114
8435//zerfaellt in unterschiedlich viele Komponenten in versch. Charkteristiken:
8436//char32003:30, char0:3(2xdeg1,1xdeg112!), char181:4(2xdeg1,1xdeg28,1xdeg84)
8437//char 0: zerodec-time:10075 (ca 3h) (matrix:3 charpoly:9367, factor:680
8438//        + 24 sec fuer Normalform (anstatt einsetzen), total [29623k])
8439//        primdecGTZ-time: 214
8440//char 32003:zerodec-time:197(68) (matrix:2(1) charpoly:173(60) factor:15(6))
8441//        primdecGTZ-time:14 (5)
8442//char 181:zerodec-time:(87) (matrix:(1) charpoly:(58) factor:(25))
8443//        primdecGTZ-time:(2)
8444//in char181 stimmen Ergebnisse von zerodec und primdecGTZ ueberein (gecheckt)
8445
8446//ring rs= 0,(a,b,c,d,e,f,g),dp;
8447ring rs= 32003,(a,b,c,d,e,f,g),dp;
8448poly f1= 2gb + 2fc + 2ed + a2 + a;
8449poly f2= 2gc + 2fd + e2 + 2ba + b;
8450poly f3= 2gd + 2fe + 2ca + c + b2;
8451poly f4= 2ge + f2 + 2da + d + 2cb;
8452poly f5= 2fg + 2ea + e + 2db + c2;
8453poly f6= g2 + 2fa + f + 2eb + 2dc;
8454poly f7= 2ga + g + 2fb + 2ec + d2;
8455ideal gls= f1,f2,f3,f4,f5,f6,f7;
8456
8457~/Singular/Singular/Singular -r123456789 -v
8458LIB"./primdec.lib";
8459timer=1;
8460int time=timer;
8461printlevel =1;
8462option(prot,mem);
8463time=timer; list pr1=zerodec(gls); timer-time;
8464
8465time=timer; list pr =primdecGTZ(gls); timer-time;
8466time=timer; list pr =primdecSY(gls); timer-time;
[07c623]8467time=timer; ideal ra =radical(gls); timer-time;size(pr);
[24f458]8468LIB"all.lib";
8469
8470ring R=0,(a,b,c,d,e,f),dp;
8471ideal I=cyclic(6);
8472minAssGTZ(I);
8473
8474
8475ring S=(2,a,b),(x,y),lp;
8476ideal I=x8-b,y4+a;
8477minAssGTZ(I);
8478
8479ring S1=2,(x,y,a,b),lp;
8480ideal I=x8-b,y4+a;
8481minAssGTZ(I);
8482
8483
8484ring S2=(2,z),(x,y),dp;
8485minpoly=z2+z+1;
8486ideal I=y3+y+1,x4+x+1;
8487primdecGTZ(I);
8488minAssGTZ(I);
8489
8490ring S3=2,(x,y,z),dp;
8491ideal I=y3+y+1,x4+x+1,z2+z+1;
8492primdecGTZ(I);
8493minAssGTZ(I);
8494
8495
8496ring R1=2,(x,y,z),lp;
8497ideal I=y6+y5+y3+y2+1,x4+x+1,z2+z+1;
8498primdecGTZ(I);
8499minAssGTZ(I);
8500
8501
8502ring R2=(2,z),(x,y),lp;
8503minpoly=z3+z+1;
8504ideal I=y2+y+(z2+z+1),x4+x+1;
8505primdecGTZ(I);
8506minAssGTZ(I);
8507
[55fcff]8508*/
Note: See TracBrowser for help on using the repository browser.