source: git/Singular/LIB/primdec.lib @ 4c1341

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