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

spielwiese
Last change on this file since dbe6a8 was dbe6a8, checked in by Hans Schoenemann <hannes@…>, 9 years ago
fix: redef, quotring
  • 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    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    def quotring;
3343
3344    @n2=size(quprimary);
3345    @n3=@n2;
3346
3347    for(@n1=1;@n1<=size(collectprimary) div 2;@n1++)
3348    {
3349      if(deg(collectprimary[2*@n1][1])>0)
3350      {
3351        @n2++;
3352        quprimary[@n2]=collectprimary[2*@n1-1];
3353        lnew[@n2]=lsau[2*@n1-1];
3354        @n2++;
3355        lnew[@n2]=lsau[2*@n1];
3356        quprimary[@n2]=collectprimary[2*@n1];
3357        if(abspri)
3358        {
3359          absprimary[@n2 div 2]=absprimarytmp[@n1];
3360          abskeep[@n2 div 2]=abskeeptmp[@n1];
3361        }
3362      }
3363    }
3364    //here the intersection with the polynomialring
3365    //mentioned above is really computed
3366    for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
3367    {
3368      if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
3369      {
3370        quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3371        quprimary[2*@n]=quprimary[2*@n-1];
3372      }
3373      else
3374      {
3375        if(@wr==0)
3376        {
3377          quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3378        }
3379        quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
3380      }
3381    }
3382
3383    if(size(@h)>0)
3384    {
3385      //---------------------------------------------------------------
3386      //we change to @Phelp to have the ordering dp for saturation
3387      //---------------------------------------------------------------
3388      setring @Phelp;
3389      @h=imap(gnir,@h);
3390      if(@wr!=1)
3391      {
3392        if(defined(@LL)){kill @LL;}
3393        list @LL=minSat(jwork,@h);
3394        @Ptest=intersect(@Ptest,@LL[1]);
3395        @q=@LL[2];
3396      }
3397      else
3398      {
3399        fac=ideal(0);
3400        for(lauf=1;lauf<=ncols(@h);lauf++)
3401        {
3402          if(deg(@h[lauf])>0)
3403          {
3404            fac=fac+factorize(@h[lauf],1);
3405          }
3406        }
3407        fac=simplify(fac,6);
3408        @q=1;
3409        for(lauf=1;lauf<=size(fac);lauf++)
3410        {
3411          @q=@q*fac[lauf];
3412        }
3413      }
3414      jwork=std(jwork,@q);
3415      keepdi=dim(jwork);
3416      if(keepdi<di)
3417      {
3418        setring gnir;
3419        @j=imap(@Phelp,jwork);
3420        break;
3421      }
3422      if(homo==1)
3423      {
3424        @hilb=hilb(jwork,1,@w);
3425      }
3426
3427      setring gnir;
3428      @j=imap(@Phelp,jwork);
3429    }
3430  }
3431
3432  if((size(quprimary)==0)&&(@wr==1))
3433  {
3434    @j=ideal(1);
3435    quprimary[1]=ideal(1);
3436    quprimary[2]=ideal(1);
3437  }
3438  if((size(quprimary)==0))
3439  {
3440    keepdi=di-1;
3441    quprimary[1]=ideal(1);
3442    quprimary[2]=ideal(1);
3443  }
3444  //---------------------------------------------------------------
3445  //notice that j=sat(j,gh) intersected with (j,gh^n)
3446  //we finished with sat(j,gh) and have to start with (j,gh^n)
3447  //---------------------------------------------------------------
3448  if((deg(@j[1])!=0)&&(@wr!=1))
3449  {
3450    if(size(quprimary)>0)
3451    {
3452      setring @Phelp;
3453      ser=imap(gnir,ser);
3454      hquprimary=imap(gnir,quprimary);
3455      if(@wr==0)
3456      {
3457        //HIER STATT DURCHSCHNITT SATURIEREN!
3458        ideal htest=@Ptest;
3459      }
3460      else
3461      {
3462        ideal htest=hquprimary[2];
3463
3464        for (@n1=2;@n1<=size(hquprimary) div 2;@n1++)
3465        {
3466          htest=intersect(htest,hquprimary[2*@n1]);
3467        }
3468      }
3469
3470      if(size(ser)>0)
3471      {
3472        ser=intersect(htest,ser);
3473      }
3474      else
3475      {
3476        ser=htest;
3477      }
3478      setring gnir;
3479      ser=imap(@Phelp,ser);
3480    }
3481    if(size(reduce(ser,peek,1))!=0)
3482    {
3483      for(@m=1;@m<=size(restindep);@m++)
3484      {
3485        // if(restindep[@m][3]>=keepdi)
3486        // {
3487        isat=0;
3488        @n2=0;
3489
3490        if(restindep[@m][1]==varstr(basering))
3491           //the good case, nothing to do, just to have the same notations
3492           //change the ring
3493        {
3494          execute("ring gnir1 = ("+charstr(basering)+"),("+
3495               varstr(basering)+"),("+ordstr(basering)+");");
3496          ideal @j=fetch(gnir,jkeep);
3497          attrib(@j,"isSB",1);
3498        }
3499        else
3500        {
3501          @va=string(maxideal(1));
3502          execute("ring gnir1 = ("+charstr(basering)+"),("+
3503                      restindep[@m][1]+"),(" +restindep[@m][2]+");");
3504          execute("map phi=gnir,"+@va+";");
3505          op=option(get);
3506          option(redSB);
3507          if(homo==1)
3508          {
3509            ideal @j=std(phi(jkeep),keephilb,@w);
3510          }
3511          else
3512          {
3513            ideal @j=groebner(phi(jkeep));
3514          }
3515          ideal ser=phi(ser);
3516          option(set,op);
3517        }
3518
3519        for (lauf=1;lauf<=size(@j);lauf++)
3520        {
3521          fett[lauf]=size(@j[lauf]);
3522        }
3523        //------------------------------------------------------------------
3524        //we have now the following situation:
3525        //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may
3526        //pass to this quotientring, j is their still a standardbasis, the
3527        //leading coefficients of the polynomials  there (polynomials in
3528        //K[var(nnp+1),..,var(nva)]) are collected in the list h,
3529        //we need their ggt, gh, because of the following:
3530        //let (j:gh^n)=(j:gh^infinity) then
3531        //j*K(var(nnp+1),..,var(nva))[..the rest..]
3532        //intersected with K[var(1),...,var(nva)] is (j:gh^n)
3533        //on the other hand j=(j,gh^n) intersected with (j:gh^n)
3534
3535        //------------------------------------------------------------------
3536
3537        //the arrangement for the quotientring
3538        // K(var(nnp+1),..,var(nva))[..the rest..]
3539        //and the map phi:K[var(1),...,var(nva)] ---->
3540        //--->K(var(nnpr+1),..,var(nva))[..the rest..]
3541        //------------------------------------------------------------------
3542        if (defined(quotring)==voice) {kill quotring;}
3543        def quotring=prepareQuotientring(nvars(basering)-restindep[@m][3],"lp");
3544
3545        //------------------------------------------------------------------
3546        //we pass to the quotientring  K(var(nnp+1),..,var(nva))[..rest..]
3547        //------------------------------------------------------------------
3548
3549        setring quotring;
3550
3551        // @j considered in the quotientring
3552        ideal @j=imap(gnir1,@j);
3553        ideal ser=imap(gnir1,ser);
3554
3555        kill gnir1;
3556
3557        //j is a standardbasis in the quotientring but usually not minimal
3558        //here it becomes minimal
3559        @j=clearSB(@j,fett);
3560        attrib(@j,"isSB",1);
3561
3562        //we need later ggt(h[1],...)=gh for saturation
3563        ideal @h;
3564
3565        for(@n=1;@n<=size(@j);@n++)
3566        {
3567          @h[@n]=leadcoef(@j[@n]);
3568        }
3569        //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..rest..]
3570
3571        op=option(get);
3572        option(redSB);
3573        list uprimary= zero_decomp(@j,ser,@wr);
3574//HIER
3575        if(abspri)
3576        {
3577          ideal II;
3578          ideal jmap;
3579          map sigma;
3580          nn=nvars(basering);
3581          map invsigma=basering,maxideal(1);
3582          for(ab=1;ab<=size(uprimary) div 2;ab++)
3583          {
3584            II=uprimary[2*ab];
3585            attrib(II,"isSB",1);
3586            if(deg(II[1])!=vdim(II))
3587            {
3588              jmap=randomLast(50);
3589              sigma=basering,jmap;
3590              jmap[nn]=2*var(nn)-jmap[nn];
3591              invsigma=basering,jmap;
3592              II=groebner(sigma(II));
3593            }
3594            absprimarytmp[ab]= absFactorize(II[1],77);
3595            II=var(nn);
3596            abskeeptmp[ab]=string(invsigma(II));
3597            invsigma=basering,maxideal(1);
3598          }
3599        }
3600        option(set,op);
3601
3602        //we need the intersection of the ideals in the list quprimary with
3603        //the polynomialring, i.e. let q=(f1,...,fr) in the quotientring
3604        //such an ideal but fi polynomials, then the intersection of q with
3605        //the polynomialring is the saturation of the ideal generated by
3606        //f1,...,fr with respect toh which is the lcm of the leading
3607        //coefficients of the fi considered in the quotientring:
3608        //this is coded in saturn
3609
3610        list saturn;
3611        ideal hpl;
3612
3613        for(@n=1;@n<=size(uprimary);@n++)
3614        {
3615          hpl=0;
3616          for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
3617          {
3618            hpl=hpl,leadcoef(uprimary[@n][@n1]);
3619          }
3620          saturn[@n]=hpl;
3621        }
3622        //------------------------------------------------------------------
3623        //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..rest..]
3624        //back to the polynomialring
3625        //------------------------------------------------------------------
3626        setring gnir;
3627        collectprimary=imap(quotring,uprimary);
3628        lsau=imap(quotring,saturn);
3629        @h=imap(quotring,@h);
3630
3631        kill quotring;
3632
3633        @n2=size(quprimary);
3634        @n3=@n2;
3635
3636        for(@n1=1;@n1<=size(collectprimary) div 2;@n1++)
3637        {
3638          if(deg(collectprimary[2*@n1][1])>0)
3639          {
3640            @n2++;
3641            quprimary[@n2]=collectprimary[2*@n1-1];
3642            lnew[@n2]=lsau[2*@n1-1];
3643            @n2++;
3644            lnew[@n2]=lsau[2*@n1];
3645            quprimary[@n2]=collectprimary[2*@n1];
3646            if(abspri)
3647            {
3648              absprimary[@n2 div 2]=absprimarytmp[@n1];
3649              abskeep[@n2 div 2]=abskeeptmp[@n1];
3650            }
3651          }
3652        }
3653
3654
3655        //here the intersection with the polynomialring
3656        //mentioned above is really computed
3657
3658        for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
3659        {
3660          if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
3661          {
3662            quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3663            quprimary[2*@n]=quprimary[2*@n-1];
3664          }
3665          else
3666          {
3667            if(@wr==0)
3668            {
3669              quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
3670            }
3671            quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
3672          }
3673        }
3674        if(@n2>=@n3+2)
3675        {
3676          setring @Phelp;
3677          ser=imap(gnir,ser);
3678          hquprimary=imap(gnir,quprimary);
3679          for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
3680          {
3681            if(@wr==0)
3682            {
3683              ser=intersect(ser,hquprimary[2*@n-1]);
3684            }
3685            else
3686            {
3687              ser=intersect(ser,hquprimary[2*@n]);
3688            }
3689          }
3690          setring gnir;
3691          ser=imap(@Phelp,ser);
3692        }
3693
3694         // }
3695      }
3696//HIER
3697      if(abspri)
3698      {
3699        list resu,tempo;
3700        for(ab=1;ab<=size(quprimary) div 2;ab++)
3701        {
3702          if (deg(quprimary[2*ab][1])!=0)
3703          {
3704            tempo=quprimary[2*ab-1],quprimary[2*ab],
3705                         absprimary[ab],abskeep[ab];
3706            resu[ab]=tempo;
3707          }
3708        }
3709        quprimary=resu;
3710        @wr=3;
3711      }
3712      if(size(reduce(ser,peek,1))!=0)
3713      {
3714        if(@wr>0)
3715        {
3716          htprimary=decomp(@j,@wr,peek,ser);
3717        }
3718        else
3719        {
3720          htprimary=decomp(@j,peek,ser);
3721        }
3722        // here we collect now both results primary(sat(j,gh))
3723        // and primary(j,gh^n)
3724        @n=size(quprimary);
3725        for (@k=1;@k<=size(htprimary);@k++)
3726        {
3727          quprimary[@n+@k]=htprimary[@k];
3728        }
3729      }
3730    }
3731  }
3732  else
3733  {
3734    if(abspri)
3735    {
3736      list resu,tempo;
3737      for(ab=1;ab<=size(quprimary) div 2;ab++)
3738      {
3739        tempo=quprimary[2*ab-1],quprimary[2*ab],
3740                   absprimary[ab],abskeep[ab];
3741        resu[ab]=tempo;
3742      }
3743      quprimary=resu;
3744    }
3745  }
3746  //---------------------------------------------------------------------------
3747  //back to the ring we started with
3748  //the final result: primary
3749  //---------------------------------------------------------------------------
3750  setring @P;
3751  primary=imap(gnir,quprimary);
3752  if(!abspri)
3753  {
3754    primary=cleanPrimary(primary);
3755  }
3756  if (size(primary)>0)
3757  {
3758    if (abspri && (typeof(primary[1][1])=="poly"))
3759    { return(prepare_absprimdec(primary));}
3760  }
3761  return(primary);
3762}
3763
3764
3765example
3766{ "EXAMPLE:"; echo = 2;
3767   ring  r = 32003,(x,y,z),lp;
3768   poly  p = z2+1;
3769   poly  q = z4+2;
3770   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
3771   list pr= decomp(i);
3772   pr;
3773   testPrimary( pr, i);
3774}
3775
3776///////////////////////////////////////////////////////////////////////////////
3777static proc powerCoeffs(poly f,int e)
3778//computes a polynomial with the same monomials as f but coefficients
3779//the p^e th power of the coefficients of f
3780{
3781   ASSUME(1, hasFieldCoefficient(basering) );
3782   ASSUME(1, not isQuotientRing(basering) ) ;
3783   ASSUME(1, hasGlobalOrdering(basering) ) ;
3784
3785   int i;
3786   poly g;
3787   int ex=char(basering)^e;
3788   for(i=1;i<=size(f);i++)
3789   {
3790      g=g+leadcoef(f[i])^ex*leadmonom(f[i]);
3791   }
3792   return(g);
3793}
3794///////////////////////////////////////////////////////////////////////////////
3795
3796proc sep(poly f,int i, list #)
3797"USAGE:  input: a polynomial f depending on the i-th variable and optional
3798         an integer k considering the polynomial f defined over Fp(t1,...,tm)
3799         as polynomial over Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3800 RETURN: the separabel part of f as polynomial in Fp(t1,...,tm)
3801        and an integer k to indicate that f should be considerd
3802        as polynomial over Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3803 EXAMPLE: example sep; shows an example
3804{
3805   ASSUME(0, hasFieldCoefficient(basering) );
3806   ASSUME(0, not isQuotientRing(basering) ) ;
3807   ASSUME(0, hasGlobalOrdering(basering) ) ;
3808
3809   def R=basering;
3810   int k;
3811   if(size(#)>0){k=#[1];}
3812
3813
3814   poly h=gcd(f,diff(f,var(i)));
3815   if((reduce(f,std(h))!=0)||(reduce(diff(f,var(i)),std(h))!=0))
3816   {
3817      ERROR("FEHLER IN GCD");
3818   }
3819   poly g1=lift(h,f)[1][1];    //  f/h
3820   poly h1;
3821
3822   while(h!=h1)
3823   {
3824      h1=h;
3825      h=gcd(h,diff(h,var(i)));
3826   }
3827
3828   if(deg(h1)==0){return(list(g1,k));} //in characteristic 0 we return here
3829
3830   k++;
3831
3832   ideal ma=maxideal(1);
3833   ma[i]=var(i)^char(R);
3834   map phi=R,ma;
3835   ideal hh=h;    //this is technical because preimage works only for ideals
3836
3837   poly u=preimage(R,phi,hh)[1]; //h=u(x(i)^p)
3838
3839   list g2=sep(u,i,k);           //we consider u(t(1)^(p^-1),...,t(m)^(p^-1))
3840   g1=powerCoeffs(g1,g2[2]-k+1); //to have g1 over the same field as g2[1]
3841
3842   list g3=sep(g1*g2[1],i,g2[2]);
3843   return(g3);
3844}
3845example
3846{ "EXAMPLE:"; echo = 2;
3847   ring R=(5,t,s),(x,y,z),dp;
3848   poly f=(x^25-t*x^5+t)*(x^3+s);
3849   sep(f,1);
3850}
3851
3852///////////////////////////////////////////////////////////////////////////////
3853 proc zeroRad(ideal I,list #)
3854"USAGE:  zeroRad(I) , I a zero-dimensional ideal
3855 RETURN: the radical of I
3856 NOTE:  Algorithm of Kemper
3857 EXAMPLE: example zeroRad; shows an example
3858{
3859   ASSUME(0, hasFieldCoefficient(basering) );
3860   ASSUME(0, not isQuotientRing(basering) ) ;
3861   ASSUME(0, hasGlobalOrdering(basering) ) ;
3862
3863   if(homog(I)==1){return(maxideal(1));}
3864   //I needs to be a reduced standard basis
3865   def R=basering;
3866   int m=npars(R);
3867   int n=nvars(R);
3868   int p=char(R);
3869   int d=vdim(I);
3870   int i,k;
3871   list l;
3872   if(((p==0)||(p>d))&&(d==deg(I[1])))
3873   {
3874     intvec e=leadexp(I[1]);
3875     for(i=1;i<=nvars(basering);i++)
3876     {
3877       if(e[i]!=0) break;
3878     }
3879     I[1]=sep(I[1],i)[1];
3880     return(interred(I));
3881   }
3882   intvec op=option(get);
3883
3884   option(redSB);
3885   ASSUME(1, dim(I)==0);
3886   ideal F=finduni(I);//F[i] generates I intersected with K[var(i)]
3887
3888   option(set,op);
3889   if(size(#)>0){I=#[1];}
3890
3891   for(i=1;i<=n;i++)
3892   {
3893      l[i]=sep(F[i],i);
3894      F[i]=l[i][1];
3895      if(l[i][2]>k){k=l[i][2];}  //computation of the maximal k
3896   }
3897
3898   if((k==0)||(m==0)) //the separable case
3899   {
3900    intvec save=option(get);option(redSB);
3901    I=interred(I+F);option(set,save);return(I);
3902   }
3903   //I=simplify(I,1);
3904
3905   for(i=1;i<=n;i++)             //consider all polynomials over
3906   {                             //Fp(t(1)^(p^-k),...,t(m)^(p^-k))
3907      F[i]=powerCoeffs(F[i],k-l[i][2]);
3908   }
3909
3910   string cR="ring @R="+string(p)+",("+parstr(R)+","+varstr(R)+"),dp;";
3911   execute(cR);
3912   ideal F=imap(R,F);
3913
3914   string nR1="ring @S1="+string(p)+",("+varstr(R)+","+parstr(R)+",@y(1..m)),dp;";
3915   execute(nR1);
3916   list lR=ringlist(@S1)[2];
3917   lR=lR[(size(lR)-m+1)..(size(lR))];
3918
3919   string nR="ring @S="+string(p)+",("+string(lR)+","+varstr(R)+","+parstr(R)+"),dp;";
3920   execute(nR);
3921
3922   ideal G=fetch(@R,F);    //G[i](t(1)^(p^-k),...,t(m)^(p^-k),x(i))=sep(F[i])
3923
3924   ideal I=imap(R,I);
3925   ideal J=I+G;
3926   poly el=1;
3927   k=p^k;
3928   for(i=1;i<=m;i++)
3929   {
3930      J=J,var(i)^k-var(m+n+i);
3931      el=el*var(i);
3932   }
3933
3934   J=eliminate(J,el);
3935   setring R;
3936   ideal J=imap(@S,J);
3937   return(J);
3938}
3939example
3940{ "EXAMPLE:"; echo = 2;
3941   ring R=(5,t),(x,y),dp;
3942   ideal I=x^5-t,y^5-t;
3943   zeroRad(I);
3944}
3945
3946///////////////////////////////////////////////////////////////////////////////
3947
3948proc radicalEHV(ideal i)
3949"USAGE:   radicalEHV(i); i ideal.
3950RETURN:  ideal, the radical of i.
3951NOTE:    Uses the algorithm of Eisenbud/Huneke/Vasconcelos, which
3952         reduces the computation to the complete intersection case,
3953         by taking, in the general case, a generic linear combination
3954         of the input.
3955         Works only in characteristic 0 or p large.
3956EXAMPLE: example radicalEHV; shows an example
3957"
3958{
3959   ASSUME(0, hasFieldCoefficient(basering) );
3960   ASSUME(0, not isQuotientRing(basering) ) ;
3961   if(attrib(basering,"global")!=1)
3962   {
3963      ERROR(
3964      "// Not implemented for this ordering, please change to global ordering."
3965      );
3966   }
3967
3968   if((char(basering)<100)&&(char(basering)!=0))
3969   {
3970      "WARNING: The characteristic is too small, the result may be wrong";
3971   }
3972   if ( size(i)==0 ) { return(ideal(0)); }
3973
3974   ideal J,I,I0,radI0,L,radI1,I2,radI2;
3975   int l,n;
3976   intvec op=option(get);
3977   matrix M;
3978
3979   option(redSB);
3980   list m=mstd(i);
3981        I=m[2];
3982   option(set,op);
3983
3984   if ( dim(m[1])<0 ) { return(ideal(1)); }
3985
3986   int cod=nvars(basering)-dim(m[1]);
3987   //-------------------complete intersection case:----------------------
3988   if(cod==size(m[2]))
3989   {
3990     J=minor(jacob(I),cod);
3991     return(quotient(I,J));
3992   }
3993   //-----first codim elements of I are a complete intersection:---------
3994   for(l=1;l<=cod;l++)
3995   {
3996      I0[l]=I[l];
3997   }
3998   n=dim(std(I0))+cod-nvars(basering);
3999   //-----last codim elements of I are a complete intersection:----------
4000   if(n!=0)
4001   {
4002      for(l=1;l<=cod;l++)
4003      {
4004         I0[l]=I[size(I)-l+1];
4005      }
4006      n=dim(std(I0))+cod-nvars(basering);
4007   }
4008   //-----taking a generic linear combination of the input:--------------
4009   if(n!=0)
4010   {
4011      M=transpose(sparsetriag(size(m[2]),cod,95,1));
4012      I0=ideal(M*transpose(I));
4013      n=dim(std(I0))+cod-nvars(basering);
4014   }
4015   //-----taking a more generic linear combination of the input:---------
4016   if(n!=0)
4017   {
4018      M=transpose(sparsetriag(size(m[2]),cod,0,100));
4019      I0=ideal(M*transpose(I));
4020      n=dim(std(I0))+cod-nvars(basering);
4021   }
4022   if(n==0)
4023   {
4024      J=minor(jacob(I0),cod);
4025      radI0=quotient(I0,J);
4026      L=quotient(radI0,I);
4027      radI1=quotient(radI0,L);
4028
4029      if(size(reduce(radI1,m[1],1))==0)
4030      {
4031         return(I);
4032      }
4033
4034      I2=sat(I,radI1)[1];
4035
4036      if(deg(I2[1])<=0)
4037      {
4038         return(radI1);
4039      }
4040      return(intersect(radI1,radicalEHV(I2)));
4041   }
4042   //---------------------general case-------------------------------------
4043   return(radical(I));
4044}
4045example
4046{ "EXAMPLE:";  echo = 2;
4047   ring  r = 0,(x,y,z),dp;
4048   poly  p = z2+1;
4049   poly  q = z3+2;
4050   ideal i = p*q^2,y-z2;
4051   ideal pr= radicalEHV(i);
4052   pr;
4053}
4054
4055///////////////////////////////////////////////////////////////////////////////
4056
4057proc Ann(module M)
4058"USAGE:   Ann(M);  M module
4059RETURN:  ideal, the annihilator of coker(M)
4060NOTE:    The output is the ideal of all elements a of the basering R such that
4061         a * R^m is contained in M  (m=number of rows of M).
4062EXAMPLE: example Ann; shows an example
4063"
4064{
4065
4066  M=prune(M);  //to obtain a small embedding
4067  ideal ann=quotient1(M,freemodule(nrows(M)));
4068  return(ann);
4069}
4070example
4071{ "EXAMPLE:"; echo = 2;
4072   ring  r = 0,(x,y,z),lp;
4073   module M = x2-y2,z3;
4074   Ann(M);
4075   M = [1,x2],[y,x];
4076   Ann(M);
4077   qring Q=std(xy-1);
4078   module M=imap(r,M);
4079   Ann(M);
4080}
4081
4082///////////////////////////////////////////////////////////////////////////////
4083
4084//computes the equidimensional part of the ideal i of codimension e
4085static proc int_ass_primary_e(ideal i, int e)
4086{
4087  ASSUME(1, hasFieldCoefficient(basering) );
4088  ASSUME(1, not isQuotientRing(basering) ) ;
4089  ASSUME(1, hasGlobalOrdering(basering) ) ;
4090
4091  if(homog(i)!=1)
4092  {
4093     i=std(i);
4094  }
4095  list re=sres(i,0);                   //the resolution
4096  re=minres(re);                       //minimized resolution
4097  ideal ann = AnnExt_R(e,re);
4098  if ( nvars(basering)-dim(std(ann)) != e )
4099  {
4100    return( ideal(1) );
4101  }
4102  return(ann);
4103}
4104
4105///////////////////////////////////////////////////////////////////////////////
4106
4107//computes the annihilator of Ext^n(R/i,R) with given resolution re
4108//n is not necessarily the number of variables
4109// !! borrowed correct code from 'ehv.lib::AnnExtEHV' by Kai Dehmann !! duplicate code!! (jk)
4110
4111static proc AnnExt_R(int n,list re)
4112"USAGE:   AnnExt_R(n,re); n integer, re resolution
4113RETURN:  ideal, the annihilator of Ext^n(R/I,R) with given
4114         resolution re of I
4115"
4116{
4117
4118  if(n < 0)
4119    {
4120      ideal ann = ideal(1);
4121      return(ann);
4122    }
4123  int l = size(re);
4124
4125  if(n < l)
4126    {
4127      matrix f = transpose(re[n+1]);
4128      if(n == 0)
4129        {
4130          matrix g = 0*gen(ncols(f));
4131        }
4132      else
4133        {
4134          matrix g = transpose(re[n]);
4135        }
4136      module k = syz(f);
4137      ideal ann = quotient1(g,k);
4138      return(ann);
4139    }
4140
4141  if(n == l)
4142    {
4143      ideal ann = Ann(transpose(re[n]));
4144      return(ann);
4145    }
4146
4147  ideal ann = ideal(1);
4148  return(ann);
4149}
4150///////////////////////////////////////////////////////////////////////////////
4151
4152static proc analyze(list pr)
4153{
4154   ASSUME(1, hasFieldCoefficient(basering) );
4155   ASSUME(1, not isQuotientRing(basering) ) ;
4156   ASSUME(1, hasGlobalOrdering(basering) ) ;
4157
4158   int ii,jj;
4159   for(ii=1;ii<=size(pr) div 2;ii++)
4160   {
4161      dim(std(pr[2*ii]));
4162      idealsEqual(pr[2*ii-1],pr[2*ii]);
4163      "===========================";
4164   }
4165
4166   for(ii=size(pr) div 2;ii>1;ii--)
4167   {
4168      for(jj=1;jj<ii;jj++)
4169      {
4170         if(size(reduce(pr[2*jj],std(pr[2*ii],1)))==0)
4171         {
4172            "eingebette Komponente";
4173            jj;
4174            ii;
4175         }
4176      }
4177   }
4178}
4179
4180///////////////////////////////////////////////////////////////////////////////
4181//
4182//                  Shimoyama-Yokoyama
4183//
4184///////////////////////////////////////////////////////////////////////////////
4185static proc simplifyIdeal(ideal i)
4186{
4187  ASSUME(1, hasFieldCoefficient(basering) );
4188  ASSUME(1, hasGlobalOrdering(basering) ) ;
4189
4190  def r=basering;
4191
4192  ideal iwork=i;
4193  ideal imap2=maxideal(1);
4194
4195  int j,k;
4196  map phi;
4197  poly p;
4198  ideal imap1=maxideal(1);
4199  // first try: very simple substitutions
4200  intvec tested=0:nvars(r);
4201  for(j=1;j<=nvars(r);j++)
4202  {
4203    for(k=1;k<=ncols(i);k++)
4204    {
4205      if(deg(iwork[k]/var(j))==0)
4206      {
4207        p=-1/leadcoef(iwork[k]/var(j))*iwork[k];
4208        if(size(p)<=2)
4209        {
4210          tested[j]=1;
4211          imap1[j]=p+2*var(j);
4212          phi=r,imap1;
4213          iwork=phi(iwork);
4214          iwork=subst(iwork,var(j),0);
4215          iwork[k]=var(j);
4216          imap1=maxideal(1);
4217          imap2[j]=-p;
4218          break;
4219        }
4220      }
4221    }
4222  }
4223  // second try: substitutions not so simple
4224  for(j=1;j<=nvars(r);j++)
4225  {
4226    if (tested[j]==0)
4227    {
4228      for(k=1;k<=ncols(i);k++)
4229      {
4230        if(deg(iwork[k]/var(j))==0)
4231        {
4232          p=-1/leadcoef(iwork[k]/var(j))*iwork[k];
4233          imap1[j]=p+2*var(j);
4234          phi=r,imap1;
4235          iwork=phi(iwork);
4236          iwork=subst(iwork,var(j),0);
4237          iwork[k]=var(j);
4238          imap1=maxideal(1);
4239          imap2[j]=-p;
4240          break;
4241        }
4242      }
4243    }
4244  }
4245  return(iwork,imap2);
4246}
4247
4248
4249///////////////////////////////////////////////////////
4250// ini_mod
4251// input: a polynomial p
4252// output: the initial term of p as needed
4253// in the context of characteristic sets
4254//////////////////////////////////////////////////////
4255
4256static proc ini_mod(poly p)
4257{
4258  if (p==0)
4259  {
4260    return(0);
4261  }
4262  int n; matrix m;
4263  for( n=nvars(basering); n>0; n--)
4264  {
4265    m=coef(p,var(n));
4266    if(m[1,1]!=1)
4267    {
4268      p=m[2,1];
4269      break;
4270    }
4271  }
4272  if(deg(p)==0)
4273  {
4274    p=0;
4275  }
4276  return(p);
4277}
4278///////////////////////////////////////////////////////
4279// min_ass_prim_charsets
4280// input: generators of an ideal PS and an integer cho
4281// If cho=0, the given ordering of the variables is used.
4282// Otherwise, the system tries to find an "optimal ordering",
4283// which in some cases may considerably speed up the algorithm
4284// output: the minimal associated primes of PS
4285// algorithm: via characteriostic sets
4286//////////////////////////////////////////////////////
4287
4288
4289static proc min_ass_prim_charsets (ideal PS, int cho)
4290{
4291  if((cho<0) and (cho>1))
4292  {
4293    ERROR("<int> must be 0 or 1");
4294  }
4295  intvec saveopt=option(get);
4296  option(notWarnSB);
4297  list L;
4298  if(cho==0)
4299  {
4300    L=min_ass_prim_charsets0(PS);
4301  }
4302  else
4303  {
4304    L=min_ass_prim_charsets1(PS);
4305  }
4306  option(set,saveopt);
4307  return(L);
4308}
4309///////////////////////////////////////////////////////
4310// min_ass_prim_charsets0
4311// input: generators of an ideal PS
4312// output: the minimal associated primes of PS
4313// algorithm: via characteristic sets
4314// the given ordering of the variables is used
4315//////////////////////////////////////////////////////
4316
4317
4318static proc min_ass_prim_charsets0 (ideal PS)
4319{
4320  ASSUME(1, hasFieldCoefficient(basering) );
4321  ASSUME(1, not isQuotientRing(basering) ) ;
4322  ASSUME(1, hasGlobalOrdering(basering) ) ;
4323
4324  intvec op;
4325  matrix m=char_series(PS);  // We compute an irreducible
4326                             // characteristic series
4327  if ((nrows(m)==1)
4328  && (ncols(m)==1)
4329  && (m[1,1]==1)) // in case of an empty series: min_ass_prim_charsets1
4330  {
4331    return min_ass_prim_charsets1(PS);
4332  }
4333  int i,j,k;
4334  list PSI;
4335  list PHI;  // the ideals given by the characteristic series
4336  for(i=nrows(m);i>=1; i--)
4337  {
4338    PHI[i]=ideal(m[i,1..ncols(m)]);
4339  }
4340  // We compute the radical of each ideal in PHI
4341  ideal I,JS,II;
4342  int sizeJS, sizeII;
4343  for(i=size(PHI);i>=1; i--)
4344  {
4345    I=0;
4346    for(j=size(PHI[i]);j>0;j--)
4347    {
4348      I=I+ini_mod(PHI[i][j]);
4349    }
4350    JS=std(PHI[i]);
4351    sizeJS=size(JS);
4352    for(j=size(I);j>0;j--)
4353    {
4354      II=0;
4355      sizeII=0;
4356      k=0;
4357      while(k<=sizeII)                  // successive saturation
4358      {
4359        op=option(get);
4360        option(returnSB);
4361        II=quotient(JS,I[j]);
4362        option(set,op);
4363        sizeII=size(II);
4364        if(sizeII==sizeJS)
4365        {
4366          for(k=1;k<=sizeII;k++)
4367          {
4368            if(leadexp(II[k])!=leadexp(JS[k])) break;
4369          }
4370        }
4371        JS=II;
4372        sizeJS=sizeII;
4373      }
4374    }
4375    PSI=insert(PSI,JS);
4376  }
4377  int sizePSI=size(PSI);
4378  // We eliminate redundant ideals
4379  for(i=1;i<sizePSI;i++)
4380  {
4381    for(j=i+1;j<=sizePSI;j++)
4382    {
4383      if(size(PSI[i])!=0)
4384      {
4385        if(size(PSI[j])!=0)
4386        {
4387          if(size(NF(PSI[i],PSI[j],1))==0)
4388          {
4389            PSI[j]=ideal(0);
4390          }
4391          else
4392          {
4393            if(size(NF(PSI[j],PSI[i],1))==0)
4394            {
4395              PSI[i]=ideal(0);
4396            }
4397          }
4398        }
4399      }
4400    }
4401  }
4402  for(i=sizePSI;i>=1;i--)
4403  {
4404    if(size(PSI[i])==0)
4405    {
4406      PSI=delete(PSI,i);
4407    }
4408  }
4409  return (PSI);
4410}
4411
4412///////////////////////////////////////////////////////
4413// min_ass_prim_charsets1
4414// input: generators of an ideal PS
4415// output: the minimal associated primes of PS
4416// algorithm: via characteristic sets
4417// input: generators of an ideal PS and an integer i
4418// The system tries to find an "optimal ordering" of
4419// the variables
4420//////////////////////////////////////////////////////
4421
4422
4423static proc min_ass_prim_charsets1 (ideal PS)
4424{
4425  ASSUME(1, hasFieldCoefficient(basering) );
4426  ASSUME(1, not isQuotientRing(basering) ) ;
4427  ASSUME(1, hasGlobalOrdering(basering) ) ;
4428
4429  intvec op;
4430  def oldring=basering;
4431  string n=system("neworder",PS);
4432  execute("ring r=("+charstr(oldring)+"),("+n+"),dp;");
4433  ideal PS=imap(oldring,PS);
4434  matrix m=char_series(PS);  // We compute an irreducible
4435                             // characteristic series
4436                             // this series may be empty (1x1: 1)
4437  int i,j,k,cnt;
4438  while ((cnt<nvars(oldring))
4439  && (nrows(m)==1)
4440  && (ncols(m)==1)
4441  && (m[1,1]==1)) // in case of an empty series: permute the variables
4442  {
4443    cnt++;
4444    n=string(var(nvars(oldring)));
4445    for(i=1;i<nvars(oldring);i++) { n=n+","+string(var(i)); }
4446    kill r;
4447    execute("ring r=("+charstr(oldring)+"),("+n+"),dp;");
4448    ideal PS=imap(oldring,PS);
4449    matrix m=char_series(PS);
4450  }
4451  ideal I;
4452  list PSI;
4453  list PHI;    // the ideals given by the characteristic series
4454  list ITPHI;  // their initial terms
4455  for(i=nrows(m);i>=1; i--)
4456  {
4457    PHI[i]=simplify(ideal(m[i,1..ncols(m)]),2);
4458    I=0;
4459    for(j=ncols(PHI[i]);j>0;j--)
4460    {
4461      I=I,ini_mod(PHI[i][j]);
4462    }
4463    I=I[2..ncols(I)];
4464    ITPHI[i]=I;
4465  }
4466  setring oldring;
4467  matrix m=imap(r,m);
4468  list PHI=imap(r,PHI);
4469  list ITPHI=imap(r,ITPHI);
4470  // We compute the radical of each ideal in PHI
4471  ideal I,JS,II;
4472  int sizeJS, sizeII;
4473  for(i=size(PHI);i>=1; i--)
4474  {
4475    I=0;
4476    for(j=size(PHI[i]);j>0;j--)
4477    {
4478      I=I+ITPHI[i][j];
4479    }
4480    JS=std(PHI[i]);
4481    sizeJS=size(JS);
4482    for(j=size(I);j>0;j--)
4483    {
4484      II=0;
4485      sizeII=0;
4486      k=0;
4487      while(k<=sizeII)                  // successive iteration
4488      {
4489        op=option(get);
4490        option(returnSB);
4491        II=quotient(JS,I[j]);
4492        option(set,op);
4493//std
4494//         II=std(II);
4495        sizeII=size(II);
4496        if(sizeII==sizeJS)
4497        {
4498          for(k=1;k<=sizeII;k++)
4499          {
4500            if(leadexp(II[k])!=leadexp(JS[k])) break;
4501          }
4502        }
4503        JS=II;
4504        sizeJS=sizeII;
4505      }
4506    }
4507    PSI=insert(PSI,JS);
4508  }
4509  int sizePSI=size(PSI);
4510  // We eliminate redundant ideals
4511  for(i=1;i<sizePSI;i++)
4512  {
4513    for(j=i+1;j<=sizePSI;j++)
4514    {
4515      if(size(PSI[i])!=0)
4516      {
4517        if(size(PSI[j])!=0)
4518        {
4519          if(size(NF(PSI[i],PSI[j],1))==0)
4520          {
4521            PSI[j]=ideal(0);
4522          }
4523          else
4524          {
4525            if(size(NF(PSI[j],PSI[i],1))==0)
4526            {
4527              PSI[i]=ideal(0);
4528            }
4529          }
4530        }
4531      }
4532    }
4533  }
4534  for(i=sizePSI;i>=1;i--)
4535  {
4536    if(size(PSI[i])==0)
4537    {
4538      PSI=delete(PSI,i);
4539    }
4540  }
4541  return (PSI);
4542}
4543
4544
4545/////////////////////////////////////////////////////
4546// proc prim_dec
4547// input:  generators of an ideal I and an integer choose
4548// If choose=0, min_ass_prim_charsets with the given
4549// ordering of the variables is used.
4550// If choose=1, min_ass_prim_charsets with the "optimized"
4551// ordering of the variables is used.
4552// If choose=2, minAssPrimes from primdec.lib is used
4553// If choose=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4554// output: a primary decomposition of I, i.e., a list
4555// of pairs consisting of a standard basis of a primary component
4556// of I and a standard basis of the corresponding associated prime.
4557// To compute the minimal associated primes of a given ideal
4558// min_ass_prim_l is called, i.e., the minimal associated primes
4559// are computed via characteristic sets.
4560// In the homogeneous case, the performance of the procedure
4561// will be improved if I is already given by a minimal set of
4562// generators. Apply minbase if necessary.
4563//////////////////////////////////////////////////////////
4564
4565
4566static proc prim_dec(ideal I, int choose)
4567{
4568  ASSUME(1, hasFieldCoefficient(basering) );
4569  ASSUME(1, not isQuotientRing(basering) ) ;
4570  ASSUME(1, hasGlobalOrdering(basering) ) ;
4571
4572  if((choose<0) or (choose>3))
4573  {
4574    ERROR("ERROR: <int> must be 0 or 1 or 2 or 3");
4575  }
4576  ideal H=1; // The intersection of the primary components
4577  list U;    // the leaves of the decomposition tree, i.e.,
4578             // pairs consisting of a primary component of I
4579             // and the corresponding associated prime
4580  list W;    // the non-leaf vertices in the decomposition tree.
4581             // every entry has 6 components:
4582                // 1- the vertex itself , i.e., a standard bais of the
4583                //    given ideal I (type 1), or a standard basis of a
4584                //    pseudo-primary component arising from
4585                //    pseudo-primary decomposition (type 2), or a
4586                //    standard basis of a remaining component arising from
4587                //    pseudo-primary decomposition or extraction (type 3)
4588                // 2- the type of the vertex as indicated above
4589                // 3- the weighted_tree_depth of the vertex
4590                // 4- the tester of the vertex
4591                // 5- a standard basis of the associated prime
4592                //    of a vertex of type 2, or 0 otherwise
4593                // 6- a list of pairs consisting of a standard
4594                //    basis of a minimal associated prime ideal
4595                //    of the father of the vertex and the
4596                //    irreducible factors of the "minimal
4597                //    divisor" of the seperator or extractor
4598                //    corresponding to the prime ideal
4599                //    as computed by the procedure minsat,
4600                //    if the vertex is of type 3, or
4601                //    the empty list otherwise
4602  ideal SI=std(I);
4603  if(SI[1]==1)  // primdecSY(ideal(1))
4604  {
4605    return(list());
4606  }
4607  intvec save=option(get);
4608  option(notWarnSB);
4609  int ncolsSI=ncols(SI);
4610  int ncolsH=1;
4611  W[1]=list(I,1,0,poly(1),ideal(0),list()); // The root of the tree
4612  int weighted_tree_depth;
4613  int i,j;
4614  int check;
4615  list V;  // current vertex
4616  list VV; // new vertex
4617  list QQ;
4618  list WI;
4619  ideal Qi,SQ,SRest,fac;
4620  poly tester;
4621
4622  while(1)
4623  {
4624    i=1;
4625    while(1)
4626    {
4627      while(i<=size(W)) // find vertex V of smallest weighted tree-depth
4628      {
4629        if (W[i][3]<=weighted_tree_depth) break;
4630        i++;
4631      }
4632      if (i<=size(W)) break;
4633      i=1;
4634      weighted_tree_depth++;
4635    }
4636    V=W[i];
4637    W=delete(W,i); // delete V from W
4638
4639    // now proceed by type of vertex V
4640
4641    if (V[2]==2)  // extraction needed
4642    {
4643      SQ,SRest,fac=extraction(V[1],V[5]);
4644                        // standard basis of primary component,
4645                        // standard basis of remaining component,
4646                        // irreducible factors of
4647                        // the "minimal divisor" of the extractor
4648                        // as computed by the procedure minsat,
4649      check=0;
4650      for(j=1;j<=ncolsH;j++)
4651      {
4652        if (NF(H[j],SQ,1)!=0) // Q is not redundant
4653        {
4654          check=1;
4655          break;
4656        }
4657      }
4658      if(check==1)             // Q is not redundant
4659      {
4660        QQ=list();
4661        QQ[1]=list(SQ,V[5]);  // primary component, associated prime,
4662                              // i.e., standard bases thereof
4663        U=U+QQ;
4664        H=intersect(H,SQ);
4665        H=std(H);
4666        ncolsH=ncols(H);
4667        check=0;
4668        if(ncolsH==ncolsSI)
4669        {
4670          for(j=1;j<=ncolsSI;j++)
4671          {
4672            if(leadexp(H[j])!=leadexp(SI[j]))
4673            {
4674              check=1;
4675              break;
4676            }
4677          }
4678        }
4679        else
4680        {
4681          check=1;
4682        }
4683        if(check==0) // H==I => U is a primary decomposition
4684        {
4685          option(set,save);
4686          return(U);
4687        }
4688      }
4689      if (SRest[1]!=1)        // the remaining component is not
4690                              // the whole ring
4691      {
4692        if (rad_con(V[4],SRest)==0) // the new vertex is not the
4693                                    // root of a redundant subtree
4694        {
4695          VV[1]=SRest;     // remaining component
4696          VV[2]=3;         // pseudoprimdec_special
4697          VV[3]=V[3]+1;    // weighted depth
4698          VV[4]=V[4];      // the tester did not change
4699          VV[5]=ideal(0);
4700          VV[6]=list(list(V[5],fac));
4701          W=insert(W,VV,size(W));
4702        }
4703      }
4704    }
4705    else
4706    {
4707      if (V[2]==3) // pseudo_prim_dec_special is needed
4708      {
4709        QQ,SRest=pseudo_prim_dec_special_charsets(V[1],V[6],choose);
4710                         // QQ = quadruples:
4711                         // standard basis of pseudo-primary component,
4712                         // standard basis of corresponding prime,
4713                         // seperator, irreducible factors of
4714                         // the "minimal divisor" of the seperator
4715                         // as computed by the procedure minsat,
4716                         // SRest=standard basis of remaining component
4717      }
4718      else     // V is the root, pseudo_prim_dec is needed
4719      {
4720        QQ,SRest=pseudo_prim_dec_charsets(I,SI,choose);
4721                         // QQ = quadruples:
4722                         // standard basis of pseudo-primary component,
4723                         // standard basis of corresponding prime,
4724                         // seperator, irreducible factors of
4725                         // the "minimal divisor" of the seperator
4726                         // as computed by the procedure minsat,
4727                         // SRest=standard basis of remaining component
4728      }
4729      //check
4730      for(i=size(QQ);i>=1;i--)
4731      //for(i=1;i<=size(QQ);i++)
4732      {
4733        tester=QQ[i][3]*V[4];
4734        Qi=QQ[i][2];
4735        if(NF(tester,Qi,1)!=0)  // the new vertex is not the
4736                                // root of a redundant subtree
4737        {
4738          VV[1]=QQ[i][1];
4739          VV[2]=2;
4740          VV[3]=V[3]+1;
4741          VV[4]=tester;      // the new tester as computed above
4742          VV[5]=Qi;          // QQ[i][2];
4743          VV[6]=list();
4744          W=insert(W,VV,size(W));
4745        }
4746      }
4747      if (SRest[1]!=1)        // the remaining component is not
4748                              // the whole ring
4749      {
4750        if (rad_con(V[4],SRest)==0) // the vertex is not the root
4751                                    // of a redundant subtree
4752        {
4753          VV[1]=SRest;
4754          VV[2]=3;
4755          VV[3]=V[3]+2;
4756          VV[4]=V[4];      // the tester did not change
4757          VV[5]=ideal(0);
4758          WI=list();
4759          for(i=1;i<=size(QQ);i++)
4760          {
4761            WI=insert(WI,list(QQ[i][2],QQ[i][4]));
4762          }
4763          VV[6]=WI;
4764          W=insert(W,VV,size(W));
4765        }
4766      }
4767    }
4768  }
4769  option(set,save);
4770}
4771
4772//////////////////////////////////////////////////////////////////////////
4773// proc pseudo_prim_dec_charsets
4774// input: Generators of an arbitrary ideal I, a standard basis SI of I,
4775// and an integer choo
4776// If choo=0, min_ass_prim_charsets with the given
4777// ordering of the variables is used.
4778// If choo=1, min_ass_prim_charsets with the "optimized"
4779// ordering of the variables is used.
4780// If choo=2, minAssPrimes from primdec.lib is used
4781// If choo=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4782// output: a pseudo primary decomposition of I, i.e., a list
4783// of pseudo primary components together with a standard basis of the
4784// remaining component. Each pseudo primary component is
4785// represented by a quadrupel: A standard basis of the component,
4786// a standard basis of the corresponding associated prime, the
4787// seperator of the component, and the irreducible factors of the
4788// "minimal divisor" of the seperator as computed by the procedure minsat,
4789// calls  proc pseudo_prim_dec_i
4790//////////////////////////////////////////////////////////////////////////
4791
4792
4793static proc pseudo_prim_dec_charsets (ideal I, ideal SI, int choo)
4794{
4795  ASSUME(1, hasFieldCoefficient(basering) );
4796  ASSUME(1, not isQuotientRing(basering) ) ;
4797  ASSUME(1, hasGlobalOrdering(basering) ) ;
4798
4799  list L;          // The list of minimal associated primes,
4800                   // each one given by a standard basis
4801  if((choo==0) or (choo==1))
4802  {
4803    L=min_ass_prim_charsets(I,choo);
4804  }
4805  else
4806  {
4807    if(choo==2)
4808    {
4809      L=minAssPrimes(I);
4810    }
4811    else
4812    {
4813      L=minAssPrimes(I,1);
4814    }
4815    for(int i=size(L);i>=1;i--)
4816    {
4817      L[i]=std(L[i]);
4818    }
4819  }
4820  return (pseudo_prim_dec_i(SI,L));
4821}
4822
4823////////////////////////////////////////////////////////////////
4824// proc pseudo_prim_dec_special_charsets
4825// input: a standard basis of an ideal I whose radical is the
4826// intersection of the radicals of ideals generated by one prime ideal
4827// P_i together with one polynomial f_i, the list V6 must be the list of
4828// pairs (standard basis of P_i, irreducible factors of f_i),
4829// and an integer choo
4830// If choo=0, min_ass_prim_charsets with the given
4831// ordering of the variables is used.
4832// If choo=1, min_ass_prim_charsets with the "optimized"
4833// ordering of the variables is used.
4834// If choo=2, minAssPrimes from primdec.lib is used
4835// If choo=3, minAssPrimes+factorizing Buchberger from primdec.lib is used
4836// output: a pseudo primary decomposition of I, i.e., a list
4837// of pseudo primary components together with a standard basis of the
4838// remaining component. Each pseudo primary component is
4839// represented by a quadrupel: A standard basis of the component,
4840// a standard basis of the corresponding associated prime, the
4841// seperator of the component, and the irreducible factors of the
4842// "minimal divisor" of the seperator as computed by the procedure minsat,
4843// calls  proc pseudo_prim_dec_i
4844////////////////////////////////////////////////////////////////
4845
4846
4847static proc pseudo_prim_dec_special_charsets (ideal SI,list V6, int choo)
4848{
4849  ASSUME(1, hasFieldCoefficient(basering) );
4850  ASSUME(1, not isQuotientRing(basering) ) ;
4851  ASSUME(1, hasGlobalOrdering(basering) ) ;
4852
4853  int i,j,l;
4854  list m;
4855  list L;
4856  int sizeL;
4857  ideal P,SP; ideal fac;
4858  int dimSP;
4859  for(l=size(V6);l>=1;l--)   // creates a list of associated primes
4860                             // of I, possibly redundant
4861  {
4862    P=V6[l][1];
4863    fac=V6[l][2];
4864    for(i=ncols(fac);i>=1;i--)
4865    {
4866      SP=P+fac[i];
4867      SP=std(SP);
4868      if(SP[1]!=1)
4869      {
4870        if((choo==0) or (choo==1))
4871        {
4872          m=min_ass_prim_charsets(SP,choo);  // a list of SB
4873        }
4874        else
4875        {
4876          if(choo==2)
4877          {
4878            m=minAssPrimes(SP);
4879          }
4880          else
4881          {
4882            m=minAssPrimes(SP,1);
4883          }
4884          for(j=size(m);j>=1;j--)
4885            {
4886              m[j]=std(m[j]);
4887            }
4888        }
4889        dimSP=dim(SP);
4890        for(j=size(m);j>=1; j--)
4891        {
4892          if(dim(m[j])==dimSP)
4893          {
4894            L=insert(L,m[j],size(L));
4895          }
4896        }
4897      }
4898    }
4899  }
4900  sizeL=size(L);
4901  for(i=1;i<sizeL;i++)     // get rid of redundant primes
4902  {
4903    for(j=i+1;j<=sizeL;j++)
4904    {
4905      if(size(L[i])!=0)
4906      {
4907        if(size(L[j])!=0)
4908        {
4909          if(size(NF(L[i],L[j],1))==0)
4910          {
4911            L[j]=ideal(0);
4912          }
4913          else
4914          {
4915            if(size(NF(L[j],L[i],1))==0)
4916            {
4917              L[i]=ideal(0);
4918            }
4919          }
4920        }
4921      }
4922    }
4923  }
4924  for(i=sizeL;i>=1;i--)
4925  {
4926    if(size(L[i])==0)
4927    {
4928      L=delete(L,i);
4929    }
4930  }
4931  return (pseudo_prim_dec_i(SI,L));
4932}
4933
4934
4935////////////////////////////////////////////////////////////////
4936// proc pseudo_prim_dec_i
4937// input: A standard basis of an arbitrary ideal I, and standard bases
4938// of the minimal associated primes of I
4939// output: a pseudo primary decomposition of I, i.e., a list
4940// of pseudo primary components together with a standard basis of the
4941// remaining component. Each pseudo primary component is
4942// represented by a quadrupel: A standard basis of the component Q_i,
4943// a standard basis of the corresponding associated prime P_i, the
4944// seperator of the component, and the irreducible factors of the
4945// "minimal divisor" of the seperator as computed by the procedure minsat,
4946////////////////////////////////////////////////////////////////
4947
4948
4949static proc pseudo_prim_dec_i (ideal SI, list L)
4950{
4951  ASSUME(1, hasFieldCoefficient(basering) );
4952  ASSUME(1, not isQuotientRing(basering) ) ;
4953  ASSUME(1, hasGlobalOrdering(basering) ) ;
4954
4955  list Q;
4956  if (size(L)==1)               // one minimal associated prime only
4957                                // the ideal is already pseudo primary
4958  {
4959    Q=SI,L[1],1;
4960    list QQ;
4961    QQ[1]=Q;
4962    return (QQ,ideal(1));
4963  }
4964
4965  poly f0,f,g;
4966  ideal fac;
4967  int i,j,k,l;
4968  ideal SQi;
4969  ideal I'=SI;
4970  list QP;
4971  int sizeL=size(L);
4972  for(i=1;i<=sizeL;i++)
4973  {
4974    fac=0;
4975    for(j=1;j<=sizeL;j++)           // compute the seperator sep_i
4976                                    // of the i-th component
4977    {
4978      if (i!=j)                       // search g not in L[i], but L[j]
4979      {
4980        for(k=1;k<=ncols(L[j]);k++)
4981        {
4982          if(NF(L[j][k],L[i],1)!=0)
4983          {
4984            break;
4985          }
4986        }
4987        fac=fac+L[j][k];
4988      }
4989    }
4990    // delete superfluous polynomials
4991    fac=simplify(fac,8+2);
4992    // saturation
4993    SQi,f0,f,fac=minsat_ppd(SI,fac);
4994    I'=I',f;
4995    QP=SQi,L[i],f0,fac;
4996             // the quadrupel:
4997             // a standard basis of Q_i,
4998             // a standard basis of P_i,
4999             // sep_i,
5000             // irreducible factors of
5001             // the "minimal divisor" of the seperator
5002             //  as computed by the procedure minsat,
5003    Q[i]=QP;
5004  }
5005  I'=std(I');
5006  return (Q, I');
5007                   // I' = remaining component
5008}
5009
5010
5011////////////////////////////////////////////////////////////////
5012// proc extraction
5013// input: A standard basis of a pseudo primary ideal I, and a standard
5014// basis of the unique minimal associated prime P of I
5015// output: an extraction of I, i.e., a standard basis of the primary
5016// component Q of I with associated prime P, a standard basis of the
5017// remaining component, and the irreducible factors of the
5018// "minimal divisor" of the extractor as computed by the procedure minsat
5019////////////////////////////////////////////////////////////////
5020
5021
5022static proc extraction (ideal SI, ideal SP)
5023{
5024  ASSUME(1, hasFieldCoefficient(basering) );
5025  ASSUME(1, not isQuotientRing(basering) ) ;
5026  ASSUME(1, hasGlobalOrdering(basering) ) ;
5027
5028  list indsets=indepSet(SP,0);
5029  poly f;
5030  if(size(indsets)!=0)      //check, whether dim P != 0
5031  {
5032    intvec v;               // a maximal independent set of variables
5033                            // modulo P
5034    string U;               // the independent variables
5035    string A;               // the dependent variables
5036    int j,k;
5037    int a;                  //  the size of A
5038    int degf;
5039    ideal g;
5040    list polys;
5041    int sizepolys;
5042    list newpoly;
5043    def R=basering;
5044    //intvec hv=hilb(SI,1);
5045    for (k=1;k<=size(indsets);k++)
5046    {
5047      v=indsets[k];
5048      for (j=1;j<=nvars(R);j++)
5049      {
5050        if (v[j]==1)
5051        {
5052          U=U+varstr(j)+",";
5053        }
5054        else
5055        {
5056          A=A+varstr(j)+",";
5057          a++;
5058        }
5059      }
5060
5061      U[size(U)]=")";           // we compute the extractor of I (w.r.t. U)
5062      execute("ring RAU=("+charstr(basering)+"),("+A+U+",(dp("+string(a)+"),dp);");
5063      ideal I=imap(R,SI);
5064      //I=std(I,hv);            // the standard basis in (R[U])[A]
5065      I=std(I);            // the standard basis in (R[U])[A]
5066      A[size(A)]=")";
5067      execute("ring Rloc=("+charstr(basering)+","+U+",("+A+",dp;");
5068      ideal I=imap(RAU,I);
5069      //"std in lokalisierung:"+newline,I;
5070      ideal h;
5071      for(j=ncols(I);j>=1;j--)
5072      {
5073        h[j]=leadcoef(I[j]);  // consider I in (R(U))[A]
5074      }
5075      setring R;
5076      g=imap(Rloc,h);
5077      kill RAU,Rloc;
5078      U="";
5079      A="";
5080      a=0;
5081      f=lcm(g);
5082      newpoly[1]=f;
5083      polys=polys+newpoly;
5084      newpoly=list();
5085    }
5086    f=polys[1];
5087    degf=deg(f);
5088    sizepolys=size(polys);
5089    for (k=2;k<=sizepolys;k++)
5090    {
5091      if (deg(polys[k])<degf)
5092      {
5093        f=polys[k];
5094        degf=deg(f);
5095      }
5096    }
5097  }
5098  else
5099  {
5100    f=1;
5101  }
5102  poly f0,h0; ideal SQ; ideal fac;
5103  if(f!=1)
5104  {
5105    SQ,f0,h0,fac=minsat(SI,f);
5106    return(SQ,std(SI+h0),fac);
5107             // the tripel
5108             // a standard basis of Q,
5109             // a standard basis of remaining component,
5110             // irreducible factors of
5111             // the "minimal divisor" of the extractor
5112             // as computed by the procedure minsat
5113  }
5114  else
5115  {
5116    return(SI,ideal(1),ideal(1));
5117  }
5118}
5119
5120/////////////////////////////////////////////////////
5121// proc minsat
5122// input:  a standard basis of an ideal I and a polynomial p
5123// output: a standard basis IS of the saturation of I w.r. to p,
5124// the maximal squarefree factor f0 of p,
5125// the "minimal divisor" f of f0 such that the saturation of
5126// I w.r. to f equals the saturation of I w.r. to f0 (which is IS),
5127// the irreducible factors of f
5128//////////////////////////////////////////////////////////
5129
5130
5131static proc minsat(ideal SI, poly p)
5132{
5133  ASSUME(1, hasFieldCoefficient(basering) );
5134  ASSUME(1, not isQuotientRing(basering) ) ;
5135  ASSUME(1, hasGlobalOrdering(basering) ) ;
5136
5137  ideal fac=factorize(p,1);       //the irreducible factors of p
5138  fac=sort(fac)[1];
5139  int i,k;
5140  poly f0=1;
5141  for(i=ncols(fac);i>=1;i--)
5142  {
5143    f0=f0*fac[i];
5144  }
5145  poly f=1;
5146  ideal iold;
5147  list quotM;
5148  quotM[1]=SI;
5149  quotM[2]=fac;
5150  quotM[3]=f0;
5151  // we deal seperately with the first quotient;
5152  // factors, which do not contribute to this one,
5153  // are omitted
5154  iold=quotM[1];
5155  quotM=minquot(quotM);
5156  fac=quotM[2];
5157  if(quotM[3]==1)
5158    {
5159      return(quotM[1],f0,f,fac);
5160    }
5161  while(special_ideals_equal(iold,quotM[1])==0)
5162    {
5163      f=f*quotM[3];
5164      iold=quotM[1];
5165      quotM=minquot(quotM);
5166    }
5167  return(quotM[1],f0,f,fac);           // the quadrupel ((I:p),f0,f, irr. factors of f)
5168}
5169
5170/////////////////////////////////////////////////////
5171// proc minsat_ppd
5172// input:  a standard basis of an ideal I and a polynomial p
5173// output: a standard basis IS of the saturation of I w.r. to p,
5174// the maximal squarefree factor f0 of p,
5175// the "minimal divisor" f of f0 such that the saturation of
5176// I w.r. to f equals the saturation of I w.r. to f0 (which is IS),
5177// the irreducible factors of f
5178//////////////////////////////////////////////////////////
5179
5180
5181static proc minsat_ppd(ideal SI, ideal fac)
5182{
5183  ASSUME(1, hasFieldCoefficient(basering) );
5184  ASSUME(1, not isQuotientRing(basering) ) ;
5185  ASSUME(1, hasGlobalOrdering(basering) ) ;
5186
5187  fac=sort(fac)[1];
5188  int i,k;
5189  poly f0=1;
5190  for(i=ncols(fac);i>=1;i--)
5191  {
5192    f0=f0*fac[i];
5193  }
5194  poly f=1;
5195  ideal iold;
5196  list quotM;
5197  quotM[1]=SI;
5198  quotM[2]=fac;
5199  quotM[3]=f0;
5200  // we deal seperately with the first quotient;
5201  // factors, which do not contribute to this one,
5202  // are omitted
5203  iold=quotM[1];
5204  quotM=minquot(quotM);
5205  fac=quotM[2];
5206  if(quotM[3]==1)
5207    {
5208      return(quotM[1],f0,f,fac);
5209    }
5210  while(special_ideals_equal(iold,quotM[1])==0)
5211  {
5212    f=f*quotM[3];
5213    iold=quotM[1];
5214    quotM=minquot(quotM);
5215    k++;
5216  }
5217  return(quotM[1],f0,f,fac);           // the quadrupel ((I:p),f0,f, irr. factors of f)
5218}
5219/////////////////////////////////////////////////////////////////
5220// proc minquot
5221// input: a list with 3 components: a standard basis
5222// of an ideal I, a set of irreducible polynomials, and
5223// there product f0
5224// output: a standard basis of the ideal (I:f0), the irreducible
5225// factors of the "minimal divisor" f of f0 with (I:f0) = (I:f),
5226// the "minimal divisor" f
5227/////////////////////////////////////////////////////////////////
5228
5229static proc minquot(list tsil)
5230{
5231   ASSUME(1, hasFieldCoefficient(basering) );
5232   ASSUME(1, not isQuotientRing(basering) ) ;
5233   ASSUME(1, hasGlobalOrdering(basering) ) ;
5234
5235   intvec op;
5236   int i,j,k,action;
5237   ideal verg;
5238   list l;
5239   poly g;
5240   ideal laedi=tsil[1];
5241   ideal fac=tsil[2];
5242   poly f=tsil[3];
5243
5244//std
5245//   ideal star=quotient(laedi,f);
5246//   star=std(star);
5247   op=option(get);
5248   option(returnSB);
5249   ideal star=quotient(laedi,f);
5250   option(set,op);
5251   if(special_ideals_equal(laedi,star)==1)
5252     {
5253       return(laedi,ideal(1),1);
5254     }
5255   action=1;
5256   while(action==1)
5257   {
5258      if(size(fac)==1)
5259      {
5260         action=0;
5261         break;
5262      }
5263      for(i=1;i<=size(fac);i++)
5264      {
5265        g=1;
5266         for(j=1;j<=size(fac);j++)
5267         {
5268            if(i!=j)
5269            {
5270               g=g*fac[j];
5271            }
5272         }
5273//std
5274//         verg=quotient(laedi,g);
5275//         verg=std(verg);
5276         op=option(get);
5277         option(returnSB);
5278         verg=quotient(laedi,g);
5279         option(set,op);
5280         if(special_ideals_equal(verg,star)==1)
5281         {
5282            f=g;
5283            fac[i]=0;
5284            fac=simplify(fac,2);
5285            break;
5286         }
5287         if(i==size(fac))
5288         {
5289            action=0;
5290         }
5291      }
5292   }
5293   l=star,fac,f;
5294   return(l);
5295}
5296/////////////////////////////////////////////////
5297// proc special_ideals_equal
5298// input: standard bases of ideal k1 and k2 such that
5299// k1 is contained in k2, or k2 is contained ink1
5300// output: 1, if k1 equals k2, 0 otherwise
5301//////////////////////////////////////////////////
5302
5303static proc special_ideals_equal( ideal k1, ideal k2)
5304{
5305   int j;
5306   if(size(k1)==size(k2))
5307   {
5308      for(j=1;j<=size(k1);j++)
5309      {
5310         if(leadexp(k1[j])!=leadexp(k2[j]))
5311         {
5312            return(0);
5313         }
5314      }
5315      return(1);
5316   }
5317   return(0);
5318}
5319
5320
5321///////////////////////////////////////////////////////////////////////////////
5322
5323static proc convList(list l)
5324{
5325   int i;
5326   list re,he;
5327   for(i=1;i<=size(l) div 2;i++)
5328   {
5329      he=l[2*i-1],l[2*i];
5330      re[i]=he;
5331   }
5332   return(re);
5333}
5334///////////////////////////////////////////////////////////////////////////////
5335
5336static proc reconvList(list l)
5337{
5338   int i;
5339   list re;
5340   for(i=size(l);i>0;i--)
5341   {
5342      re[2*i-1]=l[i][1];
5343      re[2*i]=l[i][2];
5344   }
5345   return(re);
5346}
5347
5348///////////////////////////////////////////////////////////////////////////////
5349//
5350//     The main procedures
5351//
5352///////////////////////////////////////////////////////////////////////////////
5353
5354proc primdecGTZ(ideal i, list #)
5355"USAGE:   primdecGTZ(i); i ideal
5356RETURN:  a list pr of primary ideals and their associated primes:
5357@format
5358   pr[i][1]   the i-th primary component,
5359   pr[i][2]   the i-th prime component.
5360@end format
5361NOTE:    - Algorithm of Gianni/Trager/Zacharias.
5362         - Designed for characteristic 0, works also in char k > 0, if it
5363           terminates (may result in an infinite loop in small characteristic!)
5364         - For local orderings, the result is considered in the localization
5365           of the polynomial ring, not in the power series ring
5366         - For local and mixed orderings, the decomposition in the
5367           corresponding global ring is returned if the string 'global'
5368           is specified as second argument
5369EXAMPLE: example primdecGTZ; shows an example
5370"
5371{
5372   ASSUME(0, hasFieldCoefficient(basering) );
5373   ASSUME(0, not isQuotientRing(basering) ) ;
5374   if(size(#)>0)
5375   {
5376      int keep_comp=1;
5377   }
5378   if(attrib(basering,"global")!=1)
5379   {
5380// algorithms only work in global case!
5381// pass to appropriate global ring
5382      def r=basering;
5383      def s=changeord(list(list("dp",1:nvars(basering))));
5384      setring s;
5385      ideal i=imap(r,i);
5386// decompose and go back
5387      list li=primdecGTZ(i);
5388      setring r;
5389      def li=imap(s,li);
5390// clean up
5391      if(!defined(keep_comp))
5392      {
5393         for(int k=size(li);k>=1;k--)
5394         {
5395            if(mindeg(std(lead(li[k][2]))[1])==0)
5396            {
5397// 1 contained in ideal, i.e. component does not meet origin in local ordering
5398               li=delete(li,k);
5399            }
5400         }
5401      }
5402      return(li);
5403   }
5404
5405   if(minpoly!=0)
5406   {
5407      return(algeDeco(i,0));
5408      ERROR(
5409      "// Not implemented yet for algebraic extensions.Simulate the ring extension by adding the minpoly to the ideal"
5410      );
5411   }
5412  return(convList(decomp(i)));
5413}
5414example
5415{ "EXAMPLE:";  echo = 2;
5416   ring  r = 0,(x,y,z),lp;
5417   poly  p = z2+1;
5418   poly  q = z3+2;
5419   ideal i = p*q^2,y-z2;
5420   list pr = primdecGTZ(i);
5421   pr;
5422}
5423///////////////////////////////////////////////////////////////////////////////
5424proc absPrimdecGTZ(ideal I, list #)
5425"USAGE:   absPrimdecGTZ(I); I ideal
5426ASSUME:  Ground field has characteristic 0.
5427RETURN:  a ring containing two lists: @code{absolute_primes}, the absolute
5428         prime components of I, and @code{primary_decomp}, the output of
5429         @code{primdecGTZ(I)}.
5430         The list absolute_primes has to be interpreted as follows:
5431         each entry describes a class of conjugated absolute primes,
5432@format
5433   absolute_primes[i][1]   the absolute prime component,
5434   absolute_primes[i][2]   the number of conjugates.
5435@end format
5436         The first entry of @code{absolute_primes[i][1]} is the minimal
5437         polynomial of a minimal finite field extension over which the
5438         absolute prime component is defined.
5439         For local orderings, the result is considered in the localization
5440         of the polynomial ring, not in the power series ring.
5441         For local and mixed orderings, the decomposition in the
5442         corresponding global ring is returned if the string 'global'
5443         is specified as second argument
5444NOTE:    Algorithm of Gianni/Trager/Zacharias combined with the
5445         @code{absFactorize} command.
5446SEE ALSO: primdecGTZ; absFactorize
5447EXAMPLE: example absPrimdecGTZ; shows an example
5448"
5449{
5450  ASSUME(0, hasFieldCoefficient(basering) );
5451  ASSUME(0, not isQuotientRing(basering) ) ;
5452  if (char(basering) != 0)
5453  {
5454    ERROR("primdec.lib::absPrimdecGTZ is only implemented for "+
5455           +"characteristic 0");
5456  }
5457
5458  if(size(#)>0)
5459  {
5460     int keep_comp=1;
5461  }
5462
5463  if(attrib(basering,"global")!=1)
5464  {
5465// algorithm automatically passes to the global case
5466// hence prepare to go back to an appropriate new ring
5467      def r=basering;
5468      ideal max_of_r=maxideal(1);
5469      def s=changeord(list(list("dp",1:nvars(basering))));
5470      setring s;
5471      def I=imap(r,I);
5472      def S=absPrimdecGTZ(I);
5473      setring S;
5474      ring r1=char(basering),var(nvars(r)+1),dp;
5475      def rS=r+r1;
5476// move objects to appropriate ring and clean up
5477      setring rS;
5478      def max_of_r=imap(r,max_of_r);
5479      attrib(max_of_r,"isSB",1);
5480      def absolute_primes=imap(S,absolute_primes);
5481      def primary_decomp=imap(S,primary_decomp);
5482      if(!defined(keep_comp))
5483      {
5484         ideal tempid;
5485         for(int k=size(absolute_primes);k>=1;k--)
5486         {
5487            tempid=absolute_primes[k][1];
5488            tempid[1]=0;                  // ignore minimal polynomial
5489            if(size(reduce(lead(tempid),max_of_r))!=0)
5490            {
5491// 1 contained in ideal, i.e. component does not meet origin in local ordering
5492               absolute_primes=delete(absolute_primes,k);
5493            }
5494         }
5495         for(k=size(primary_decomp);k>=1;k--)
5496         {
5497            if(mindeg(std(lead(primary_decomp[k][2]))[1])==0)
5498            {
5499// 1 contained in ideal, i.e. component does not meet origin in local ordering
5500               primary_decomp=delete(primary_decomp,k);
5501            }
5502         }
5503         kill tempid;
5504      }
5505      export(primary_decomp);
5506      export(absolute_primes);
5507      return(rS);
5508  }
5509  if(minpoly!=0)
5510  {
5511    //return(algeDeco(i,0));
5512    ERROR(
5513      "// Not implemented yet for algebraic extensions.Simulate the ring extension by adding the minpoly to the ideal"
5514    );
5515  }
5516  def R=basering;
5517  int n=nvars(R);
5518  list L=decomp(I,3);
5519  string newvar=L[1][3];
5520  int k=find(newvar,",",find(newvar,",")+1);
5521  newvar=newvar[k+1..size(newvar)];
5522  list lR=ringlist(R);
5523  int i,de,ii;
5524  intvec vv=1:n;
5525  //for(i=1;i<=n;i++){vv[i]=1;}
5526
5527  list orst;
5528  orst[1]=list("dp",vv);
5529  orst[2]=list("dp",intvec(1));
5530  orst[3]=list("C",0);
5531  lR[3]=orst;
5532  lR[2][n+1] = newvar;
5533  def Rz = ring(lR);
5534  setring Rz;
5535  list L=imap(R,L);
5536  list absolute_primes,primary_decomp;
5537  ideal I,M,N,K;
5538  M=maxideal(1);
5539  N=maxideal(1);
5540  poly p,q,f,g;
5541  map phi,psi;
5542  string tvar;
5543  for(i=1;i<=size(L);i++)
5544  {
5545    tvar=L[i][4];
5546    ii=find(tvar,"+");
5547    while(ii)
5548    {
5549      tvar=tvar[ii+1..size(tvar)];
5550      ii=find(tvar,"+");
5551    }
5552    for(ii=1;ii<=nvars(basering);ii++)
5553    {
5554      if(tvar==string(var(ii))) break;
5555    }
5556    I=L[i][2];
5557    execute("K="+L[i][3]+";");
5558    p=K[1];
5559    q=K[2];
5560    execute("f="+L[i][4]+";");
5561    g=2*var(ii)-f;
5562    M[ii]=f;
5563    N[ii]=g;
5564    de=deg(p);
5565    psi=Rz,M;
5566    phi=Rz,N;
5567    I=phi(I),p,q;
5568    I=std(I);
5569    absolute_primes[i]=list(psi(I),de);
5570    primary_decomp[i]=list(L[i][1],L[i][2]);
5571  }
5572  export(primary_decomp);
5573  export(absolute_primes);
5574  setring R;
5575  dbprint( printlevel-voice+3,"
5576// 'absPrimdecGTZ' created a ring, in which two lists absolute_primes (the
5577// absolute prime components) and primary_decomp (the primary and prime
5578// components over the current basering) are stored.
5579// To access the list of absolute prime components, type (if the name S was
5580// assigned to the return value):
5581        setring S; absolute_primes; ");
5582
5583  return(Rz);
5584}
5585example
5586{ "EXAMPLE:";  echo = 2;
5587   ring  r = 0,(x,y,z),lp;
5588   poly  p = z2+1;
5589   poly  q = z3+2;
5590   ideal i = p*q^2,y-z2;
5591   def S = absPrimdecGTZ(i);
5592   setring S;
5593   absolute_primes;
5594}
5595
5596///////////////////////////////////////////////////////////////////////////////
5597
5598proc primdecSY(ideal i, list #)
5599"USAGE:   primdecSY(I, c); I ideal, c int (optional)
5600RETURN:  a list pr of primary ideals and their associated primes:
5601@format
5602   pr[i][1]   the i-th primary component,
5603   pr[i][2]   the i-th prime component.
5604@end format
5605NOTE:    Algorithm of Shimoyama/Yokoyama.
5606@format
5607   if c=0,  the given ordering of the variables is used,
5608   if c=1,  minAssChar tries to use an optimal ordering (default),
5609   if c=2,  minAssGTZ is used,
5610   if c=3,  minAssGTZ and facstd are used.
5611@end format
5612         For local orderings, the result is considered in the localization
5613         of the polynomial ring, not in the power series ring.
5614         For local and mixed orderings, the decomposition in the
5615         corresponding global ring is returned if the string 'global'
5616         is specified as third argument
5617EXAMPLE: example primdecSY; shows an example
5618"
5619{
5620   ASSUME(0, hasFieldCoefficient(basering) );
5621   ASSUME(0, not isQuotientRing(basering) ) ;
5622   if(size(#)>1)
5623   {
5624      int keep_comp=1;
5625   }
5626   if(attrib(basering,"global")!=1)
5627   {
5628// algorithms only work in global case!
5629// pass to appropriate global ring
5630      def r=basering;
5631      def s=changeord(list(list("dp",1:nvars(basering))));
5632      setring s;
5633      ideal i=imap(r,i);
5634// decompose and go back
5635      list li=primdecSY(i);
5636      setring r;
5637      def li=imap(s,li);
5638// clean up
5639      if(!defined(keep_comp))
5640      {
5641         for(int k=size(li);k>=1;k--)
5642         {
5643            if(mindeg(std(lead(li[k][2]))[1])==0)
5644            {
5645// 1 contained in ideal, i.e. component does not meet origin in local ordering
5646               li=delete(li,k);
5647            }
5648         }
5649      }
5650      return(li);
5651   }
5652   i=simplify(i,2);
5653   if ((i[1]==0)||(i[1]==1))
5654   {
5655     list L=list(ideal(i[1]),ideal(i[1]));
5656     return(list(L));
5657   }
5658
5659   if(minpoly!=0)
5660   {
5661      return(algeDeco(i,1));
5662   }
5663   if (size(#)!=0)
5664   { return(prim_dec(i,#[1])); }
5665   else
5666   { return(prim_dec(i,1)); }
5667}
5668example
5669{ "EXAMPLE:";  echo = 2;
5670   ring  r = 0,(x,y,z),lp;
5671   poly  p = z2+1;
5672   poly  q = z3+2;
5673   ideal i = p*q^2,y-z2;
5674   list pr = primdecSY(i);
5675   pr;
5676}
5677///////////////////////////////////////////////////////////////////////////////
5678proc minAssGTZ(ideal i,list #)
5679"USAGE:    minAssGTZ(I[, l]); I ideal, l list (optional)
5680   @* Optional parameters in list l (can be entered in any order):
5681   @* 0, \"facstd\" -> uses facstd to first decompose the ideal (default)
5682   @* 1, \"noFacstd\" -> does not use facstd
5683   @* \"GTZ\" -> the original algorithm by Gianni, Trager and Zacharias is used
5684   @* \"SL\" -> GTZ algorithm with modificiations by Laplagne is used (default)
5685
5686RETURN:  a list, the minimal associated prime ideals of I.
5687NOTE:    - Designed for characteristic 0, works also in char k > 0 based
5688           on an algorithm of Yokoyama
5689         - For local orderings, the result is considered in the localization
5690           of the polynomial ring, not in the power series ring
5691         - For local and mixed orderings, the decomposition in the
5692           corresponding global ring is returned if the string 'global'
5693           is specified as second argument
5694EXAMPLE: example minAssGTZ; shows an example
5695"
5696{
5697   ASSUME(0, hasFieldCoefficient(basering) );
5698   ASSUME(0, not isQuotientRing(basering) ) ;
5699   if(size(#)>0)
5700   {
5701      int keep_comp=1;
5702   }
5703
5704  if(attrib(basering,"global")!=1)
5705  {
5706  // algorithms only work in global case!
5707// pass to appropriate global ring
5708      def r=basering;
5709      def s=changeord(list(list("dp",1:nvars(basering))));
5710      setring s;
5711      ideal i=imap(r,i);
5712// decompose and go back
5713      list li=minAssGTZ(i);
5714      setring r;
5715      def li=imap(s,li);
5716// clean up
5717      if(!defined(keep_comp))
5718      {
5719         for(int k=size(li);k>=1;k--)
5720         {
5721            if(mindeg(std(lead(li[k]))[1])==0)
5722            {
5723// 1 contained in ideal, i.e. component does not meet origin in local ordering
5724               li=delete(li,k);
5725            }
5726         }
5727      }
5728      return(li);
5729  }
5730
5731  int j;
5732  string algorithm;
5733  string facstdOption;
5734  int useFac;
5735
5736  // Set input parameters
5737  algorithm = "SL";         // Default: SL algorithm
5738  facstdOption = "facstd";
5739  if(size(#) > 0)
5740  {
5741    int valid;
5742    for(j = 1; j <= size(#); j++)
5743    {
5744      valid = 0;
5745      if((typeof(#[j]) == "int") or (typeof(#[j]) == "number"))
5746      {
5747        if (#[j] == 1) {facstdOption = "noFacstd"; valid = 1;}    // If #[j] == 1, facstd is not used.
5748        if (#[j] == 0) {facstdOption = "facstd";   valid = 1;}    // If #[j] == 0, facstd is used.
5749      }
5750      if(typeof(#[j]) == "string")
5751      {
5752        if((#[j] == "GTZ") || (#[j] == "SL"))
5753        {
5754          algorithm = #[j];
5755          valid = 1;
5756        }
5757        if((#[j] == "noFacstd") || (#[j] == "facstd"))
5758        {
5759          facstdOption = #[j];
5760          valid = 1;
5761        }
5762      }
5763      if(valid == 0)
5764      {
5765        dbprint(1, "Warning! The following input parameter was not recognized:", #[j]);
5766      }
5767    }
5768  }
5769
5770  if(minpoly!=0)
5771  {
5772    return(algeDeco(i,2));
5773  }
5774
5775  list result = minAssPrimes(i, facstdOption, algorithm);
5776  return(result);
5777}
5778example
5779{ "EXAMPLE:";  echo = 2;
5780   ring  r = 0,(x,y,z),dp;
5781   poly  p = z2+1;
5782   poly  q = z3+2;
5783   ideal i = p*q^2,y-z2;
5784   list pr = minAssGTZ(i);
5785   pr;
5786}
5787
5788///////////////////////////////////////////////////////////////////////////////
5789proc minAssChar(ideal i, list #)
5790"USAGE:   minAssChar(I[,c]); i ideal, c int (optional).
5791RETURN:  list, the minimal associated prime ideals of i.
5792NOTE:    If c=0, the given ordering of the variables is used. @*
5793         Otherwise, the system tries to find an optimal ordering,
5794         which in some cases may considerably speed up the algorithm. @*
5795         For local orderings, the result is considered in the localization
5796         of the polynomial ring, not in the power series ring
5797         For local and mixed orderings, the decomposition in the
5798         corresponding global ring is returned if the string 'global'
5799         is specified as third argument
5800EXAMPLE: example minAssChar; shows an example
5801"
5802{
5803   ASSUME(0, hasFieldCoefficient(basering) );
5804   ASSUME(0, not isQuotientRing(basering) ) ;
5805   if(size(#)>1)
5806   {
5807      int keep_comp=1;
5808   }
5809   if(attrib(basering,"global")!=1)
5810   {
5811// algorithms only work in global case!
5812// pass to appropriate global ring
5813      def r=basering;
5814      def s=changeord(list(list("dp",1:nvars(basering))));
5815      setring s;
5816      ideal i=imap(r,i);
5817// decompose and go back
5818      list li=minAssChar(i);
5819      setring r;
5820      def li=imap(s,li);
5821// clean up
5822      if(!defined(keep_comp))
5823      {
5824         for(int k=size(li);k>=1;k--)
5825         {
5826            if(mindeg(std(lead(li[k]))[1])==0)
5827            {
5828// 1 contained in ideal, i.e. component does not meet origin in local ordering
5829               li=delete(li,k);
5830            }
5831         }
5832      }
5833      return(li);
5834   }
5835   if (size(#)>0)
5836   { return(min_ass_prim_charsets(i,#[1])); }
5837   else
5838   { return(min_ass_prim_charsets(i,1)); }
5839}
5840example
5841{ "EXAMPLE:";  echo = 2;
5842   ring  r = 0,(x,y,z),dp;
5843   poly  p = z2+1;
5844   poly  q = z3+2;
5845   ideal i = p*q^2,y-z2;
5846   list pr = minAssChar(i);
5847   pr;
5848}
5849///////////////////////////////////////////////////////////////////////////////
5850proc equiRadical(ideal i)
5851"USAGE:   equiRadical(I); I ideal
5852RETURN:  ideal, intersection of associated primes of I of maximal dimension.
5853NOTE:    A combination of the algorithms of Krick/Logar (with modifications by Laplagne) and Kemper is used.
5854         Works also in positive characteristic (Kempers algorithm).
5855EXAMPLE: example equiRadical; shows an example
5856"
5857{
5858  ASSUME(0, hasFieldCoefficient(basering) );
5859  ASSUME(0, not isQuotientRing(basering) ) ;
5860  if(attrib(basering,"global")!=1)
5861  {
5862     ERROR(
5863     "// Not implemented for this ordering, please change to global ordering."
5864     );
5865  }
5866
5867  return(radical(i, 1));
5868}
5869example
5870{ "EXAMPLE:";  echo = 2;
5871   ring  r = 0,(x,y,z),dp;
5872   poly  p = z2+1;
5873   poly  q = z3+2;
5874   ideal i = p*q^2,y-z2;
5875   ideal pr= equiRadical(i);
5876   pr;
5877}
5878
5879///////////////////////////////////////////////////////////////////////////////
5880proc radical(ideal i, list #)
5881"USAGE: radical(I[, l]); I ideal, l list (optional)
5882 @*  Optional parameters in list l (can be entered in any order):
5883 @*  0, \"fullRad\" -> full radical is computed (default)
5884 @*  1, \"equiRad\" -> equiRadical is computed
5885 @*  \"KL\" -> Krick/Logar algorithm is used
5886 @*  \"SL\" -> modifications by Laplagne are used (default)
5887 @*  \"facstd\" -> uses facstd to first decompose the ideal (default for non homogeneous ideals)
5888 @*  \"noFacstd\" -> does not use facstd (default for homogeneous ideals)
5889RETURN:  ideal, the radical of I (or the equiradical if required in the input parameters)
5890NOTE:    A combination of the algorithms of Krick/Logar (with modifications by Laplagne) and Kemper is used.
5891         Works also in positive characteristic (Kempers algorithm).
5892EXAMPLE: example radical; shows an example
5893"
5894{
5895  ASSUME(0, hasFieldCoefficient(basering) );
5896  ASSUME(0, not isQuotientRing(basering) ) ;
5897  dbprint(printlevel - voice, "Radical, version 2006.05.08");
5898  if(size(i) == 0){return(ideal(0));}
5899  if(attrib(basering,"global")!=1)
5900  {
5901// algorithms only work in global case!
5902// pass to appropriate global ring
5903      def r=basering;
5904      def s=changeord(list(list("dp",1:nvars(basering))));
5905      setring s;
5906      ideal i=imap(r,i);
5907// compute radical and go back
5908      def j=radical(i);
5909      setring r;
5910      def j=imap(s,j);
5911      return(j);
5912  }
5913  int j;
5914  def P0 = basering;
5915  list Pl=ringlist(P0);
5916  intvec dp_w;
5917  for(j=nvars(P0);j>0;j--) {dp_w[j]=1;}
5918  Pl[3]=list(list("dp",dp_w),list("C",0));
5919  def @P=ring(Pl);
5920  setring @P;
5921  ideal i=imap(P0,i);
5922
5923  int il;
5924  string algorithm;
5925  int useFac;
5926
5927  // Set input parameters
5928  algorithm = "SL";                                 // Default: SL algorithm
5929  il = 0;                                           // Default: Full radical (not only equiRadical)
5930  if (homog(i) == 1)
5931  {   // Default: facStd is used, except if the ideal is homogeneous.
5932    useFac = 0;
5933  }
5934  else
5935  {
5936    useFac = 1;
5937  }
5938  if(size(#) > 0)
5939  {
5940    int valid;
5941    for(j = 1; j <= size(#); j++)
5942    {
5943      valid = 0;
5944      if((typeof(#[j]) == "int") or (typeof(#[j]) == "number"))
5945      {
5946        il = #[j];          // If il == 1, equiRadical is computed
5947        valid = 1;
5948      }
5949      if(typeof(#[j]) == "string")
5950      {
5951        if(#[j] == "KL")
5952        {
5953          algorithm = "KL";
5954          valid = 1;
5955        }
5956        if(#[j] == "SL")
5957        {
5958          algorithm = "SL";
5959          valid = 1;
5960        }
5961        if(#[j] == "noFacstd")
5962        {
5963          useFac = 0;
5964          valid = 1;
5965        }
5966        if(#[j] == "facstd")
5967        {
5968          useFac = 1;
5969          valid = 1;
5970        }
5971        if(#[j] == "equiRad")
5972        {
5973          il = 1;
5974          valid = 1;
5975        }
5976        if(#[j] == "fullRad")
5977        {
5978          il = 0;
5979          valid = 1;
5980        }
5981      }
5982      if(valid == 0)
5983      {
5984        dbprint(1, "Warning! The following input parameter was not recognized:", #[j]);
5985      }
5986    }
5987  }
5988
5989  ideal rad = 1;
5990  intvec op = option(get);
5991  list qr = simplifyIdeal(i);
5992  map phi = @P, qr[2];
5993
5994  option(redSB);
5995  i = groebner(qr[1]);
5996  option(set, op);
5997  int di = dim(i);
5998
5999  if(di == 0)
6000  {
6001    i = zeroRad(i, qr[1]);
6002    option(redSB);
6003    i=interred(phi(i));
6004    option(set, op);
6005    setring(P0);
6006    i=imap(@P,i);
6007    return(i);
6008  }
6009
6010  option(redSB);
6011  list pr;
6012  if(useFac == 1)
6013  {
6014    pr = facstd(i);
6015  }
6016  else
6017  {
6018    pr = i;
6019  }
6020  option(set, op);
6021  int s = size(pr);
6022  if(useFac == 1)
6023  {
6024    dbprint(printlevel - voice, "Number of components returned by facstd: ", s);
6025  }
6026  for(j = 1; j <= s; j++)
6027  {
6028    attrib(pr[s + 1 - j], "isSB", 1);
6029    if((size(reduce(rad, pr[s + 1 - j], 1)) != 0) && ((dim(pr[s + 1 - j]) == di) || !il))
6030    {
6031      // SL Debug messages
6032      dbprint(printlevel-voice, "We shall compute the radical of ", pr[s + 1 - j]);
6033      dbprint(printlevel-voice, "The dimension is: ", dim(pr[s+1-j]));
6034
6035      if(algorithm == "KL")
6036      {
6037        rad = intersect(rad, radicalKL(pr[s + 1 - j], rad, il));
6038      }
6039      if(algorithm == "SL")
6040      {
6041        rad = intersect(rad, radicalSL(pr[s + 1 - j], il));
6042      }
6043    }
6044    else
6045    {
6046      // SL Debug
6047      dbprint(printlevel-voice, "The radical of this component is not needed.");
6048      dbprint(printlevel-voice, "size(reduce(rad, pr[s + 1 - j], 1))",
6049              size(reduce(rad, pr[s + 1 - j], 1)));
6050      dbprint(printlevel-voice, "dim(pr[s + 1 - j])", dim(pr[s + 1 - j]));
6051      dbprint(printlevel-voice, "il", il);
6052    }
6053  }
6054  rad=interred(phi(rad));
6055  setring(P0);
6056  i=imap(@P,rad);
6057  return(i);
6058}
6059example
6060{ "EXAMPLE:";  echo = 2;
6061   ring  r = 0,(x,y,z),dp;
6062   poly  p = z2+1;
6063   poly  q = z3+2;
6064   ideal i = p*q^2,y-z2;
6065   ideal pr = radical(i);
6066   pr;
6067}
6068
6069///////////////////////////////////////////////////////////////////////////////
6070//
6071// Computes the radical of I using KL algorithm.
6072// The only difference with the previous implementation of KL algorithm is
6073// that now it uses block dp instead of lp ordering for the reduction to the
6074// zerodimensional case.
6075// The reduction step has been moved to the new routine radicalReduction, so that it can be
6076// used also by radicalSL procedure.
6077//
6078static proc radicalKL(ideal I, ideal ser, list #)
6079{
6080  ASSUME(1, hasFieldCoefficient(basering) );
6081  ASSUME(1, not isQuotientRing(basering) ) ;
6082  ASSUME(1, hasGlobalOrdering(basering) ) ;
6083
6084// ideal I     The ideal for which the radical is computed
6085// ideal ser   Used to reduce components already obtained
6086// list #      If #[1] = 1, equiradical is computed.
6087
6088  // I needs to be a Groebner basis.
6089  if (attrib(I, "isSB") != 1)
6090  {
6091    I = groebner(I);
6092  }
6093
6094  ideal rad;                                // The radical
6095  int allIndep = 1;                // All max independent sets are used
6096
6097  list result = radicalReduction(I, ser, allIndep, #);
6098  int done = result[3];
6099  rad = result[1];
6100  if (done == 0)
6101  {
6102    rad = intersect(rad, radicalKL(result[2], ideal(1), #));
6103  }
6104  return(rad);
6105}
6106
6107
6108///////////////////////////////////////////////////////////////////////////////
6109//
6110// Computes the radical of I via Laplagne algorithm, using zerodimensional radical in
6111// the zero dimensional case.
6112// For the reduction to the zerodimensional case, it uses the procedure
6113// radical, with some modifications to avoid the recursion.
6114//
6115static proc radicalSL(ideal I, list #)
6116// Input = I, ideal
6117//         #, list. If #[1] = 1, then computes only the equiradical.
6118// Output = (P, primaryDec) where P = rad(I) and primaryDec is the list of the radicals
6119// obtained in intermediate steps.
6120{
6121  ASSUME(1, hasFieldCoefficient(basering) );
6122  ASSUME(1, not isQuotientRing(basering) ) ;
6123  ASSUME(1, hasGlobalOrdering(basering) ) ;
6124
6125  ideal rad = 1;
6126  ideal equiRad = 1;
6127  list primes;
6128  int k;                        // Counter
6129  int il;                 // If il = 1, only the equiradical is required.
6130  int iDim;                // The dimension of I
6131  int stop = 0;   // Checks if the radical has been obtained
6132
6133  if (attrib(I, "isSB") != 1)
6134  {
6135    I = groebner(I);
6136  }
6137  iDim = dim(I);
6138
6139  // Checks if only equiradical is required
6140  if (size(#) > 0)
6141  {
6142    il = #[1];
6143  }
6144
6145  while(stop == 0)
6146  {
6147    dbprint (printlevel-voice, "// We call radLoopR to find new prime ideals.");
6148    primes = radicalSLIteration(I, rad);                         // A list of primes or intersections of primes, not included in P
6149    dbprint (printlevel - voice, "// Output of Iteration Step:");
6150    dbprint (printlevel - voice, primes);
6151    if (size(primes) > 0)
6152    {
6153      dbprint (printlevel - voice, "// We intersect P with the ideal just obtained.");
6154      for(k = 1; k <= size(primes); k++)
6155      {
6156        rad = intersect(rad, primes[k]);
6157        if (il == 1)
6158        {
6159          if (attrib(primes[k], "isSB") != 1)
6160          {
6161            primes[k] = groebner(primes[k]);
6162          }
6163          if (iDim == dim(primes[k]))
6164          {
6165            equiRad = intersect(equiRad, primes[k]);
6166          }
6167        }
6168      }
6169    }
6170    else
6171    {
6172      stop = 1;
6173    }
6174  }
6175  if (il == 0)
6176  {
6177    return(rad);
6178  }
6179  else
6180  {
6181    return(equiRad);
6182  }
6183}
6184
6185//////////////////////////////////////////////////////////////////////////
6186// Based on radicalKL.
6187// It contains all of old version of proc radicalKL except the recursion call.
6188//
6189// Output:
6190// #1 -> output ideal, the part of the radical that has been computed
6191// #2 -> complementary ideal, the part of the ideal I whose radical remains to be computed
6192//       = (I, h) in KL algorithm
6193//       This is not used in the new algorithm. It is part of KL algorithm
6194// #3 -> done, 1: output = radical, there is no need to continue
6195//                   0: radical = output \cap \sqrt{complementary ideal}
6196//       This is not used in the new algorithm. It is part of KL algorithm
6197
6198static proc radicalReduction(ideal I, ideal ser, int allIndep, list #)
6199{
6200// allMaximal      1 -> Indicates that the reduction to the zerodim case
6201//                    must be done for all indep set of the leading terms ideal
6202//                 0 -> Otherwise
6203// ideal ser       Only for radicalKL. (Same as in radicalKL)
6204// list #          Only for radicalKL (If #[1] = 1,
6205//                    only equiradical is required.
6206//                    It is used to set the value of done.)
6207  ASSUME(1, hasFieldCoefficient(basering) );
6208  ASSUME(1, not isQuotientRing(basering) ) ;
6209  ASSUME(1, hasGlobalOrdering(basering) ) ;
6210
6211  attrib(I, "isSB", 1);   // I needs to be a reduced standard basis
6212  list indep, fett;
6213  intvec @w, @hilb, op;
6214  int @wr, @n, @m, lauf, di;
6215  ideal fac, @h, collectrad, lsau;
6216  poly @q;
6217  string @va; def quotring;
6218
6219  def @P = basering;
6220  int jdim = dim(I);               // Computes the dimension of I
6221  int  homo = homog(I);            // Finds out if I is homogeneous
6222  ideal rad = ideal(1);            // The unit ideal
6223  ideal te = ser;
6224  if(size(#) > 0)
6225  {
6226    @wr = #[1];
6227  }
6228  if(homo == 1)
6229  {
6230    for(@n = 1; @n <= nvars(basering); @n++)
6231    {
6232      @w[@n] = ord(var(@n));
6233    }
6234    @hilb = hilb(I, 1, @w);
6235  }
6236
6237  // SL 2006.04.11 1 Debug messages
6238  dbprint(printlevel-voice, "//Computes the radical of the ideal:", I);
6239  // SL 2006.04.11 2 Debug messages
6240
6241  //---------------------------------------------------------------------------
6242  //j is the ring
6243  //---------------------------------------------------------------------------
6244
6245  if (jdim==-1)
6246  {
6247    return(ideal(1), ideal(1), 1);
6248  }
6249
6250  //---------------------------------------------------------------------------
6251  //the zero-dimensional case
6252  //---------------------------------------------------------------------------
6253
6254  if (jdim==0)
6255  {
6256    return(zeroRad(I), ideal(1), 1);
6257  }
6258
6259  //-------------------------------------------------------------------------
6260  //search for a maximal independent set indep,i.e.
6261  //look for subring such that the intersection with the ideal is zero
6262  //j intersected with K[var(indep[3]+1),...,var(nvar)] is zero,
6263  //indep[1] is the new varstring, indep[2] the string for the block-ordering
6264  //-------------------------------------------------------------------------
6265
6266  // SL 2006-04-24 1   If allIndep = 0, then it only computes one maximal
6267  //                     independent set.
6268  //                     This looks better for the new algorithm but not for KL
6269  //                     algorithm
6270  list parameters = allIndep;
6271  indep = newMaxIndependSetDp(I, parameters);
6272  // SL 2006-04-24 2
6273
6274  for(@m = 1; @m <= size(indep); @m++)
6275  {
6276    if((indep[@m][1] == varstr(basering)) && (@m == 1))
6277    //this is the good case, nothing to do, just to have the same notations
6278    //change the ring
6279    {
6280      execute("ring gnir1 = ("+charstr(basering)+"),("+varstr(basering)+"),("
6281                              +ordstr(basering)+");");
6282      ideal @j = fetch(@P, I);
6283      attrib(@j, "isSB", 1);
6284    }
6285    else
6286    {
6287      @va = string(maxideal(1));
6288
6289      execute("ring gnir1 = (" + charstr(basering) + "), (" + indep[@m][1] + "),("
6290                              + indep[@m][2] + ");");
6291      execute("map phi = @P," + @va + ";");
6292      if(homo == 1)
6293      {
6294        ideal @j = std(phi(I), @hilb, @w);
6295      }
6296      else
6297      {
6298        ideal @j = groebner(phi(I));
6299      }
6300    }
6301    if((deg(@j[1]) == 0) || (dim(@j) < jdim))
6302    {
6303      setring @P;
6304      break;
6305    }
6306    for (lauf = 1; lauf <= size(@j); lauf++)
6307    {
6308      fett[lauf] = size(@j[lauf]);
6309    }
6310    //------------------------------------------------------------------------
6311    // We have now the following situation:
6312    // j intersected with K[var(nnp+1),..,var(nva)] is zero so we may pass
6313    // to this quotientring, j is there still a standardbasis, the
6314    // leading coefficients of the polynomials there (polynomials in
6315    // K[var(nnp+1),..,var(nva)]) are collected in the list h,
6316    // we need their LCM, gh, because of the following:
6317    // let (j:gh^n)=(j:gh^infinity) then j*K(var(nnp+1),..,var(nva))[..rest..]
6318    // intersected with K[var(1),...,var(nva)] is (j:gh^n)
6319    // on the other hand j = ((j, gh^n) intersected with (j : gh^n))
6320
6321    //------------------------------------------------------------------------
6322    // The arrangement for the quotientring K(var(nnp+1),..,var(nva))[..rest..]
6323    // and the map phi:K[var(1),...,var(nva)] ----->
6324    // K(var(nnpr+1),..,var(nva))[..the rest..]
6325    //------------------------------------------------------------------------
6326    quotring = prepareQuotientring(nvars(basering) - indep[@m][3],"dp");
6327    //------------------------------------------------------------------------
6328    // We pass to the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
6329    //------------------------------------------------------------------------
6330
6331    setring quotring;
6332
6333    // @j considered in the quotientring
6334    ideal @j = imap(gnir1, @j);
6335
6336    kill gnir1;
6337
6338    // j is a standardbasis in the quotientring but usually not minimal
6339    // here it becomes minimal
6340
6341    @j = clearSB(@j, fett);
6342
6343    // We need later LCM(h[1],...) = gh for saturation
6344    ideal @h;
6345    if(deg(@j[1]) > 0)
6346    {
6347      for(@n = 1; @n <= size(@j); @n++)
6348      {
6349        @h[@n] = leadcoef(@j[@n]);
6350      }
6351      op = option(get);
6352      option(redSB);
6353      @j = std(@j);  //to obtain a reduced standardbasis
6354      option(set, op);
6355
6356      // SL 1 Debug messages
6357      dbprint(printlevel - voice, "zero_rad", basering, @j, dim(groebner(@j)));
6358      ideal zero_rad = zeroRad(@j);
6359      dbprint(printlevel - voice, "zero_rad passed");
6360      // SL 2
6361    }
6362    else
6363    {
6364      ideal zero_rad = ideal(1);
6365    }
6366
6367    // We need the intersection of the ideals in the list quprimary with the
6368    // polynomialring, i.e. let q=(f1,...,fr) in the quotientring such an ideal
6369    // but fi polynomials, then the intersection of q with the polynomialring
6370    // is the saturation of the ideal generated by f1,...,fr with respect to
6371    // h which is the lcm of the leading coefficients of the fi considered in
6372    // the quotientring: this is coded in saturn
6373
6374    zero_rad = std(zero_rad);
6375
6376    ideal hpl;
6377
6378    for(@n = 1; @n <= size(zero_rad); @n++)
6379    {
6380      hpl = hpl, leadcoef(zero_rad[@n]);
6381    }
6382
6383    //------------------------------------------------------------------------
6384    // We leave  the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
6385    // back to the polynomialring
6386    //------------------------------------------------------------------------
6387    setring @P;
6388
6389    collectrad = imap(quotring, zero_rad);
6390    lsau = simplify(imap(quotring, hpl), 2);
6391    @h = imap(quotring, @h);
6392
6393    kill quotring;
6394
6395    // Here the intersection with the polynomialring
6396    // mentioned above is really computed
6397
6398    collectrad = sat2(collectrad, lsau)[1];
6399    if(deg(@h[1])>=0)
6400    {
6401      fac = ideal(0);
6402      for(lauf = 1; lauf <= ncols(@h); lauf++)
6403      {
6404        if(deg(@h[lauf]) > 0)
6405        {
6406          fac = fac + factorize(@h[lauf], 1);
6407        }
6408      }
6409      fac = simplify(fac, 6);
6410      @q = 1;
6411      for(lauf = 1; lauf <= size(fac); lauf++)
6412      {
6413        @q = @q * fac[lauf];
6414      }
6415      op = option(get);
6416      option(returnSB);
6417      option(redSB);
6418      I = quotient(I + ideal(@q), rad);
6419      attrib(I, "isSB", 1);
6420      option(set, op);
6421    }
6422    if((deg(rad[1]) > 0) && (deg(collectrad[1]) > 0))
6423    {
6424      rad = intersect(rad, collectrad);
6425      te = intersect(te, collectrad);
6426      te = simplify(reduce(te, I, 1), 2);
6427    }
6428    else
6429    {
6430      if(deg(collectrad[1]) > 0)
6431      {
6432        rad = collectrad;
6433        te = intersect(te, collectrad);
6434        te = simplify(reduce(te, I, 1), 2);
6435      }
6436    }
6437
6438    if((dim(I) < jdim)||(size(te) == 0))
6439    {
6440      break;
6441    }
6442    if(homo==1)
6443    {
6444      @hilb = hilb(I, 1, @w);
6445    }
6446  }
6447
6448  // SL 2006.04.11 1 Debug messages
6449  dbprint (printlevel-voice, "// Part of the Radical already computed:", rad);
6450  dbprint (printlevel-voice, "// Dimension:", dim(groebner(rad)));
6451  // SL 2006.04.11 2 Debug messages
6452
6453  // SL 2006.04.21 1    New variable "done".
6454  //                      It tells if the radical is already computed or
6455  //                      if it still has to be computed the radical of the new ideal I
6456  int done;
6457  if(((@wr == 1) && (dim(I)<jdim)) || (deg(I[1])==0) || (size(te) == 0))
6458  {
6459    done = 1;
6460  }
6461  else
6462  {
6463    done = 0;
6464  }
6465  // SL 2006.04.21 2
6466
6467  // SL 2006.04.21 1     See details of the output at the beginning of this proc.
6468  list result = rad, I, done;
6469  return(result);
6470  // SL 2006.04.21 2
6471}
6472
6473///////////////////////////////////////////////////////////////////////////////
6474// Given an ideal I and an ideal P (intersection of some minimal prime ideals
6475// associated to I), it calculates the intersection of new minimal prime ideals
6476// associated to I which where not used to calculate P.
6477// This version uses ZD Radical in the zerodimensional case.
6478static proc radicalSLIteration (ideal I, ideal P);
6479// Input: I, ideal. The ideal from which new prime components will be obtained.
6480//        P, ideal. Intersection of some prime ideals of I.
6481// Output: ideal. Intersection of some primes of I different from the ones in P.
6482{
6483  ASSUME(1, hasFieldCoefficient(basering) );
6484  ASSUME(1, not isQuotientRing(basering) ) ;
6485  ASSUME(1, hasGlobalOrdering(basering) ) ;
6486
6487  int k = 1;                     // Counter
6488  int good  = 0;                 // Checks if an element of P is in rad(I)
6489
6490  dbprint (printlevel-voice, "// We search for an element in P - sqrt(I).");
6491  while ((k <= size(P)) and (good == 0))
6492  {
6493    dbprint (printlevel-voice, "// We try with:", P[k]);
6494    good = 1 - rad_con(P[k], I);
6495    k++;
6496  }
6497  k--;
6498  if (good == 0)
6499  {
6500    dbprint (printlevel-voice, "// No element was found, P = sqrt(I).");
6501    list emptyList = list();
6502    return (emptyList);
6503  }
6504  dbprint(printlevel - voice, "// That one was good!");
6505  dbprint(printlevel - voice, "// We saturate I with respect to this element.");
6506  if (P[k] != 1)
6507  {
6508    intvec oo=option(get);
6509    option(redSB);
6510    ideal J = sat(I, P[k])[1];
6511    option(set,oo);
6512
6513  }
6514  else
6515  {
6516    dbprint(printlevel - voice, "// The polynomial is 1, the saturation in not actually computed.");
6517    ideal J = I;
6518  }
6519
6520  // We now call proc radicalNew;
6521  dbprint(printlevel - voice, "// We do the reduction to the zerodimensional case, via radical.");
6522  dbprint(printlevel - voice, "// The ideal is ", J);
6523  dbprint(printlevel - voice, "// The dimension is ", dim(groebner(J)));
6524
6525  int allMaximal = 0;   // Compute the zerodim reduction for only one indep set.
6526  ideal re = 1;         // No reduction is need,
6527                        //    there are not redundant components.
6528  list emptyList = list();   // Look for primes of any dimension,
6529                             //   not only of max dimension.
6530  list result = radicalReduction(J, re, allMaximal, emptyList);
6531
6532  return(result[1]);
6533}
6534
6535///////////////////////////////////////////////////////////////////////////////////
6536// Based on maxIndependSet
6537// Added list # as parameter
6538// If the first element of # is 0, the output is only 1 max indep set.
6539// If no list is specified or #[1] = 1, the output is all the max indep set of the
6540// leading terms ideal. This is the original output of maxIndependSet
6541
6542// The ordering given in the output has been changed to block dp instead of lp.
6543
6544proc newMaxIndependSetDp(ideal j, list #)
6545"USAGE:   newMaxIndependentSetDp(I); I ideal (returns all maximal independent sets of the corresponding leading terms ideal)
6546          newMaxIndependentSetDp(I, 0); I ideal (returns only one maximal independent set)
6547RETURN:  list = #1. new varstring with the maximal independent set at the end,
6548                #2. ordstring with the corresponding dp block ordering,
6549                #3. the number of independent variables
6550NOTE:
6551EXAMPLE: example newMaxIndependentSetDp; shows an example
6552"
6553{
6554  ASSUME(0, hasFieldCoefficient(basering) );
6555  ASSUME(0, not isQuotientRing(basering) ) ;
6556  ASSUME(0, hasGlobalOrdering(basering) ) ;
6557
6558  int n, k, di;
6559  list resu, hilf;
6560  string var1, var2;
6561  list v = indepSet(j, 0);
6562
6563  // SL 2006.04.21 1 Lines modified to use only one independent Set
6564  int allMaximal;
6565  if (size(#) > 0)
6566  {
6567    allMaximal = #[1];
6568  }
6569  else
6570  {
6571    allMaximal = 1;
6572  }
6573
6574  int nMax;
6575  if (allMaximal == 1)
6576  {
6577    nMax = size(v);
6578  }
6579  else
6580  {
6581    nMax = 1;
6582  }
6583
6584  for(n = 1; n <= nMax; n++)
6585  // SL 2006.04.21 2
6586  {
6587    di = 0;
6588    var1 = "";
6589    var2 = "";
6590    for(k = 1; k <= size(v[n]); k++)
6591    {
6592     if(v[n][k] != 0)
6593      {
6594        di++;
6595        var2 = var2 + "var(" + string(k) + "), ";
6596      }
6597      else
6598      {
6599        var1 = var1 + "var(" + string(k) + "), ";
6600      }
6601    }
6602    if(di > 0)
6603    {
6604      var1 = var1 + var2;
6605      var1 = var1[1..size(var1) - 2];                         // The "- 2" removes the trailer comma
6606      hilf[1] = var1;
6607      // SL 2006.21.04 1 The order is now block dp instead of lp
6608      hilf[2] = "dp(" + string(nvars(basering) - di) + "), dp(" + string(di) + ")";
6609      // SL 2006.21.04 2
6610      hilf[3] = di;
6611      resu[n] = hilf;
6612    }
6613    else
6614    {
6615      resu[n] = varstr(basering), ordstr(basering), 0;
6616    }
6617  }
6618  return(resu);
6619}
6620example
6621{ "EXAMPLE:"; echo = 2;
6622   ring s1 = (0, x, y), (a, b, c, d, e, f, g), lp;
6623   ideal i = ea - fbg, fa + be, ec - fdg, fc + de;
6624   i = std(i);
6625   list l = newMaxIndependSetDp(i);
6626   l;
6627   i = i, g;
6628   l = newMaxIndependSetDp(i);
6629   l;
6630
6631   ring s = 0, (x, y, z), lp;
6632   ideal i = z, yx;
6633   list l = newMaxIndependSetDp(i);
6634   l;
6635}
6636
6637
6638///////////////////////////////////////////////////////////////////////////////
6639proc prepareAss(ideal i)
6640"USAGE:   prepareAss(I); I ideal
6641RETURN:  list, the radicals of the maximal dimensional components of I.
6642NOTE:    Uses algorithm of Eisenbud/Huneke/Vasconcelos.
6643EXAMPLE: example prepareAss; shows an example
6644"
6645{
6646  ASSUME(0, hasFieldCoefficient(basering) );
6647  ASSUME(0, not isQuotientRing(basering) ) ;
6648  if(attrib(basering,"global")!=1)
6649  {
6650      ERROR(
6651      "// Not implemented for this ordering, please change to global ordering."
6652      );
6653  }
6654
6655  ideal j=std(i);
6656  int cod=nvars(basering)-dim(j);
6657  int e;
6658  list er;
6659  ideal ann;
6660  if(homog(i)==1)
6661  {
6662     resolution re=sres(j,0);                   //the resolution
6663     re=minres(re);                       //minimized resolution
6664  }
6665  else
6666  {
6667    list re=mres(i,0);
6668  }
6669  for(e=cod;e<=nvars(basering);e++)
6670  {
6671     ann=AnnExt_R(e,re);
6672
6673     if(nvars(basering)-dim(std(ann))==e)
6674     {
6675        er[size(er)+1]=equiRadical(ann);
6676     }
6677  }
6678  return(er);
6679}
6680example
6681{ "EXAMPLE:";  echo = 2;
6682   ring  r = 0,(x,y,z),dp;
6683   poly  p = z2+1;
6684   poly  q = z3+2;
6685   ideal i = p*q^2,y-z2;
6686   list pr = prepareAss(i);
6687   pr;
6688}
6689///////////////////////////////////////////////////////////////////////////////
6690proc equidimMaxEHV(ideal i)
6691"USAGE:  equidimMaxEHV(I); I ideal
6692RETURN:  ideal, the equidimensional component (of maximal dimension) of I.
6693NOTE:    Uses algorithm of Eisenbud, Huneke and Vasconcelos.
6694EXAMPLE: example equidimMaxEHV; shows an example
6695"
6696{
6697  ASSUME(0, hasFieldCoefficient(basering) );
6698  ASSUME(0, not isQuotientRing(basering) ) ;
6699  if(attrib(basering,"global")!=1)
6700  {
6701      ERROR(
6702      "// Not implemented for this ordering, please change to global ordering."
6703      );
6704  }
6705
6706  ideal j=groebner(i);
6707  int cod=nvars(basering)-dim(j);
6708
6709
6710  if(cod > nvars(basering))
6711    {
6712      dbprint(printlevel,"//If I is the entire ring...");
6713      dbprint(printlevel,"//...then return the ideal generated by 1.");
6714      return(ideal(1));
6715    }
6716
6717  int e;
6718  ideal ann;
6719  if(homog(i)==1)
6720  {
6721     resolution re=sres(j,0);                   //the resolution
6722     re=minres(re);                       //minimized resolution
6723  }
6724  else
6725  {
6726    resolution re=mres(j,0);
6727  }
6728  ann = AnnExt_R(cod,re);
6729  if( nvars(basering)-dim(std(ann) ) != cod)
6730  {
6731     return( ideal(1) );
6732  }
6733
6734  return(ann);
6735}
6736example
6737{ "EXAMPLE:";  echo = 2;
6738   ring  r = 0,(x,y,z),dp;
6739   ideal i=intersect(ideal(z),ideal(x,y),ideal(x2,z2),ideal(x5,y5,z5));
6740   equidimMaxEHV(i);
6741}
6742
6743proc testPrimary(list pr, ideal k)
6744"USAGE:   testPrimary(pr,k); pr a list, k an ideal.
6745ASSUME:  pr is the result of primdecGTZ(k) or primdecSY(k).
6746RETURN:  int, 1 if the intersection of the ideals in pr is k, 0 if not
6747EXAMPLE: example testPrimary; shows an example
6748"
6749{
6750   ASSUME(0, hasFieldCoefficient(basering) );
6751   ASSUME(0, not isQuotientRing(basering) ) ;
6752
6753   int i;
6754   pr=reconvList(pr);
6755   ideal j=pr[1];
6756   for (i=2;i<=size(pr) div 2;i++)
6757   {
6758       j=intersect(j,pr[2*i-1]);
6759   }
6760   return(idealsEqual(j,k));
6761}
6762example
6763{ "EXAMPLE:";  echo = 2;
6764   ring  r = 32003,(x,y,z),dp;
6765   poly  p = z2+1;
6766   poly  q = z4+2;
6767   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
6768   list pr = primdecGTZ(i);
6769   testPrimary(pr,i);
6770}
6771
6772///////////////////////////////////////////////////////////////////////////////
6773proc zerodec(ideal I)
6774"USAGE:   zerodec(I); I ideal
6775ASSUME:  I is zero-dimensional, the characteristic of the ground field is 0
6776RETURN:  list of primary ideals, the zero-dimensional decomposition of I
6777NOTE:    The algorithm (of Monico), works well only for a small total number
6778         of solutions (@code{vdim(std(I))} should be < 100) and without
6779         parameters. In practice, it works also in large characteristic p>0
6780         but may fail for small p.
6781@*       If printlevel > 0 (default = 0) additional information is displayed.
6782EXAMPLE: example zerodec; shows an example
6783"
6784{
6785  ASSUME(0, hasFieldCoefficient(basering) );
6786  ASSUME(0, not isQuotientRing(basering) ) ;
6787  if(attrib(basering,"global")!=1)
6788  {
6789    ERROR(
6790    "// Not implemented for this ordering, please change to global ordering."
6791    );
6792  }
6793
6794  def R=basering;
6795  poly q;
6796  int j,time;
6797  matrix m;
6798  list re;
6799  poly va=var(1);
6800  ideal J=groebner(I);
6801  ideal ba=kbase(J);
6802  int d=vdim(J);
6803  dbprint(printlevel-voice+2,"// multiplicity of ideal : "+ string(d));
6804//------ compute matrix of multiplication on R/I with generic element p -----
6805  int e=nvars(basering);
6806  poly p=randomLast(100)[e]+random(-50,50);     //the generic element
6807  matrix n[d][d];
6808  time = timer;
6809  for(j=2;j<=e;j++)
6810  {
6811    va=va*var(j);
6812  }
6813  for(j=1;j<=d;j++)
6814  {
6815    q=reduce(p*ba[j],J);
6816    m=coeffs(q,ba,va);
6817    n[j,1..d]=m[1..d,1];
6818  }
6819  dbprint(printlevel-voice+2,
6820    "// time for computing multiplication matrix (with generic element) : "+
6821    string(timer-time));
6822//---------------- compute characteristic polynomial of matrix --------------
6823  execute("ring P1=("+charstr(R)+"),T,dp;");
6824  matrix n=imap(R,n);
6825  time = timer;
6826  poly charpol=det(n-T*freemodule(d));
6827  dbprint(printlevel-voice+2,"// time for computing char poly: "+
6828         string(timer-time));
6829//------------------- factorize characteristic polynomial -------------------
6830//check first if constant term of charpoly is != 0 (which is true for
6831//sufficiently generic element)
6832  if(charpol[size(charpol)]!=0)
6833  {
6834    time = timer;
6835    list fac=factor(charpol);
6836    testFactor(fac,charpol);
6837    dbprint(printlevel-voice+2,"// time for factorizing char poly: "+
6838            string(timer-time));
6839    int f=size(fac[1]);
6840//--------------------------- the irreducible case --------------------------
6841    if(f==1)
6842    {
6843      setring R;
6844      re=I;
6845      return(re);
6846    }
6847//---------------------------- the reducible case ---------------------------
6848//if f_i are the irreducible factors of charpoly, mult=ri, then <I,g_i^ri>
6849//are the primary components where g_i = f_i(p). However, substituting p in
6850//f_i may result in a huge object although the final result may be small.
6851//Hence it is better to simultaneously reduce with I. For this we need a new
6852//ring.
6853    execute("ring P=("+charstr(R)+"),(T,"+varstr(R)+"),(dp(1),dp);");
6854    list rfac=imap(P1,fac);
6855    intvec ov=option(get);;
6856    option(redSB);
6857    list re1;
6858    ideal new = T-imap(R,p),imap(R,J);
6859    attrib(new, "isSB",1);    //we know that new is a standard basis
6860    for(j=1;j<=f;j++)
6861    {
6862      re1[j]=reduce(rfac[1][j]^rfac[2][j],new);
6863    }
6864    setring R;
6865    re = imap(P,re1);
6866    for(j=1;j<=f;j++)
6867    {
6868      J=I,re[j];
6869      re[j]=interred(J);
6870    }
6871    option(set,ov);
6872    return(re);
6873  }
6874  else
6875//------------------- choice of generic element failed -------------------
6876  {
6877    dbprint(printlevel-voice+2,"// try new generic element!");
6878    setring R;
6879    return(zerodec(I));
6880  }
6881}
6882example
6883{ "EXAMPLE:";  echo = 2;
6884   ring r  = 0,(x,y),dp;
6885   ideal i = x2-2,y2-2;
6886   list pr = zerodec(i);
6887   pr;
6888}
6889///////////////////////////////////////////////////////////////////////////////
6890static proc newDecompStep(ideal i, list #)
6891"USAGE:  newDecompStep(i); i ideal  (for primary decomposition)
6892         newDecompStep(i,1);        (for the associated primes of dimension of i)
6893         newDecompStep(i,2);        (for the minimal associated primes)
6894         newDecompStep(i,3);        (for the absolute primary decomposition (not tested!))
6895         "oneIndep";        (for using only one max indep set)
6896         "intersect";        (returns alse the intersection of the components founded)
6897
6898RETURN:  list = list of primary ideals and their associated primes
6899         (at even positions in the list)
6900         (resp. a list of the minimal associated primes)
6901NOTE:    Algorithm of Gianni/Trager/Zacharias
6902EXAMPLE: example newDecompStep; shows an example
6903"
6904{
6905  ASSUME(1, hasFieldCoefficient(basering) );
6906  ASSUME(1, not isQuotientRing(basering) ) ;
6907  ASSUME(1, hasGlobalOrdering(basering) ) ;
6908
6909  intvec op@P, op,@vv;
6910  def  @P = basering;
6911  list primary,indep,ltras;
6912  intvec @vh,isat,@w;
6913  int @wr,@k,@n,@m,@n1,@n2,@n3,homo,seri,keepdi,abspri,ab,nn;
6914  ideal peek=i;
6915  ideal ser,tras;
6916  list data;
6917  list result;
6918  intvec @hilb;
6919  int isS=(attrib(i,"isSB")==1);
6920
6921  // Debug
6922  dbprint(printlevel - voice, "newDecompStep, v2.0");
6923
6924  string indepOption = "allIndep";
6925  string intersectOption = "noIntersect";
6926
6927  if(size(#)>0)
6928  {
6929    int count = 1;
6930    if(typeof(#[count]) == "string")
6931    {
6932      if ((#[count] == "oneIndep") or (#[count] == "allIndep"))
6933      {
6934        indepOption = #[count];
6935        count++;
6936      }
6937    }
6938    if(typeof(#[count]) == "string")
6939    {
6940      if ((#[count] == "intersect") or (#[count] == "noIntersect"))
6941      {
6942        intersectOption = #[count];
6943        count++;
6944      }
6945    }
6946    if((typeof(#[count]) == "int") or (typeof(#[count]) == "number"))
6947    {
6948      if ((#[count]==1)||(#[count]==2)||(#[count]==3))
6949      {
6950        @wr=#[count];
6951        if(@wr==3){abspri = 1; @wr = 0;}
6952        count++;
6953      }
6954    }
6955    if(size(#)>count)
6956    {
6957      seri=1;
6958      peek=#[count + 1];
6959      ser=#[count + 2];
6960    }
6961  }
6962  if(abspri)
6963  {
6964    list absprimary,abskeep,absprimarytmp,abskeeptmp;
6965  }
6966  homo=homog(i);
6967  if(homo==1)
6968  {
6969    if(attrib(i,"isSB")!=1)
6970    {
6971      //ltras=mstd(i);
6972      tras=groebner(i);
6973      ltras=tras,tras;
6974      attrib(ltras[1],"isSB",1);
6975    }
6976    else
6977    {
6978      ltras=i,i;
6979      attrib(ltras[1],"isSB",1);
6980    }
6981    tras = ltras[1];
6982    attrib(tras,"isSB",1);
6983    if(dim(tras)==0)
6984    {
6985      primary[1]=ltras[2];
6986      primary[2]=maxideal(1);
6987      if(@wr>0)
6988      {
6989        list l;
6990        l[2]=maxideal(1);
6991        l[1]=maxideal(1);
6992        if (intersectOption == "intersect")
6993        {
6994          return(list(l, maxideal(1)));
6995        }
6996        else
6997        {
6998          return(l);
6999        }
7000      }
7001      if (intersectOption == "intersect")
7002      {
7003        return(list(primary, primary[1]));
7004      }
7005      else
7006      {
7007        return(primary);
7008      }
7009    }
7010    for(@n=1;@n<=nvars(basering);@n++)
7011    {
7012      @w[@n]=ord(var(@n));
7013    }
7014    @hilb=hilb(tras,1,@w);
7015    intvec keephilb=@hilb;
7016  }
7017
7018  //----------------------------------------------------------------
7019  //i is the zero-ideal
7020  //----------------------------------------------------------------
7021
7022  if(size(i)==0)
7023  {
7024    primary=i,i;
7025    if (intersectOption == "intersect")
7026    {
7027      return(list(primary, i));
7028    }
7029    else
7030    {
7031      return(primary);
7032    }
7033  }
7034
7035  //----------------------------------------------------------------
7036  //pass to the lexicographical ordering and compute a standardbasis
7037  //----------------------------------------------------------------
7038
7039  int lp=islp();
7040
7041  op@P = option(get);
7042  execute("ring gnir = ("+charstr(basering)+"),("+varstr(basering)+"),(C,lp);");
7043
7044  op=option(get);
7045  option(redSB);
7046
7047  ideal ser=fetch(@P,ser);
7048  if(homo==1)
7049  {
7050    if(!lp)
7051    {
7052      ideal @j=std(fetch(@P,i),@hilb,@w);
7053    }
7054    else
7055    {
7056      ideal @j=fetch(@P,tras);
7057      attrib(@j,"isSB",1);
7058    }
7059  }
7060  else
7061  {
7062    if(lp&&isS)
7063    {
7064      ideal @j=fetch(@P,i);
7065      attrib(@j,"isSB",1);
7066    }
7067    else
7068    {
7069      ideal @j=groebner(fetch(@P,i));
7070    }
7071  }
7072  option(set,op);
7073  if(seri==1)
7074  {
7075    ideal peek=fetch(@P,peek);
7076    attrib(peek,"isSB",1);
7077  }
7078  else
7079  {
7080    ideal peek=@j;
7081  }
7082  if((size(ser)==0)&&(!abspri))
7083  {
7084    ideal fried;
7085    @n=size(@j);
7086    for(@k=1;@k<=@n;@k++)
7087    {
7088      if(deg(lead(@j[@k]))==1)
7089      {
7090        fried[size(fried)+1]=@j[@k];
7091        @j[@k]=0;
7092      }
7093    }
7094    if(size(fried)==nvars(basering))
7095    {
7096      setring @P;
7097      option(set,op@P);
7098      primary[1]=i;
7099      primary[2]=i;
7100      if (intersectOption == "intersect")
7101      {
7102        return(list(primary, i));
7103      }
7104      else
7105      {
7106        return(primary);
7107      }
7108    }
7109    if(size(fried)>0)
7110    {
7111      string newva;
7112      string newma;
7113      for(@k=1;@k<=nvars(basering);@k++)
7114      {
7115        @n1=0;
7116        for(@n=1;@n<=size(fried);@n++)
7117        {
7118          if(leadmonom(fried[@n])==var(@k))
7119          {
7120            @n1=1;
7121            break;
7122          }
7123        }
7124        if(@n1==0)
7125        {
7126          newva=newva+string(var(@k))+",";
7127          newma=newma+string(var(@k))+",";
7128        }
7129        else
7130        {
7131          newma=newma+string(0)+",";
7132        }
7133      }
7134      newva[size(newva)]=")";
7135      newma[size(newma)]=";";
7136      execute("ring @deirf=("+charstr(gnir)+"),("+newva+",lp;");
7137      execute("map @kappa=gnir,"+newma);
7138      ideal @j= @kappa(@j);
7139      @j=simplify(@j, 2);
7140      attrib(@j,"isSB",1);
7141      result = newDecompStep(@j, indepOption, intersectOption, @wr);
7142      if (intersectOption == "intersect")
7143      {
7144       list pr = result[1];
7145       ideal intersection = result[2];
7146      }
7147      else
7148      {
7149        list pr = result;
7150      }
7151
7152      setring gnir;
7153      list pr=imap(@deirf,pr);
7154      for(@k=1;@k<=size(pr);@k++)
7155      {
7156        @j=pr[@k]+fried;
7157        pr[@k]=@j;
7158      }
7159      if (intersectOption == "intersect")
7160      {
7161        ideal intersection = imap(@deirf, intersection);
7162        @j = intersection + fried;
7163        intersection = @j;
7164      }
7165      setring @P;
7166      option(set,op@P);
7167      if (intersectOption == "intersect")
7168      {
7169        return(list(imap(gnir,pr), imap(gnir,intersection)));
7170      }
7171      else
7172      {
7173        return(imap(gnir,pr));
7174      }
7175    }
7176  }
7177  //----------------------------------------------------------------
7178  //j is the ring
7179  //----------------------------------------------------------------
7180
7181  if (dim(@j)==-1)
7182  {
7183    setring @P;
7184    option(set,op@P);
7185    primary=ideal(1),ideal(1);
7186    if (intersectOption == "intersect")
7187    {
7188      return(list(primary, ideal(1)));
7189    }
7190    else
7191    {
7192      return(primary);
7193    }
7194  }
7195
7196  //----------------------------------------------------------------
7197  //  the case of one variable
7198  //----------------------------------------------------------------
7199
7200  if(nvars(basering)==1)
7201  {
7202    list fac=factor(@j[1]);
7203    list gprimary;
7204    poly generator;
7205    ideal gIntersection;
7206    for(@k=1;@k<=size(fac[1]);@k++)
7207    {
7208      if(@wr==0)
7209      {
7210        gprimary[2*@k-1]=ideal(fac[1][@k]^fac[2][@k]);
7211        gprimary[2*@k]=ideal(fac[1][@k]);
7212      }
7213      else
7214      {
7215        gprimary[2*@k-1]=ideal(fac[1][@k]);
7216        gprimary[2*@k]=ideal(fac[1][@k]);
7217      }
7218      if (intersectOption == "intersect")
7219      {
7220        generator = generator * fac[1][@k];
7221      }
7222    }
7223    if (intersectOption == "intersect")
7224    {
7225      gIntersection = generator;
7226    }
7227    setring @P;
7228    primary=fetch(gnir,gprimary);
7229    if (intersectOption == "intersect")
7230    {
7231      ideal intersection = fetch(gnir,gIntersection);
7232    }
7233
7234//HIER
7235    if(abspri)
7236    {
7237      list resu,tempo;
7238      string absotto;
7239      for(ab=1;ab<=size(primary) div 2;ab++)
7240      {
7241        absotto= absFactorize(primary[2*ab][1],77);
7242        tempo=primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
7243        resu[ab]=tempo;
7244      }
7245      primary=resu;
7246      intersection = 1;
7247      for(ab=1;ab<=size(primary);ab++)
7248      {
7249        intersection = intersect(intersection, primary[ab][2]);
7250      }
7251    }
7252    if (intersectOption == "intersect")
7253    {
7254      return(list(primary, intersection));
7255    }
7256    else
7257    {
7258      return(primary);
7259    }
7260  }
7261
7262 //------------------------------------------------------------------
7263 //the zero-dimensional case
7264 //------------------------------------------------------------------
7265  if (dim(@j)==0)
7266  {
7267    op=option(get);
7268    option(redSB);
7269    list gprimary= newZero_decomp(@j,ser,@wr);
7270
7271    setring @P;
7272    primary=fetch(gnir,gprimary);
7273
7274    if(size(ser)>0)
7275    {
7276      primary=cleanPrimary(primary);
7277    }
7278//HIER
7279    if(abspri)
7280    {
7281      list resu,tempo;
7282      string absotto;
7283      for(ab=1;ab<=size(primary) div 2;ab++)
7284      {
7285        absotto= absFactorize(primary[2*ab][1],77);
7286        tempo=primary[2*ab-1],primary[2*ab],absotto,string(var(nvars(basering)));
7287        resu[ab]=tempo;
7288      }
7289      primary=resu;
7290    }
7291    option(set,op@P);
7292    if (intersectOption == "intersect")
7293    {
7294      return(list(primary, fetch(gnir,@j)));
7295    }
7296    else
7297    {
7298      return(primary);
7299    }
7300  }
7301
7302  poly @gs,@gh,@p;
7303  string @va;
7304  list quprimary,htprimary,collectprimary,lsau,lnew,allindep,restindep;
7305  ideal @h;
7306  int jdim=dim(@j);
7307  list fett;
7308  int lauf,di,newtest;
7309  //------------------------------------------------------------------
7310  //search for a maximal independent set indep,i.e.
7311  //look for subring such that the intersection with the ideal is zero
7312  //j intersected with K[var(indep[3]+1),...,var(nvar] is zero,
7313  //indep[1] is the new varstring and indep[2] the string for block-ordering
7314  //------------------------------------------------------------------
7315  if(@wr!=1)
7316  {
7317    allindep = newMaxIndependSetLp(@j, indepOption);
7318    for(@m=1;@m<=size(allindep);@m++)
7319    {
7320      if(allindep[@m][3]==jdim)
7321      {
7322        di++;
7323        indep[di]=allindep[@m];
7324      }
7325      else
7326      {
7327        lauf++;
7328        restindep[lauf]=allindep[@m];
7329      }
7330    }
7331  }
7332  else
7333  {
7334    indep = newMaxIndependSetLp(@j, indepOption);
7335  }
7336
7337  ideal jkeep=@j;
7338  if(ordstr(@P)[1]=="w")
7339  {
7340    execute("ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),("+ordstr(@P)+");");
7341  }
7342  else
7343  {
7344    execute( "ring @Phelp=("+charstr(gnir)+"),("+varstr(gnir)+"),(C,dp);");
7345  }
7346
7347  if(homo==1)
7348  {
7349    if((ordstr(@P)[3]=="d")||(ordstr(@P)[1]=="d")||(ordstr(@P)[1]=="w")
7350       ||(ordstr(@P)[3]=="w"))
7351    {
7352      ideal jwork=imap(@P,tras);
7353      attrib(jwork,"isSB",1);
7354    }
7355    else
7356    {
7357      ideal jwork=std(imap(gnir,@j),@hilb,@w);
7358    }
7359  }
7360  else
7361  {
7362    ideal jwork=groebner(imap(gnir,@j));
7363  }
7364  list hquprimary;
7365  poly @p,@q;
7366  ideal @h,fac,ser;
7367//Aenderung================
7368  ideal @Ptest=1;
7369//=========================
7370  di=dim(jwork);
7371  keepdi=di;
7372
7373  ser = 1;
7374
7375  setring gnir;
7376  for(@m=1; @m<=size(indep); @m++)
7377  {
7378    data[1] = indep[@m];
7379    result = newReduction(@j, ser, @hilb, @w, jdim, abspri, @wr, data);
7380    quprimary = quprimary + result[1];
7381    if(abspri)
7382    {
7383      absprimary = absprimary + result[2];
7384      abskeep = abskeep + result[3];
7385    }
7386    @h = result[5];
7387    ser = result[4];
7388    if(size(@h)>0)
7389    {
7390      //---------------------------------------------------------------
7391      //we change to @Phelp to have the ordering dp for saturation
7392      //---------------------------------------------------------------
7393
7394      setring @Phelp;
7395      @h=imap(gnir,@h);
7396//Aenderung==================================
7397      if(defined(@LL)){kill @LL;}
7398      list @LL=minSat(jwork,@h);
7399      @Ptest=intersect(@Ptest,@LL[1]);
7400      ser = intersect(ser, @LL[1]);
7401//===========================================
7402
7403      if(@wr!=1)
7404      {
7405//Aenderung==================================
7406        @q=@LL[2];
7407//===========================================
7408        //@q=minSat(jwork,@h)[2];
7409      }
7410      else
7411      {
7412        fac=ideal(0);
7413        for(lauf=1;lauf<=ncols(@h);lauf++)
7414        {
7415          if(deg(@h[lauf])>0)
7416          {
7417            fac=fac+factorize(@h[lauf],1);
7418          }
7419        }
7420        fac=simplify(fac,6);
7421        @q=1;
7422        for(lauf=1;lauf<=size(fac);lauf++)
7423        {
7424          @q=@q*fac[lauf];
7425        }
7426      }
7427      jwork = std(jwork,@q);
7428      keepdi = dim(jwork);
7429      if(keepdi < di)
7430      {
7431        setring gnir;
7432        @j = imap(@Phelp, jwork);
7433        ser = imap(@Phelp, ser);
7434        break;
7435      }
7436      if(homo == 1)
7437      {
7438        @hilb = hilb(jwork, 1, @w);
7439      }
7440
7441      setring gnir;
7442      ser = imap(@Phelp, ser);
7443      @j = imap(@Phelp, jwork);
7444    }
7445  }
7446
7447  if((size(quprimary)==0)&&(@wr==1))
7448  {
7449     @j=ideal(1);
7450     quprimary[1]=ideal(1);
7451     quprimary[2]=ideal(1);
7452  }
7453  if((size(quprimary)==0))
7454  {
7455    keepdi = di - 1;
7456    quprimary[1]=ideal(1);
7457    quprimary[2]=ideal(1);
7458  }
7459  //---------------------------------------------------------------
7460  //notice that j=sat(j,gh) intersected with (j,gh^n)
7461  //we finished with sat(j,gh) and have to start with (j,gh^n)
7462  //---------------------------------------------------------------
7463  if((deg(@j[1])!=0)&&(@wr!=1))
7464  {
7465     if(size(quprimary)>0)
7466     {
7467        setring @Phelp;
7468        ser=imap(gnir,ser);
7469
7470        hquprimary=imap(gnir,quprimary);
7471        if(@wr==0)
7472        {
7473//Aenderung====================================================
7474//HIER STATT DURCHSCHNITT SATURIEREN!
7475           ideal htest=@Ptest;
7476/*
7477           ideal htest=hquprimary[1];
7478           for (@n1=2;@n1<=size(hquprimary) div 2;@n1++)
7479           {
7480              htest=intersect(htest,hquprimary[2*@n1-1]);
7481           }
7482*/
7483//=============================================================
7484        }
7485        else
7486        {
7487           ideal htest=hquprimary[2];
7488
7489           for (@n1=2;@n1<=size(hquprimary) div 2;@n1++)
7490           {
7491              htest=intersect(htest,hquprimary[2*@n1]);
7492           }
7493        }
7494
7495        if(size(ser)>0)
7496        {
7497           ser=intersect(htest,ser);
7498        }
7499        else
7500        {
7501          ser=htest;
7502        }
7503        setring gnir;
7504        ser=imap(@Phelp,ser);
7505     }
7506     if(size(reduce(ser,peek,1))!=0)
7507     {
7508        for(@m=1;@m<=size(restindep);@m++)
7509        {
7510         // if(restindep[@m][3]>=keepdi)
7511         // {
7512           isat=0;
7513           @n2=0;
7514
7515           if(restindep[@m][1]==varstr(basering))
7516           //the good case, nothing to do, just to have the same notations
7517           //change the ring
7518           {
7519              execute("ring gnir1 = ("+charstr(basering)+"),("+
7520                varstr(basering)+"),("+ordstr(basering)+");");
7521              ideal @j=fetch(gnir,jkeep);
7522              attrib(@j,"isSB",1);
7523           }
7524           else
7525           {
7526              @va=string(maxideal(1));
7527              execute("ring gnir1 = ("+charstr(basering)+"),("+
7528                      restindep[@m][1]+"),(" +restindep[@m][2]+");");
7529              execute("map phi=gnir,"+@va+";");
7530              op=option(get);
7531              option(redSB);
7532              if(homo==1)
7533              {
7534                 ideal @j=std(phi(jkeep),keephilb,@w);
7535              }
7536              else
7537              {
7538                ideal @j=groebner(phi(jkeep));
7539              }
7540              ideal ser=phi(ser);
7541              option(set,op);
7542           }
7543
7544           for (lauf=1;lauf<=size(@j);lauf++)
7545           {
7546              fett[lauf]=size(@j[lauf]);
7547           }
7548           //------------------------------------------------------------------
7549           //we have now the following situation:
7550           //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may
7551           //pass to this quotientring, j is their still a standardbasis, the
7552           //leading coefficients of the polynomials  there (polynomials in
7553           //K[var(nnp+1),..,var(nva)]) are collected in the list h,
7554           //we need their ggt, gh, because of the following:
7555           //let (j:gh^n)=(j:gh^infinity) then
7556           //j*K(var(nnp+1),..,var(nva))[..the rest..]
7557           //intersected with K[var(1),...,var(nva)] is (j:gh^n)
7558           //on the other hand j=(j,gh^n) intersected with (j:gh^n)
7559
7560           //------------------------------------------------------------------
7561
7562           //the arrangement for the quotientring
7563           // K(var(nnp+1),..,var(nva))[..the rest..]
7564           //and the map phi:K[var(1),...,var(nva)] ---->
7565           //--->K(var(nnpr+1),..,var(nva))[..the rest..]
7566           //------------------------------------------------------------------
7567
7568           quotring=prepareQuotientring(nvars(basering)-restindep[@m][3],"lp");
7569
7570           //------------------------------------------------------------------
7571           //we pass to the quotientring  K(var(nnp+1),..,var(nva))[..rest..]
7572           //------------------------------------------------------------------
7573
7574           setring quotring;
7575
7576           // @j considered in the quotientring
7577           ideal @j=imap(gnir1,@j);
7578           ideal ser=imap(gnir1,ser);
7579
7580           kill gnir1;
7581
7582           //j is a standardbasis in the quotientring but usually not minimal
7583           //here it becomes minimal
7584           @j=clearSB(@j,fett);
7585           attrib(@j,"isSB",1);
7586
7587           //we need later ggt(h[1],...)=gh for saturation
7588           ideal @h;
7589
7590           for(@n=1;@n<=size(@j);@n++)
7591           {
7592              @h[@n]=leadcoef(@j[@n]);
7593           }
7594           //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..rest..]
7595
7596           op=option(get);
7597           option(redSB);
7598           list uprimary= newZero_decomp(@j,ser,@wr);
7599//HIER
7600           if(abspri)
7601           {
7602              ideal II;
7603              ideal jmap;
7604              map sigma;
7605              nn=nvars(basering);
7606              map invsigma=basering,maxideal(1);
7607              for(ab=1;ab<=size(uprimary) div 2;ab++)
7608              {
7609                 II=uprimary[2*ab];
7610                 attrib(II,"isSB",1);
7611                 if(deg(II[1])!=vdim(II))
7612                 {
7613                    jmap=randomLast(50);
7614                    sigma=basering,jmap;
7615                    jmap[nn]=2*var(nn)-jmap[nn];
7616                    invsigma=basering,jmap;
7617                    II=groebner(sigma(II));
7618                  }
7619                  absprimarytmp[ab]= absFactorize(II[1],77);
7620                  II=var(nn);
7621                  abskeeptmp[ab]=string(invsigma(II));
7622                  invsigma=basering,maxideal(1);
7623              }
7624           }
7625           option(set,op);
7626
7627           //we need the intersection of the ideals in the list quprimary with
7628           //the polynomialring, i.e. let q=(f1,...,fr) in the quotientring
7629           //such an ideal but fi polynomials, then the intersection of q with
7630           //the polynomialring is the saturation of the ideal generated by
7631           //f1,...,fr with respect toh which is the lcm of the leading
7632           //coefficients of the fi considered in the quotientring:
7633           //this is coded in saturn
7634
7635           list saturn;
7636           ideal hpl;
7637
7638           for(@n=1;@n<=size(uprimary);@n++)
7639           {
7640              hpl=0;
7641              for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
7642              {
7643                 hpl=hpl,leadcoef(uprimary[@n][@n1]);
7644              }
7645              saturn[@n]=hpl;
7646           }
7647           //------------------------------------------------------------------
7648           //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..rest..]
7649           //back to the polynomialring
7650           //------------------------------------------------------------------
7651           setring gnir;
7652           collectprimary=imap(quotring,uprimary);
7653           lsau=imap(quotring,saturn);
7654           @h=imap(quotring,@h);
7655
7656           kill quotring;
7657
7658
7659           @n2=size(quprimary);
7660//================NEU=========================================
7661           if(deg(quprimary[1][1])<=0){ @n2=0; }
7662//============================================================
7663
7664           @n3=@n2;
7665
7666           for(@n1=1;@n1<=size(collectprimary) div 2;@n1++)
7667           {
7668              if(deg(collectprimary[2*@n1][1])>0)
7669              {
7670                 @n2++;
7671                 quprimary[@n2]=collectprimary[2*@n1-1];
7672                 lnew[@n2]=lsau[2*@n1-1];
7673                 @n2++;
7674                 lnew[@n2]=lsau[2*@n1];
7675                 quprimary[@n2]=collectprimary[2*@n1];
7676                 if(abspri)
7677                 {
7678                   absprimary[@n2 div 2]=absprimarytmp[@n1];
7679                   abskeep[@n2 div 2]=abskeeptmp[@n1];
7680                 }
7681              }
7682           }
7683
7684
7685           //here the intersection with the polynomialring
7686           //mentioned above is really computed
7687
7688           for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
7689           {
7690              if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
7691              {
7692                 quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7693                 quprimary[2*@n]=quprimary[2*@n-1];
7694              }
7695              else
7696              {
7697                 if(@wr==0)
7698                 {
7699                    quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
7700                 }
7701                 quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
7702              }
7703           }
7704           if(@n2>=@n3+2)
7705           {
7706              setring @Phelp;
7707              ser=imap(gnir,ser);
7708              hquprimary=imap(gnir,quprimary);
7709              for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
7710              {
7711                if(@wr==0)
7712                {
7713                   ser=intersect(ser,hquprimary[2*@n-1]);
7714                }
7715                else
7716                {
7717                   ser=intersect(ser,hquprimary[2*@n]);
7718                }
7719              }
7720              setring gnir;
7721              ser=imap(@Phelp,ser);
7722           }
7723
7724         // }
7725        }
7726//HIER
7727        if(abspri)
7728        {
7729          list resu,tempo;
7730          for(ab=1;ab<=size(quprimary) div 2;ab++)
7731          {
7732             if (deg(quprimary[2*ab][1])!=0)
7733             {
7734               tempo=quprimary[2*ab-1],quprimary[2*ab],
7735                         absprimary[ab],abskeep[ab];
7736               resu[ab]=tempo;
7737             }
7738          }
7739          quprimary=resu;
7740          @wr=3;
7741        }
7742        if(size(reduce(ser,peek,1))!=0)
7743        {
7744           if(@wr>0)
7745           {
7746              // The following line was dropped to avoid the recursion step:
7747              //htprimary=newDecompStep(@j,@wr,peek,ser);
7748              htprimary = list();
7749           }
7750           else
7751           {
7752              // The following line was dropped to avoid the recursion step:
7753              //htprimary=newDecompStep(@j,peek,ser);
7754              htprimary = list();
7755           }
7756           // here we collect now both results primary(sat(j,gh))
7757           // and primary(j,gh^n)
7758           @n=size(quprimary);
7759           if (deg(quprimary[1][1])<=0) { @n=0; }
7760           for (@k=1;@k<=size(htprimary);@k++)
7761           {
7762              quprimary[@n+@k]=htprimary[@k];
7763           }
7764        }
7765     }
7766   }
7767   else
7768   {
7769      if(abspri)
7770      {
7771        list resu,tempo;
7772        for(ab=1;ab<=size(quprimary) div 2;ab++)
7773        {
7774           tempo=quprimary[2*ab-1],quprimary[2*ab],
7775                   absprimary[ab],abskeep[ab];
7776           resu[ab]=tempo;
7777        }
7778        quprimary=resu;
7779      }
7780   }
7781  //---------------------------------------------------------------------------
7782  //back to the ring we started with
7783  //the final result: primary
7784  //---------------------------------------------------------------------------
7785
7786  setring @P;
7787  option(set,op@P);
7788  primary=imap(gnir,quprimary);
7789
7790  if (intersectOption == "intersect")
7791  {
7792     return(list(primary, imap(gnir, ser)));
7793  }
7794  else
7795  {
7796    return(primary);
7797  }
7798}
7799example
7800{ "EXAMPLE:"; echo = 2;
7801   ring  r = 32003,(x,y,z),lp;
7802   poly  p = z2+1;
7803   poly  q = z4+2;
7804   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
7805   list pr= newDecompStep(i);
7806   pr;
7807   testPrimary( pr, i);
7808}
7809
7810// This was part of proc decomp.
7811// In proc newDecompStep, used for the computation of the minimal associated primes,
7812// this part was separated as a soubrutine to make the code more clear.
7813// Also, since the reduction is performed twice in proc newDecompStep, it should use both times this routine.
7814// This is not yet implemented, since the reduction is not exactly the same and some changes should be made.
7815static proc newReduction(ideal @j, ideal ser, intvec @hilb, intvec @w, int jdim, int abspri, int @wr, list data)
7816{
7817   ASSUME(1, hasFieldCoefficient(basering) );
7818   ASSUME(1, not isQuotientRing(basering) ) ;
7819   ASSUME(1, hasGlobalOrdering(basering) ) ;
7820
7821
7822   string @va;
7823   def quotring;
7824   intvec op;
7825   intvec @vv;
7826   def gnir = basering;
7827   ideal isat=0;
7828   int @n;
7829   int @n1 = 0;
7830   int @n2 = 0;
7831   int @n3 = 0;
7832   int homo = homog(@j);
7833   int lauf;
7834   int @k;
7835   list fett;
7836   int keepdi;
7837   list collectprimary;
7838   list lsau;
7839   list lnew;
7840   ideal @h;
7841
7842   list indepInfo = data[1];
7843   list quprimary = list();
7844
7845   //if(abspri)
7846   //{
7847     int ab;
7848     list absprimarytmp,abskeeptmp;
7849     list absprimary, abskeep;
7850   //}
7851   // Debug
7852   dbprint(printlevel - voice, "newReduction, v2.0");
7853
7854   if((indepInfo[1]==varstr(basering)))  // &&(@m==1)
7855   //this is the good case, nothing to do, just to have the same notations
7856   //change the ring
7857   {
7858     execute("ring gnir1 = ("+charstr(basering)+"),("+varstr(basering)+"),("
7859                              +ordstr(basering)+");");
7860     ideal @j = fetch(gnir, @j);
7861     attrib(@j,"isSB",1);
7862     ideal ser = fetch(gnir, ser);
7863   }
7864   else
7865   {
7866     @va=string(maxideal(1));
7867//Aenderung==============
7868     //if(@m==1)
7869     //{
7870     //  @j=fetch(@P,i);
7871     //}
7872//=======================
7873     execute("ring gnir1 = ("+charstr(basering)+"),("+indepInfo[1]+"),("
7874                              +indepInfo[2]+");");
7875     execute("map phi=gnir,"+@va+";");
7876     op=option(get);
7877     option(redSB);
7878     if(homo==1)
7879     {
7880       ideal @j=std(phi(@j),@hilb,@w);
7881     }
7882     else
7883     {
7884       ideal @j=groebner(phi(@j));
7885     }
7886     ideal ser=phi(ser);
7887
7888     option(set,op);
7889   }
7890   if((deg(@j[1])==0)||(dim(@j)<jdim))
7891   {
7892     setring gnir;
7893     break;
7894   }
7895   for (lauf=1;lauf<=size(@j);lauf++)
7896   {
7897     fett[lauf]=size(@j[lauf]);
7898   }
7899   //------------------------------------------------------------------------
7900   //we have now the following situation:
7901   //j intersected with K[var(nnp+1),..,var(nva)] is zero so we may pass
7902   //to this quotientring, j is their still a standardbasis, the
7903   //leading coefficients of the polynomials  there (polynomials in
7904   //K[var(nnp+1),..,var(nva)]) are collected in the list h,
7905   //we need their ggt, gh, because of the following: let
7906   //(j:gh^n)=(j:gh^infinity) then j*K(var(nnp+1),..,var(nva))[..the rest..]
7907   //intersected with K[var(1),...,var(nva)] is (j:gh^n)
7908   //on the other hand j=(j,gh^n) intersected with (j:gh^n)
7909
7910   //------------------------------------------------------------------------
7911
7912   //arrangement for quotientring K(var(nnp+1),..,var(nva))[..the rest..] and
7913   //map phi:K[var(1),...,var(nva)] --->K(var(nnpr+1),..,var(nva))[..rest..]
7914   //------------------------------------------------------------------------
7915
7916   quotring=prepareQuotientring(nvars(basering)-indepInfo[3],"lp");
7917
7918   //---------------------------------------------------------------------
7919   //we pass to the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
7920   //---------------------------------------------------------------------
7921
7922   ideal @jj=lead(@j);               //!! vorn vereinbaren
7923   setring quotring;
7924
7925   ideal @jj=imap(gnir1,@jj);
7926   @vv=clearSBNeu(@jj,fett);  //!! vorn vereinbaren
7927   setring gnir1;
7928   @k=size(@j);
7929   for (lauf=1;lauf<=@k;lauf++)
7930   {
7931     if(@vv[lauf]==1)
7932     {
7933       @j[lauf]=0;
7934     }
7935   }
7936   @j=simplify(@j,2);
7937   setring quotring;
7938   // @j considered in the quotientring
7939   ideal @j=imap(gnir1,@j);
7940
7941   ideal ser=imap(gnir1,ser);
7942
7943   kill gnir1;
7944
7945   //j is a standardbasis in the quotientring but usually not minimal
7946   //here it becomes minimal
7947
7948   attrib(@j,"isSB",1);
7949
7950   //we need later ggt(h[1],...)=gh for saturation
7951   ideal @h;
7952   if(deg(@j[1])>0)
7953   {
7954     for(@n=1;@n<=size(@j);@n++)
7955     {
7956       @h[@n]=leadcoef(@j[@n]);
7957     }
7958     //the primary decomposition of j*K(var(nnp+1),..,var(nva))[..the rest..]
7959     op=option(get);
7960     option(redSB);
7961
7962     int zeroMinAss = @wr;
7963     if (@wr == 2) {zeroMinAss = 1;}
7964     list uprimary= newZero_decomp(@j, ser, zeroMinAss);
7965
7966//HIER
7967     if(abspri)
7968     {
7969       ideal II;
7970       ideal jmap;
7971       map sigma;
7972       nn=nvars(basering);
7973       map invsigma=basering,maxideal(1);
7974       for(ab=1;ab<=size(uprimary) div 2;ab++)
7975       {
7976         II=uprimary[2*ab];
7977         attrib(II,"isSB",1);
7978         if(deg(II[1])!=vdim(II))
7979         {
7980           jmap=randomLast(50);
7981           sigma=basering,jmap;
7982           jmap[nn]=2*var(nn)-jmap[nn];
7983           invsigma=basering,jmap;
7984           II=groebner(sigma(II));
7985         }
7986         absprimarytmp[ab]= absFactorize(II[1],77);
7987         II=var(nn);
7988         abskeeptmp[ab]=string(invsigma(II));
7989         invsigma=basering,maxideal(1);
7990       }
7991     }
7992     option(set,op);
7993   }
7994   else
7995   {
7996     list uprimary;
7997     uprimary[1]=ideal(1);
7998     uprimary[2]=ideal(1);
7999   }
8000   //we need the intersection of the ideals in the list quprimary with the
8001   //polynomialring, i.e. let q=(f1,...,fr) in the quotientring such an ideal
8002   //but fi polynomials, then the intersection of q with the polynomialring
8003   //is the saturation of the ideal generated by f1,...,fr with respect to
8004   //h which is the lcm of the leading coefficients of the fi considered in
8005   //in the quotientring: this is coded in saturn
8006
8007   list saturn;
8008   ideal hpl;
8009
8010   for(@n=1;@n<=size(uprimary);@n++)
8011   {
8012     uprimary[@n]=interred(uprimary[@n]); // temporary fix
8013     hpl=0;
8014     for(@n1=1;@n1<=size(uprimary[@n]);@n1++)
8015     {
8016       hpl=hpl,leadcoef(uprimary[@n][@n1]);
8017     }
8018     saturn[@n]=hpl;
8019   }
8020
8021   //--------------------------------------------------------------------
8022   //we leave  the quotientring   K(var(nnp+1),..,var(nva))[..the rest..]
8023   //back to the polynomialring
8024   //---------------------------------------------------------------------
8025   setring gnir;
8026
8027   collectprimary=imap(quotring,uprimary);
8028   lsau=imap(quotring,saturn);
8029   @h=imap(quotring,@h);
8030
8031   kill quotring;
8032
8033   @n2=size(quprimary);
8034   @n3=@n2;
8035
8036   for(@n1=1;@n1<=size(collectprimary) div 2;@n1++)
8037   {
8038     if(deg(collectprimary[2*@n1][1])>0)
8039     {
8040       @n2++;
8041       quprimary[@n2]=collectprimary[2*@n1-1];
8042       lnew[@n2]=lsau[2*@n1-1];
8043       @n2++;
8044       lnew[@n2]=lsau[2*@n1];
8045       quprimary[@n2]=collectprimary[2*@n1];
8046       if(abspri)
8047       {
8048         absprimary[@n2 div 2]=absprimarytmp[@n1];
8049         abskeep[@n2 div 2]=abskeeptmp[@n1];
8050       }
8051     }
8052   }
8053
8054   //here the intersection with the polynomialring
8055   //mentioned above is really computed
8056   for(@n=@n3 div 2+1;@n<=@n2 div 2;@n++)
8057   {
8058     if(specialIdealsEqual(quprimary[2*@n-1],quprimary[2*@n]))
8059     {
8060       quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
8061       quprimary[2*@n]=quprimary[2*@n-1];
8062     }
8063     else
8064     {
8065       if(@wr==0)
8066       {
8067         quprimary[2*@n-1]=sat2(quprimary[2*@n-1],lnew[2*@n-1])[1];
8068       }
8069       quprimary[2*@n]=sat2(quprimary[2*@n],lnew[2*@n])[1];
8070     }
8071   }
8072
8073   return(quprimary, absprimary, abskeep, ser, @h);
8074}
8075
8076
8077////////////////////////////////////////////////////////////////////////////
8078
8079
8080
8081
8082///////////////////////////////////////////////////////////////////////////////
8083// Based on minAssGTZ
8084
8085proc minAss(ideal i,list #)
8086"USAGE:   minAss(I[, l]); i ideal, l list (optional) of parameters, same as minAssGTZ
8087RETURN:  a list, the minimal associated prime ideals of I.
8088NOTE:    Designed for characteristic 0, works also in char k > 0 based
8089         on an algorithm of Yokoyama
8090EXAMPLE: example minAss; shows an example
8091"
8092{
8093  return(minAssGTZ(i,#));
8094}
8095example
8096{ "EXAMPLE:";  echo = 2;
8097   ring  r = 0, (x, y, z), dp;
8098   poly  p = z2 + 1;
8099   poly  q = z3 + 2;
8100   ideal i = p * q^2, y - z2;
8101   list pr = minAss(i);
8102   pr;
8103}
8104
8105
8106///////////////////////////////////////////////////////////////////////////////
8107//
8108// Computes the minimal associated primes of I via Laplagne algorithm,
8109// using primary decomposition in the zero dimensional case.
8110// For reduction to the zerodimensional case, it uses the procedure
8111// decomp, with some modifications to avoid the recursion.
8112//
8113
8114static proc minAssSL(ideal I)
8115// Input = I, ideal
8116// Output = primaryDec where primaryDec is the list of the minimal
8117// associated primes and the primary components corresponding to these primes.
8118{
8119  ASSUME(1, hasFieldCoefficient(basering) );
8120  ASSUME(1, not isQuotientRing(basering) ) ;
8121  ASSUME(1, hasGlobalOrdering(basering) ) ;
8122
8123  ideal P = 1;
8124  list pd = list();
8125  int k;
8126  int stop = 0;
8127  list primaryDec = list();
8128
8129  while (stop == 0)
8130  {
8131    // Debug
8132    dbprint(printlevel - voice, "// We call minAssSLIteration to find new prime ideals!");
8133    pd = minAssSLIteration(I, P);
8134    // Debug
8135    dbprint(printlevel - voice, "// Output of minAssSLIteration:");
8136    dbprint(printlevel - voice, pd);
8137    if (size(pd[1]) > 0)
8138    {
8139      primaryDec = primaryDec + pd[1];
8140      // Debug
8141      dbprint(printlevel - voice, "// We intersect the prime ideals obtained.");
8142      P = intersect(P, pd[2]);
8143      // Debug
8144      dbprint(printlevel - voice, "// Intersection finished.");
8145    }
8146    else
8147    {
8148      stop = 1;
8149    }
8150  }
8151
8152  // Returns only the primary components, not the radical.
8153  return(primaryDec);
8154}
8155
8156///////////////////////////////////////////////////////////////////////////////
8157// Given an ideal I and an ideal P (intersection of some minimal prime ideals
8158// associated to I), it calculates new minimal prime ideals associated to I
8159// which were not used to calculate P.
8160// This version uses Primary Decomposition in the zerodimensional case.
8161static proc minAssSLIteration(ideal I, ideal P);
8162{
8163  ASSUME(1, hasFieldCoefficient(basering) );
8164  ASSUME(1, not isQuotientRing(basering) ) ;
8165  ASSUME(1, hasGlobalOrdering(basering) ) ;
8166
8167  int k = 1;
8168  int good  = 0;
8169  list primaryDec = list();
8170  // Debug
8171  dbprint (printlevel-voice, "// We search for an element in P - sqrt(I).");
8172  while ((k <= size(P)) and (good == 0))
8173  {
8174    good = 1 - rad_con(P[k], I);
8175    k++;
8176  }
8177  k--;
8178  if (good == 0)
8179  {
8180    // Debug
8181    dbprint (printlevel - voice, "// No element was found, P = sqrt(I).");
8182    return (list(primaryDec, ideal(0)));
8183  }
8184  // Debug
8185  dbprint (printlevel - voice, "// We found h = ", P[k]);
8186  dbprint (printlevel - voice, "// We calculate the saturation of I with respect to the element just founded.");
8187  ideal J = sat(I, P[k])[1];
8188
8189  // Uses decomp from primdec, modified to avoid the recursion.
8190  // Debug
8191  dbprint(printlevel - voice, "// We do the reduction to the zerodimensional case, via decomp.");
8192
8193  primaryDec = newDecompStep(J, "oneIndep", "intersect", 2);
8194  // Debug
8195  dbprint(printlevel - voice, "// Proc decomp has found", size(primaryDec) div 2, "new primary components.");
8196
8197  return(primaryDec);
8198}
8199
8200
8201
8202///////////////////////////////////////////////////////////////////////////////////
8203// Based on maxIndependSet
8204// Added list # as parameter
8205// If the first element of # is 0, the output is only 1 max indep set.
8206// If no list is specified or #[1] = 1, the output is all the max indep set of the
8207// leading terms ideal. This is the original output of maxIndependSet
8208
8209proc newMaxIndependSetLp(ideal j, list #)
8210"USAGE:   newMaxIndependentSetLp(i); i ideal (returns all maximal independent sets of the corresponding leading terms ideal)
8211          newMaxIndependentSetLp(i, 0); i ideal (returns only one maximal independent set)
8212RETURN:  list = #1. new varstring with the maximal independent set at the end,
8213                #2. ordstring with the lp ordering,
8214                #3. the number of independent variables
8215NOTE:
8216EXAMPLE: example newMaxIndependentSetLp; shows an example
8217"
8218{
8219  ASSUME(0, hasFieldCoefficient(basering) );
8220  ASSUME(0, not isQuotientRing(basering) ) ;
8221  ASSUME(0, hasGlobalOrdering(basering) ) ;
8222
8223  int n, k, di;
8224  list resu, hilf;
8225  string var1, var2;
8226  list v = indepSet(j, 0);
8227
8228  // SL 2006.04.21 1 Lines modified to use only one independent Set
8229  string indepOption;
8230  if (size(#) > 0)
8231  {
8232    indepOption = #[1];
8233  }
8234  else
8235  {
8236    indepOption = "allIndep";
8237  }
8238
8239  int nMax;
8240  if (indepOption == "allIndep")
8241  {
8242    nMax = size(v);
8243  }
8244  else
8245  {
8246    nMax = 1;
8247  }
8248
8249  for(n = 1; n <= nMax; n++)
8250  // SL 2006.04.21 2
8251  {
8252    di = 0;
8253    var1 = "";
8254    var2 = "";
8255    for(k = 1; k <= size(v[n]); k++)
8256    {
8257      if(v[n][k] != 0)
8258      {
8259        di++;
8260        var2 = var2 + "var(" + string(k) + "), ";
8261      }
8262      else
8263      {
8264        var1 = var1 + "var(" + string(k) + "), ";
8265      }
8266    }
8267    if(di > 0)
8268    {
8269      var1 = var1 + var2;
8270      var1 = var1[1..size(var1) - 2];       // The "- 2" removes the trailer comma
8271      hilf[1] = var1;
8272      // SL 2006.21.04 1 The order is now block dp instead of lp
8273      //hilf[2] = "dp(" + string(nvars(basering) - di) + "), dp(" + string(di) + ")";
8274      // SL 2006.21.04 2
8275      // For decomp, lp ordering is needed. Nothing is changed.
8276      hilf[2] = "lp";
8277      hilf[3] = di;
8278      resu[n] = hilf;
8279    }
8280    else
8281    {
8282      resu[n] = varstr(basering), ordstr(basering), 0;
8283    }
8284  }
8285  return(resu);
8286}
8287example
8288{ "EXAMPLE:"; echo = 2;
8289   ring s1 = (0, x, y), (a, b, c, d, e, f, g), lp;
8290   ideal i = ea - fbg, fa + be, ec - fdg, fc + de;
8291   i = std(i);
8292   list l = newMaxIndependSetLp(i);
8293   l;
8294   i = i, g;
8295   l = newMaxIndependSetLp(i);
8296   l;
8297
8298   ring s = 0, (x, y, z), lp;
8299   ideal i = z, yx;
8300   list l = newMaxIndependSetLp(i);
8301   l;
8302}
8303
8304
8305///////////////////////////////////////////////////////////////////////////////
8306
8307proc newZero_decomp (ideal j, ideal ser, int @wr, list #)
8308"USAGE:   newZero_decomp(j,ser,@wr); j,ser ideals, @wr=0 or 1
8309         (@wr=0 for primary decomposition, @wr=1 for computation of associated
8310         primes)
8311         if #[1] = "nest", then #[2] indicates the nest level (number of recursive calls)
8312         When the nest level is high it indicates that the computation is difficult,
8313         and different methods are applied.
8314RETURN:  list = list of primary ideals and their radicals (at even positions
8315         in the list) if the input is zero-dimensional and a standardbases
8316         with respect to lex-ordering
8317         If ser!=(0) and ser is contained in j or if j is not zero-dimen-
8318         sional then ideal(1),ideal(1) is returned
8319NOTE:    Algorithm of Gianni/Trager/Zacharias
8320EXAMPLE: example newZero_decomp; shows an example
8321"
8322{
8323  ASSUME(0, hasFieldCoefficient(basering) );
8324  ASSUME(0, not isQuotientRing(basering) ) ;
8325  ASSUME(0, hasGlobalOrdering(basering) ) ;
8326
8327  def   @P = basering;
8328  int uytrewq;
8329  int nva = nvars(basering);
8330  int @k,@s,@n,@k1,zz;
8331  list primary,lres0,lres1,act,@lh,@wh;
8332  map phi,psi,phi1,psi1;
8333  ideal jmap,jmap1,jmap2,helpprim,@qh,@qht,ser1;
8334  intvec @vh,@hilb;
8335  string @ri;
8336  poly @f;
8337
8338  // Debug
8339  dbprint(printlevel - voice, "proc newZero_decomp");
8340
8341  if (dim(j)>0)
8342  {
8343    primary[1]=ideal(1);
8344    primary[2]=ideal(1);
8345    return(primary);
8346  }
8347  j=interred(j);
8348
8349  attrib(j,"isSB",1);
8350
8351  int nestLevel = 0;
8352  if (size(#) > 0)
8353  {
8354    if (typeof(#[1]) == "string")
8355    {
8356      if (#[1] == "nest")
8357      {
8358        nestLevel = #[2];
8359      }
8360      # = list();
8361    }
8362  }
8363
8364  if(vdim(j)==deg(j[1]))
8365  {
8366    act=factor(j[1]);
8367    for(@k=1;@k<=size(act[1]);@k++)
8368    {
8369      @qh=j;
8370      if(@wr==0)
8371      {
8372        @qh[1]=act[1][@k]^act[2][@k];
8373      }
8374      else
8375      {
8376        @qh[1]=act[1][@k];
8377      }
8378      primary[2*@k-1]=interred(@qh);
8379      @qh=j;
8380      @qh[1]=act[1][@k];
8381      primary[2*@k]=interred(@qh);
8382      attrib( primary[2*@k-1],"isSB",1);
8383
8384      if((size(ser)>0)&&(size(reduce(ser,primary[2*@k-1],1))==0))
8385      {
8386        primary[2*@k-1]=ideal(1);
8387        primary[2*@k]=ideal(1);
8388      }
8389    }
8390    return(primary);
8391  }
8392
8393  if(homog(j)==1)
8394  {
8395    primary[1]=j;
8396    if((size(ser)>0)&&(size(reduce(ser,j,1))==0))
8397    {
8398      primary[1]=ideal(1);
8399      primary[2]=ideal(1);
8400      return(primary);
8401    }
8402    if(dim(j)==-1)
8403    {
8404      primary[1]=ideal(1);
8405      primary[2]=ideal(1);
8406    }
8407    else
8408    {
8409      primary[2]=maxideal(1);
8410    }
8411    return(primary);
8412  }
8413
8414//the first element in the standardbase is factorized
8415  if(deg(j[1])>0)
8416  {
8417    act=factor(j[1]);
8418    testFactor(act,j[1]);
8419  }
8420  else
8421  {
8422    primary[1]=ideal(1);
8423    primary[2]=ideal(1);
8424    return(primary);
8425  }
8426
8427//with the factors new ideals (hopefully the primary decomposition)
8428//are created
8429  if(size(act[1])>1)
8430  {
8431    if(size(#)>1)
8432    {
8433      primary[1]=ideal(1);
8434      primary[2]=ideal(1);
8435      primary[3]=ideal(1);
8436      primary[4]=ideal(1);
8437      return(primary);
8438    }
8439    for(@k=1;@k<=size(act[1]);@k++)
8440    {
8441      if(@wr==0)
8442      {
8443        primary[2*@k-1]=std(j,act[1][@k]^act[2][@k]);
8444      }
8445      else
8446      {
8447        primary[2*@k-1]=std(j,act[1][@k]);
8448      }
8449      if((act[2][@k]==1)&&(vdim(primary[2*@k-1])==deg(act[1][@k])))
8450      {
8451        primary[2*@k]   = primary[2*@k-1];
8452      }
8453      else
8454      {
8455        primary[2*@k]   = primaryTest(primary[2*@k-1],act[1][@k]);
8456      }
8457    }
8458  }
8459  else
8460  {
8461    primary[1]=j;
8462    if((size(#)>0)&&(act[2][1]>1))
8463    {
8464      act[2]=1;
8465      primary[1]=std(primary[1],act[1][1]);
8466    }
8467    if(@wr!=0)
8468    {
8469      primary[1]=std(j,act[1][1]);
8470    }
8471    if((act[2][1]==1)&&(vdim(primary[1])==deg(act[1][1])))
8472    {
8473      primary[2]=primary[1];
8474    }
8475    else
8476    {
8477      primary[2]=primaryTest(primary[1],act[1][1]);
8478    }
8479  }
8480
8481  if(size(#)==0)
8482  {
8483    primary=splitPrimary(primary,ser,@wr,act);
8484  }
8485
8486  if((voice>=6)&&(char(basering)<=181))
8487  {
8488    primary=splitCharp(primary);
8489  }
8490
8491  if((@wr==2)&&(npars(basering)>0)&&(voice>=6)&&(char(basering)>0))
8492  {
8493  //the prime decomposition of Yokoyama in characteristic p
8494    list ke,ek;
8495    @k=0;
8496    while(@k<size(primary) div 2)
8497    {
8498      @k++;
8499      if(size(primary[2*@k])==0)
8500      {
8501        ek=insepDecomp(primary[2*@k-1]);
8502        primary=delete(primary,2*@k);
8503        primary=delete(primary,2*@k-1);
8504        @k--;
8505      }
8506      ke=ke+ek;
8507    }
8508    for(@k=1;@k<=size(ke);@k++)
8509    {
8510      primary[size(primary)+1]=ke[@k];
8511      primary[size(primary)+1]=ke[@k];
8512    }
8513  }
8514
8515  if(nestLevel > 1){primary=extF(primary);}
8516
8517//test whether all ideals in the decomposition are primary and
8518//in general position
8519//if not after a random coordinate transformation of the last
8520//variable the corresponding ideal is decomposed again.
8521  if((npars(basering)>0)&&(nestLevel > 1))
8522  {
8523    poly randp;
8524    for(zz=1;zz<nvars(basering);zz++)
8525    {
8526      randp=randp
8527              +(random(0,5)*par(1)^2+random(0,5)*par(1)+random(0,5))*var(zz);
8528    }
8529    randp=randp+var(nvars(basering));
8530  }
8531  @k=0;
8532  while(@k<(size(primary) div 2))
8533  {
8534    @k++;
8535    if (size(primary[2*@k])==0)
8536    {
8537      for(zz=1;zz<size(primary[2*@k-1])-1;zz++)
8538      {
8539        attrib(primary[2*@k-1],"isSB",1);
8540        if(vdim(primary[2*@k-1])==deg(primary[2*@k-1][zz]))
8541        {
8542          primary[2*@k]=primary[2*@k-1];
8543        }
8544      }
8545    }
8546  }
8547
8548  @k=0;
8549  ideal keep;
8550  while(@k<(size(primary) div 2))
8551  {
8552    @k++;
8553    if (size(primary[2*@k])==0)
8554    {
8555      jmap=randomLast(100);
8556      jmap1=maxideal(1);
8557      jmap2=maxideal(1);
8558      @qht=primary[2*@k-1];
8559      if((npars(basering)>0)&&(nestLevel > 1))
8560      {
8561        jmap[size(jmap)]=randp;
8562      }
8563
8564      for(@n=2;@n<=size(primary[2*@k-1]);@n++)
8565      {
8566        if(deg(lead(primary[2*@k-1][@n]))==1)
8567        {
8568          for(zz=1;zz<=nva;zz++)
8569          {
8570            if(lead(primary[2*@k-1][@n])/var(zz)!=0)
8571            {
8572              jmap1[zz]=-1/leadcoef(primary[2*@k-1][@n])*primary[2*@k-1][@n]
8573                   +2/leadcoef(primary[2*@k-1][@n])*lead(primary[2*@k-1][@n]);
8574              jmap2[zz]=primary[2*@k-1][@n];
8575              @qht[@n]=var(zz);
8576            }
8577          }
8578          jmap[nva]=subst(jmap[nva],lead(primary[2*@k-1][@n]),0);
8579        }
8580      }
8581      if(size(subst(jmap[nva],var(1),0)-var(nva))!=0)
8582      {
8583        // jmap[nva]=subst(jmap[nva],var(1),0);
8584        //hier geaendert +untersuchen!!!!!!!!!!!!!!
8585      }
8586      phi1=@P,jmap1;
8587      phi=@P,jmap;
8588      for(@n=1;@n<=nva;@n++)
8589      {
8590        jmap[@n]=-(jmap[@n]-2*var(@n));
8591      }
8592      psi=@P,jmap;
8593      psi1=@P,jmap2;
8594      @qh=phi(@qht);
8595
8596//=================== the new part ============================
8597
8598      if (npars(basering)>1) { @qh=groebner(@qh,"par2var"); }
8599      else                   { @qh=groebner(@qh); }
8600
8601//=============================================================
8602//       if(npars(@P)>0)
8603//       {
8604//          @ri= "ring @Phelp ="
8605//                  +string(char(@P))+",
8606//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
8607//       }
8608//       else
8609//       {
8610//          @ri= "ring @Phelp ="
8611//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
8612//       }
8613//       execute(@ri);
8614//       ideal @qh=homog(imap(@P,@qht),@t);
8615//
8616//       ideal @qh1=std(@qh);
8617//       @hilb=hilb(@qh1,1);
8618//       @ri= "ring @Phelp1 ="
8619//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
8620//       execute(@ri);
8621//       ideal @qh=homog(imap(@P,@qh),@t);
8622//       kill @Phelp;
8623//       @qh=std(@qh,@hilb);
8624//       @qh=subst(@qh,@t,1);
8625//       setring @P;
8626//       @qh=imap(@Phelp1,@qh);
8627//       kill @Phelp1;
8628//       @qh=clearSB(@qh);
8629//       attrib(@qh,"isSB",1);
8630//=============================================================
8631
8632      ser1=phi1(ser);
8633      @lh=newZero_decomp (@qh,phi(ser1),@wr, list("nest", nestLevel + 1));
8634
8635      kill lres0;
8636      list lres0;
8637      if(size(@lh)==2)
8638      {
8639        helpprim=@lh[2];
8640        lres0[1]=primary[2*@k-1];
8641        attrib(lres0[1],"isSB",1);
8642        ser1=psi(helpprim);
8643        lres0[2]=psi1(ser1);
8644        if(size(reduce(lres0[2],lres0[1],1))==0)
8645        {
8646          primary[2*@k]=primary[2*@k-1];
8647          continue;
8648        }
8649      }
8650      else
8651      {
8652        lres1=psi(@lh);
8653        lres0=psi1(lres1);
8654      }
8655
8656//=================== the new part ============================
8657
8658      primary=delete(primary,2*@k-1);
8659      primary=delete(primary,2*@k-1);
8660      @k--;
8661      if(size(lres0)==2)
8662      {
8663        if (npars(basering)>1) { lres0[2]=groebner(lres0[2],"par2var"); }
8664        else                   { lres0[2]=groebner(lres0[2]); }
8665      }
8666      else
8667      {
8668        for(@n=1;@n<=size(lres0) div 2;@n++)
8669        {
8670          if(specialIdealsEqual(lres0[2*@n-1],lres0[2*@n])==1)
8671          {
8672            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
8673            lres0[2*@n]=lres0[2*@n-1];
8674            attrib(lres0[2*@n],"isSB",1);
8675          }
8676          else
8677          {
8678            lres0[2*@n-1]=groebner(lres0[2*@n-1]);
8679            lres0[2*@n]=groebner(lres0[2*@n]);
8680          }
8681        }
8682      }
8683      primary=primary+lres0;
8684
8685//=============================================================
8686//       if(npars(@P)>0)
8687//       {
8688//          @ri= "ring @Phelp ="
8689//                  +string(char(@P))+",
8690//                   ("+varstr(@P)+","+parstr(@P)+",@t),(C,dp);";
8691//       }
8692//       else
8693//       {
8694//          @ri= "ring @Phelp ="
8695//                  +string(char(@P))+",("+varstr(@P)+",@t),(C,dp);";
8696//       }
8697//       execute(@ri);
8698//       list @lvec;
8699//       list @lr=imap(@P,lres0);
8700//       ideal @lr1;
8701//
8702//       if(size(@lr)==2)
8703//       {
8704//          @lr[2]=homog(@lr[2],@t);
8705//          @lr1=std(@lr[2]);
8706//          @lvec[2]=hilb(@lr1,1);
8707//       }
8708//       else
8709//       {
8710//          for(@n=1;@n<=size(@lr) div 2;@n++)
8711//          {
8712//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
8713//             {
8714//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
8715//                @lr1=std(@lr[2*@n-1]);
8716//                @lvec[2*@n-1]=hilb(@lr1,1);
8717//                @lvec[2*@n]=@lvec[2*@n-1];
8718//             }
8719//             else
8720//             {
8721//                @lr[2*@n-1]=homog(@lr[2*@n-1],@t);
8722//                @lr1=std(@lr[2*@n-1]);
8723//                @lvec[2*@n-1]=hilb(@lr1,1);
8724//                @lr[2*@n]=homog(@lr[2*@n],@t);
8725//                @lr1=std(@lr[2*@n]);
8726//                @lvec[2*@n]=hilb(@lr1,1);
8727//
8728//             }
8729//         }
8730//       }
8731//       @ri= "ring @Phelp1 ="
8732//                  +string(char(@P))+",("+varstr(@Phelp)+"),(C,lp);";
8733//       execute(@ri);
8734//       list @lr=imap(@Phelp,@lr);
8735//
8736//       kill @Phelp;
8737//       if(size(@lr)==2)
8738//      {
8739//          @lr[2]=std(@lr[2],@lvec[2]);
8740//          @lr[2]=subst(@lr[2],@t,1);
8741//
8742//       }
8743//       else
8744//       {
8745//          for(@n=1;@n<=size(@lr) div 2;@n++)
8746//          {
8747//             if(specialIdealsEqual(@lr[2*@n-1],@lr[2*@n])==1)
8748//             {
8749//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
8750//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
8751//                @lr[2*@n]=@lr[2*@n-1];
8752//                attrib(@lr[2*@n],"isSB",1);
8753//             }
8754//             else
8755//             {
8756//                @lr[2*@n-1]=std(@lr[2*@n-1],@lvec[2*@n-1]);
8757//                @lr[2*@n-1]=subst(@lr[2*@n-1],@t,1);
8758//                @lr[2*@n]=std(@lr[2*@n],@lvec[2*@n]);
8759//                @lr[2*@n]=subst(@lr[2*@n],@t,1);
8760//             }
8761//          }
8762//       }
8763//       kill @lvec;
8764//       setring @P;
8765//       lres0=imap(@Phelp1,@lr);
8766//       kill @Phelp1;
8767//       for(@n=1;@n<=size(lres0);@n++)
8768//       {
8769//          lres0[@n]=clearSB(lres0[@n]);
8770//          attrib(lres0[@n],"isSB",1);
8771//       }
8772//
8773//       primary[2*@k-1]=lres0[1];
8774//       primary[2*@k]=lres0[2];
8775//       @s=size(primary) div 2;
8776//       for(@n=1;@n<=size(lres0) div 2-1;@n++)
8777//       {
8778//         primary[2*@s+2*@n-1]=lres0[2*@n+1];
8779//         primary[2*@s+2*@n]=lres0[2*@n+2];
8780//       }
8781//       @k--;
8782//=============================================================
8783    }
8784  }
8785  return(primary);
8786}
8787example
8788{ "EXAMPLE:"; echo = 2;
8789   ring  r = 0,(x,y,z),lp;
8790   poly  p = z2+1;
8791   poly  q = z4+2;
8792   ideal i = p^2*q^3,(y-z3)^3,(x-yz+z4)^4;
8793   i=std(i);
8794   list  pr= newZero_decomp(i,ideal(0),0);
8795   pr;
8796}
8797///////////////////////////////////////////////////////////////////////////////
8798
8799////////////////////////////////////////////////////////////////////////////
8800/*
8801//Beispiele Wenk-Dipl (in ~/Texfiles/Diplom/Wenk/Examples/)
8802//Zeiten: Singular/Singular/Singular -r123456789 -v :wilde13 (PentiumPro200)
8803//Singular for HPUX-9 version 1-3-8  (2000060214)  Jun  2 2000 15:31:26
8804//(wilde13)
8805
8806//1. vdim=20, 3  Komponenten
8807//zerodec-time:2(1)  (matrix:1 charpoly:0 factor:1)
8808//primdecGTZ-time: 1(0)
8809ring rs= 0,(a,b,c),dp;
8810poly f1= a^2*b*c + a*b^2*c + a*b*c^2 + a*b*c + a*b + a*c + b*c;
8811poly f2= a^2*b^2*c + a*b^2*c^2 + a^2*b*c + a*b*c + b*c + a + c;
8812poly f3= a^2*b^2*c^2 + a^2*b^2*c + a*b^2*c + a*b*c + a*c + c + 1;
8813ideal gls=f1,f2,f3;
8814int time=timer;
8815printlevel =1;
8816time=timer; list pr1=zerodec(gls); timer-time;size(pr1);
8817time=timer; list pr =primdecGTZ(gls); timer-time;size(pr);
8818time=timer; ideal ra =radical(gls); timer-time;size(pr);
8819
8820//2.cyclic5  vdim=70, 20 Komponenten
8821//zerodec-time:36(28)  (matrix:1(0) charpoly:18(19) factor:17(9)
8822//primdecGTZ-time: 28(5)
8823//radical : 0
8824ring rs= 0,(a,b,c,d,e),dp;
8825poly f0= a + b + c + d + e + 1;
8826poly f1= a + b + c + d + e;
8827poly f2= a*b + b*c + c*d + a*e + d*e;
8828poly f3= a*b*c + b*c*d + a*b*e + a*d*e + c*d*e;
8829poly f4= a*b*c*d + a*b*c*e + a*b*d*e + a*c*d*e + b*c*d*e;
8830poly f5= a*b*c*d*e - 1;
8831ideal gls= f1,f2,f3,f4,f5;
8832
8833//3. random vdim=40, 1 Komponente
8834//zerodec-time:126(304)  (matrix:1 charpoly:115(298) factor:10(5))
8835//primdecGTZ-time:17 (11)
8836ring rs=0,(x,y,z),dp;
8837poly f1=2*x^2 + 4*x + 3*y^2 + 7*x*z + 9*y*z + 5*z^2;
8838poly f2=7*x^3 + 8*x*y + 12*y^2 + 18*x*z + 3*y^4*z + 10*z^3 + 12;
8839poly f3=3*x^4 + 1*x*y*z + 6*y^3 + 3*x*z^2 + 2*y*z^2 + 4*z^2 + 5;
8840ideal gls=f1,f2,f3;
8841
8842//4. introduction into resultants, sturmfels, vdim=28, 1 Komponente
8843//zerodec-time:4  (matrix:0 charpoly:0 factor:4)
8844//primdecGTZ-time:1
8845ring rs=0,(x,y),dp;
8846poly f1= x4+y4-1;
8847poly f2= x5y2-4x3y3+x2y5-1;
8848ideal gls=f1,f2;
8849
8850//5. 3 quadratic equations with random coeffs, vdim=8, 1 Komponente
8851//zerodec-time:0(0)  (matrix:0 charpoly:0 factor:0)
8852//primdecGTZ-time:1(0)
8853ring rs=0,(x,y,z),dp;
8854poly f1=2*x^2 + 4*x*y + 3*y^2 + 7*x*z + 9*y*z + 5*z^2 + 2;
8855poly f2=7*x^2 + 8*x*y + 12*y^2 + 18*x*z + 3*y*z + 10*z^2 + 12;
8856poly f3=3*x^2 + 1*x*y + 6*y^2 + 3*x*z + 2*y*z + 4*z^2 + 5;
8857ideal gls=f1,f2,f3;
8858
8859//6. 3 polys    vdim=24, 1 Komponente
8860// run("ex14",2);
8861//zerodec-time:5(4)  (matrix:0 charpoly:3(3) factor:2(1))
8862//primdecGTZ-time:4 (2)
8863ring rs=0,(x1,x2,x3,x4),dp;
8864poly f1=16*x1^2 + 3*x2^2 + 5*x3^4 - 1 - 4*x4 + x4^3;
8865poly f2=5*x1^3 + 3*x2^2 + 4*x3^2*x4 + 2*x1*x4 - 1 + x4 + 4*x1 + x2 + x3 + x4;
8866poly f3=-4*x1^2 + x2^2 + x3^2 - 3 + x4^2 + 4*x1 + x2 + x3 + x4;
8867poly f4=-4*x1 + x2 + x3 + x4;
8868ideal gls=f1,f2,f3,f4;
8869
8870//7. ex43, PoSSo, caprasse   vdim=56, 16 Komponenten
8871//zerodec-time:23(15)  (matrix:0 charpoly:16(13) factor:3(2))
8872//primdecGTZ-time:3 (2)
8873ring rs= 0,(y,z,x,t),dp;
8874ideal gls=y^2*z+2*y*x*t-z-2*x,
88754*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,
88762*y*z*t+x*t^2-2*z-x,
8877-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;
8878
8879//8. Arnborg-System, n=6 (II),    vdim=156, 90 Komponenten
8880//zerodec-time (char32003):127(45)(matrix:2(0) charpoly:106(37) factor:16(7))
8881//primdecGTZ-time(char32003) :81 (18)
8882//ring rs= 0,(a,b,c,d,x,f),dp;
8883ring rs= 32003,(a,b,c,d,x,f),dp;
8884ideal gls=a+b+c+d+x+f, ab+bc+cd+dx+xf+af, abc+bcd+cdx+d*xf+axf+abf,
8885abcd+bcdx+cd*xf+ad*xf+abxf+abcf, abcdx+bcd*xf+acd*xf+abd*xf+abcxf+abcdf,
8886abcd*xf-1;
8887
8888//9. ex42, PoSSo, Methan6_1, vdim=27, 2 Komponenten
8889//zerodec-time:610  (matrix:10 charpoly:557 factor:26)
8890//primdecGTZ-time: 118
8891//zerodec-time(char32003):2
8892//primdecGTZ-time(char32003):4
8893//ring rs= 0,(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10),dp;
8894ring rs= 32003,(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10),dp;
8895ideal gls=64*x2*x7-10*x1*x8+10*x7*x9+11*x7*x10-320000*x1,
8896-32*x2*x7-5*x2*x8-5*x2*x10+160000*x1-5000*x2,
8897-x3*x8+x6*x8+x9*x10+210*x6+1300000,
8898-x4*x8+700000,
8899x10^2-2*x5,
8900-x6*x8+x7*x9-210*x6,
8901-64*x2*x7-10*x7*x9-11*x7*x10+320000*x1-16*x7+7000000,
8902-10*x1*x8-10*x2*x8-10*x3*x8-10*x4*x8-10*x6*x8+10*x2*x10+11*x7*x10
8903    +20000*x2+14*x5,
8904x4*x8-x7*x9-x9*x10-410*x9,
890510*x2*x8+10*x3*x8+10*x6*x8+10*x7*x9-10*x2*x10-11*x7*x10-10*x9*x10
8906    -10*x10^2+1400*x6-4200*x10;
8907
8908//10. ex33, walk-s7, Diplomarbeit von Tim, vdim=114
8909//zerfaellt in unterschiedlich viele Komponenten in versch. Charkteristiken:
8910//char32003:30, char0:3(2xdeg1,1xdeg112!), char181:4(2xdeg1,1xdeg28,1xdeg84)
8911//char 0: zerodec-time:10075 (ca 3h) (matrix:3 charpoly:9367, factor:680
8912//        + 24 sec fuer Normalform (anstatt einsetzen), total [29623k])
8913//        primdecGTZ-time: 214
8914//char 32003:zerodec-time:197(68) (matrix:2(1) charpoly:173(60) factor:15(6))
8915//        primdecGTZ-time:14 (5)
8916//char 181:zerodec-time:(87) (matrix:(1) charpoly:(58) factor:(25))
8917//        primdecGTZ-time:(2)
8918//in char181 stimmen Ergebnisse von zerodec und primdecGTZ ueberein (gecheckt)
8919
8920//ring rs= 0,(a,b,c,d,e,f,g),dp;
8921ring rs= 32003,(a,b,c,d,e,f,g),dp;
8922poly f1= 2gb + 2fc + 2ed + a2 + a;
8923poly f2= 2gc + 2fd + e2 + 2ba + b;
8924poly f3= 2gd + 2fe + 2ca + c + b2;
8925poly f4= 2ge + f2 + 2da + d + 2cb;
8926poly f5= 2fg + 2ea + e + 2db + c2;
8927poly f6= g2 + 2fa + f + 2eb + 2dc;
8928poly f7= 2ga + g + 2fb + 2ec + d2;
8929ideal gls= f1,f2,f3,f4,f5,f6,f7;
8930
8931~/Singular/Singular/Singular -r123456789 -v
8932LIB"./primdec.lib";
8933timer=1;
8934int time=timer;
8935printlevel =1;
8936option(prot,mem);
8937time=timer; list pr1=zerodec(gls); timer-time;
8938
8939time=timer; list pr =primdecGTZ(gls); timer-time;
8940time=timer; list pr =primdecSY(gls); timer-time;
8941time=timer; ideal ra =radical(gls); timer-time;size(pr);
8942LIB"all.lib";
8943
8944ring R=0,(a,b,c,d,e,f),dp;
8945ideal I=cyclic(6);
8946minAssGTZ(I);
8947
8948
8949ring S=(2,a,b),(x,y),lp;
8950ideal I=x8-b,y4+a;
8951minAssGTZ(I);
8952
8953ring S1=2,(x,y,a,b),lp;
8954ideal I=x8-b,y4+a;
8955minAssGTZ(I);
8956
8957
8958ring S2=(2,z),(x,y),dp;
8959minpoly=z2+z+1;
8960ideal I=y3+y+1,x4+x+1;
8961primdecGTZ(I);
8962minAssGTZ(I);
8963
8964ring S3=2,(x,y,z),dp;
8965ideal I=y3+y+1,x4+x+1,z2+z+1;
8966primdecGTZ(I);
8967minAssGTZ(I);
8968
8969
8970ring R1=2,(x,y,z),lp;
8971ideal I=y6+y5+y3+y2+1,x4+x+1,z2+z+1;
8972primdecGTZ(I);
8973minAssGTZ(I);
8974
8975
8976ring R2=(2,z),(x,y),lp;
8977minpoly=z3+z+1;
8978ideal I=y2+y+(z2+z+1),x4+x+1;
8979primdecGTZ(I);
8980minAssGTZ(I);
8981
8982*/
Note: See TracBrowser for help on using the repository browser.