source: git/Singular/LIB/primdec.lib @ 2fa80a

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