source: git/Singular/LIB/primdec.lib @ 67b671

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