source: git/Singular/LIB/primdec.lib @ 9e0e2b

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