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

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