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

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