source: git/Singular/LIB/primdec.lib @ 6e8b02

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