source: git/Singular/LIB/grobcov.lib @ 1f9a84

jengelh-datetimespielwiese
Last change on this file since 1f9a84 was 1f9a84, checked in by Hans Schoenemann <hannes@…>, 12 years ago
more int division from the manual git-svn-id: file:///usr/local/Singular/svn/trunk@14203 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 209.5 KB
Line 
1//////////////////////////////////////////////////////////////////////////////
2version="$Id$";
3category="General purpose";
4info="
5LIBRARY:  grobcov.lib   Groebner Cover for parametric ideals.
6PURPOSE:  Comprehensive Groebner Systems, Groebner Cover, Canonical Forms.
7          The library contains Montes's algorithms to compute the
8          canonical Groebner cover of a parametric ideal as described in
9          the paper:
10
11          Montes A., Wibmer M.,
12          Groebner Bases for Polynomial Systems with parameters.
13          Journal of Symbolic Computation 45 (2010) 1391-1425.
14
15          The central routine is grobcov. Given a parametric
16          ideal, grobcov outputs its canonical Groebner cover, consisting
17          of a set of pairs of (basis, segment). The basis (after
18          normalization) is the reduced Groebner basis for each point
19          of the segment. The segments are disjoint, locally closed
20          and correspond to constant lpp (leading power product)
21          of the basis, and are represented in canonical prime
22          representation. The segments are disjoint and cover the
23          whole parameter space. The output is canonical, it only
24          depends on the given parametric ideal and the monomial order.
25          This is much more than a simple comprehensive Groebner system.
26          The algorithm grobcov allows options to solve partially the
27          problem when the whole automatic algorithm does not finish
28          in reasonable time.
29
30          grobcov uses a first algorithm cgsdr that outputs a disjoint
31          reduced comprehensive Groebner system with constant lpp.
32          cgsdr can be called directly if only a disjoint reduced
33          comprehensive Groebner system is required.
34
35          Two other routines: gencase1 and multigrobcov can be used
36          in problems with basis of the generic case equal to 1
37          (for example in automatic geometric theorem discovering)
38          that allow to obtain partial results even when grobcov does
39          not finish in reasonable time.
40
41          For completeness, the library also contains the algorithms
42          with similar purposes contained in the old library redcgs.lib.
43          These algorithms are, in general, less efficient and do not
44          ensure a canonical results, even if they are similar to the
45          results obtained with grobcov.
46          The old routines are no more recommended and remain in
47          this library for didactic purposes. These are
48          cgsdrold, grobcovold, buildtreetoMaple, cantreetoMaple.
49
50AUTHORS:  Antonio Montes , Hans Schoenemann.
51OVERVIEW: see \"Groebner Bases for Polynomial Systems with parameters\"
52          Montes A., Wibmer M.,
53          Journal of Symbolic Computation 45 (2010) 1391-1425.
54          (http://www-ma2.upc.edu/~montes/).
55
56NOTATIONS: All given and determined polynomials and ideals are in the
57@*         basering Q[a][x]; (a=parameters, x=variables)
58@*         After defining the ring, the main routines
59@*         grobcov, cgsdr, gencase1, multigrobcov
60@*         generate the global rings
61@*         @R   (Q[a][x]),
62@*         @P   (Q[a]),
63@*         @RP  (Q[x,a])
64@*         that are used inside and killed before the output.
65@*         If you want to use some internal routine you must
66@*         create before the above rings by calling setglobalrings();
67@*         because most of the internal routines use these rings.
68@*         The call to the basic routines grobcov, cgsdr, gencase1, multigrobcov
69@*         or even the older grobcovold, cgsdrold will kill these rings.
70
71PROCEDURES:
72
73grobcov(F);          Is the basic routine giving the canonical
74                     Groebner cover of the parametric ideal F.
75                     This routine accepts many options, that
76                     allow to obtain results even when the canonical
77                     computation does not finish in reasonable time.
78
79cgsdr(F);            Is the procedure for obtaining a first disjoint,
80                     reduced comprehensive Groebner system that
81                     is used in grobcov, but that can be used
82                     independently if only the CGS is required.
83                     It is a more efficient version of buildtree
84                     that does not output the complete discussion tree
85                     but only the terminal vertices giving the
86                     disjoint reduced comprehensive Groebner system.
87
88gencase1(F);         Returns the segment of the generic case when his
89                     basis is 1. This is useful for automatic discovering
90                     of geometrical theorems, as it gives the components
91                     where a solution exists and is much more efficient
92                     than the complete computation of grobcov.
93
94multigrobcov(F);     In problems like automatic discovery of theorems,
95                     when grobcov does not give the answer in reasonable
96                     time, and the generic case is expected to
97                     have basis 1, one can try with multigrobcov procedure
98                     to obtain an answer over the different irreducible
99                     components: the generic case with basis 1, and the
100                     components not corresponding to the generic case. To
101                     deduce from its result the true Groebner cover one
102                     must discuss theoretically in which segment
103                     must be located the intersecting parts in the
104                     different irreducible components.
105
106setglobalrings();    Generates the global rings @R, @P and @PR that are
107                     respectively the rings Q[a][x], Q[a], Q[x,a].
108                     It is called inside each of the fundamental routines of the
109                     library: grobcov, cgsdr, gencase1, multigrobcov, as well as
110                     by the old routines cgsdrold, grobcovold and killed
111                     before the output.
112                     If the user want to use some other internal routine,
113                     then setglobalrings() is to be called before, as
114                     the rings @R, @P and @RP are needed in most of them.
115                     globally, and more internal routines can be used, but
116                     These rings are destroyed by the call to any of the basic
117                     routines.
118
119pdivi(f,F);          Performs a pseudodivision of a parametric polynomial
120                     by a parametric ideal.
121
122pnormalform(f,N,W);  Reduces a parametric polynomial f by a reduced-representation
123                     (N,W) of null and non-null conditions over the parameters.
124                     Before using it setglobalrings() must be called.
125
126Also included from the old library redcgs.lib the following routines
127
128cgsdrold(F);         Similar to cgsdr using the algorithm buildtree
129                     of the old library.
130grobcovold(F);       Similar to grobcov with the algorithms of the old
131                     library.
132buildtreetoMaple(T); Writes into a file the output of cgsdrold called
133                     with option ('old',0) into a text file that is Maple
134                     readable and can be plotted in Maple using
135                     the tplot routine of the library dpgb.
136cantreetoMaple(M);   Writes into a text file the output of grobcovold called
137                     with  option ('out',1), that is readable
138                     in Maple and can be plotted using the routine
139                     plotcantree of the Maple library dpgb.
140
141SEE ALSO: compregb_lib
142";
143
144LIB "primdec.lib";
145LIB "qhmoduli.lib";
146
147// ************ Begin of the grobcov library *********************
148
149// Library grobcov.lib
150// (Groebner cover):
151// Initial data: 6-9-2009
152// Release 1:
153// Final data: 30-12-2010
154// Contains also the old redcgs.lib library that was created
155// Initial data: 21-1-2008
156// Release 1:
157// Final data: 3-7-2008
158// Given and determined polynomials and ideals are in the
159// basering Q[a][x];
160
161// ************ Begin of buildtree ******************************
162
163proc setglobalrings()
164"USAGE:   setglobalrings();
165          No arguments
166RETURN:   After its call the rings @R=Q[a][x], @P=Q[a], @RP=Q[x,a] are
167          defined as global variables.
168NOTE:     It is called internally by the fundamental routines of the
169          library grobcov, cgsdr, gencase1, muligrobcov as well as by the
170          old ones grobcovold,cgsdrold, and killed before the output.
171          The user does not need to call it, except when it is interested
172          in using some internal routine of the library that
173          uses these rings.
174          The basering R, must be of the form Q[a][x], a=parameters,
175          x=variables, and should be defined previously.
176KEYWORDS: ring, rings
177EXAMPLE:  setglobalrings; shows an example"
178{
179  if (defined(@P)==1)
180  {
181    kill @P; kill @R; kill @RP;
182  }
183  def RR=basering;
184  def @R=basering;  // must be of the form K[a][x], a=parameters, x=variables
185  def Rx=ringlist(RR);
186  def @P=ring(Rx[1]);
187  list Lx;
188  Lx[1]=0;
189  Lx[2]=Rx[2]+Rx[1][2];
190  Lx[3]=Rx[1][3];
191  Lx[4]=Rx[1][4];
192  Rx[1]=0;
193  def D=ring(Rx);
194  def @RP=D+@P;
195  exportto(Top,@R);      // global ring K[a][x]
196  exportto(Top,@P);      // global ring K[a]
197  exportto(Top,@RP);     // global ring K[x,a] with product order
198  setring(RR);
199}
200example
201{ "EXAMPLE:"; echo = 2;
202  ring R=(0,a,b),(x,y,z),dp;
203  setglobalrings();
204  @R;
205  @P;
206  @RP;
207}
208
209//*************Auxilliary routines**************
210
211// cld : clears denominators of an ideal and normalizes to content 1
212//       can be used in @R or @P or @RP
213// input:
214//    ideal J (J can be also poly), but the output is an ideal;
215// output:
216//    ideal Jc (the new form of ideal J without denominators and
217//       normalized to content 1)
218static proc cld(ideal J)
219{
220  if (size(J)==0){return(ideal(0));}
221  def RR=basering;
222  setring(@RP);
223  def Ja=imap(RR,J);
224  ideal Jb;
225  if (size(Ja)==0){return(ideal(0));}
226  int i;
227  def j=0;
228  for (i=1;i<=ncols(Ja);i++){if (size(Ja[i])!=0){j++; Jb[j]=cleardenom(Ja[i]);}}
229  setring(RR);
230  def Jc=imap(@RP,Jb);
231  return(Jc);
232}
233
234static proc memberpos(f,J)
235//"USAGE:  memberpos(f,J);
236//         (f,J) expected (polynomial,ideal)
237//               or       (int,list(int))
238//               or       (int,intvec)
239//               or       (intvec,list(intvec))
240//               or       (list(int),list(list(int)))
241//               or       (ideal,list(ideal))
242//               or       (list(intvec),  list(list(intvec))).
243//         The ring can be @R or @P or @RP or any other.
244//RETURN:  The list (t,pos) t int; pos int;
245//         t is 1 if f belongs to J and 0 if not.
246//         pos gives the position in J (or 0 if f does not belong).
247//EXAMPLE: memberpos; shows an example"
248{
249  int pos=0;
250  int i=1;
251  int j;
252  int t=0;
253  int nt;
254  if (typeof(J)=="ideal"){nt=ncols(J);}
255  else{nt=size(J);}
256  if ((typeof(f)=="poly") or (typeof(f)=="int"))
257  { // (poly,ideal)  or
258    // (poly,list(poly))
259    // (int,list(int)) or
260    // (int,intvec)
261    i=1;
262    while(i<=nt)
263    {
264      if (f==J[i]){return(list(1,i));}
265      i++;
266    }
267    return(list(0,0));
268  }
269  else
270  {
271    if ((typeof(f)=="intvec") or ((typeof(f)=="list") and (typeof(f[1])=="int")))
272    { // (intvec,list(intvec)) or
273      // (list(int),list(list(int)))
274      i=1;
275      t=0;
276      pos=0;
277      while((i<=nt) and (t==0))
278      {
279        t=1;
280        j=1;
281        if (size(f)!=size(J[i])){t=0;}
282        else
283        {
284          while ((j<=size(f)) and t)
285          {
286            if (f[j]!=J[i][j]){t=0;}
287            j++;
288          }
289        }
290        if (t){pos=i;}
291        i++;
292      }
293      if (t){return(list(1,pos));}
294      else{return(list(0,0));}
295    }
296    else
297    {
298      if (typeof(f)=="ideal")
299      { // (ideal,list(ideal))
300        i=1;
301        t=0;
302        pos=0;
303        while((i<=nt) and (t==0))
304        {
305          t=1;
306          j=1;
307          if (ncols(f)!=ncols(J[i])){t=0;}
308          else
309          {
310            while ((j<=ncols(f)) and t)
311            {
312              if (f[j]!=J[i][j]){t=0;}
313              j++;
314            }
315          }
316          if (t){pos=i;}
317          i++;
318        }
319        if (t){return(list(1,pos));}
320        else{return(list(0,0));}
321      }
322      else
323      {
324        if ((typeof(f)=="list") and (typeof(f[1])=="intvec"))
325        { // (list(intvec),list(list(intvec)))
326          i=1;
327          t=0;
328          pos=0;
329          while((i<=nt) and (t==0))
330          {
331            t=1;
332            j=1;
333            if (size(f)!=size(J[i])){t=0;}
334            else
335            {
336              while ((j<=size(f)) and t)
337              {
338                if (f[j]!=J[i][j]){t=0;}
339                j++;
340              }
341            }
342            if (t){pos=i;}
343            i++;
344          }
345          if (t){return(list(1,pos));}
346          else{return(list(0,0));}
347        }
348      }
349    }
350  }
351}
352//example
353//{ "EXAMPLE:"; echo = 2;
354//  list L=(7,4,5,1,1,4,9);
355//  memberpos(1,L);
356//  >
357//}
358
359
360static proc subset(J,K)
361//"USAGE:   subset(J,K);
362//          (J,K)  expected (ideal,ideal)
363//                   or     (list, list)
364//RETURN:   1 if all the elements of J are in K, 0 if not.
365//EXAMPLE:  subset; shows an example;"
366{
367  int i=1;
368  int nt;
369  if (typeof(J)=="ideal"){nt=ncols(J);}
370  else{nt=size(J);}
371  if (size(J)==0){return(1);}
372  while(i<=nt)
373  {
374    if (memberpos(J[i],K)[1]){i++;}
375    else {return(0);}
376  }
377  return(1);
378}
379//example
380//{ "EXAMPLE:"; echo = 2;
381//  list J=list(7,3,2);
382//  list K=list(1,2,3,5,7,8);
383//  subset(J,K);
384//}
385
386// elimintfromideal: elimine the constant numbers from an ideal
387//     (designed for W, nonnull conditions)
388// input: ideal J
389// output:ideal K with the elements of J that are non constants, in the ring @P
390static proc elimintfromideal(ideal J)
391{
392  int i;
393  int j=0;
394  ideal K;
395  if (size(J)==0){return(ideal(0));}
396  for (i=1;i<=ncols(J);i++){if (size(variables(J[i])) !=0){j++; K[j]=J[i];}}
397  return(K);
398}
399
400// simpqcoeffs : simplifies a quotient of two polynomials
401// input: two coeficients (or terms), that are considered as a quotient
402// output: the two coeficients reduced without common factors
403static proc simpqcoeffs(poly n,poly m)
404{
405  def nc=content(n);
406  def mc=content(m);
407  def gc=gcd(nc,mc);
408  ideal s=n/gc,m/gc;
409  return (s);
410}
411
412// pdivi : pseudodivision of a poly f by an ideal F in a parametric ideal
413//         Q[a][x]
414// input:
415//   poly f0  (in the parametric ring @R)
416//   ideal F0 (in the parametric ring @R)
417// output:
418//   list (poly r, ideal q, poly mu)
419proc pdivi(poly f,ideal F)
420"USAGE:   pdivi(f,F);
421          poly f: the polynomial to be divided
422          ideal F: the divisor ideal
423RETURN:   A list (poly r, ideal q, poly m). r is the remainder of the
424          pseudodivision, q is the set of quotients, and m is the
425          factor by which f is to be multiplied.
426NOTE:     pseudodivision of a poly f by an ideal F in @R. Returns a
427          list (r,q,m) such that m*f=r+sum(q.G), and no lpp of a divisor
428          divides a pp of r.
429KEYWORDS: division, reduce
430EXAMPLE:  pdivi; shows an example"
431{
432  int i;
433  int j;
434  poly r=0;
435  poly mu=1;
436  def p=f;
437  ideal q;
438  for (i=1; i<=size(F); i++){q[i]=0;}
439  ideal lpf;
440  ideal lcf;
441  for (i=1;i<=size(F);i++){lpf[i]=leadmonom(F[i]);}
442  for (i=1;i<=size(F);i++){lcf[i]=leadcoef(F[i]);}
443  poly lpp;
444  poly lcp;
445  poly qlm;
446  poly nu;
447  poly rho;
448  int divoc=0;
449  ideal qlc;
450  while (p!=0)
451  {
452    i=1;
453    divoc=0;
454    lpp=leadmonom(p);
455    lcp=leadcoef(p);
456    while (divoc==0 and i<=size(F))
457    {
458      qlm=lpp/lpf[i];
459      if (qlm!=0)
460      {
461        qlc=simpqcoeffs(lcp,lcf[i]);
462        nu=qlc[2];
463        mu=mu*nu;
464        rho=qlc[1]*qlm;
465        p=nu*p-rho*F[i];
466        r=nu*r;
467        for (j=1;j<=size(F);j++){q[j]=nu*q[j];}
468        q[i]=q[i]+rho;
469        divoc=1;
470      }
471      else {i++;}
472    }
473    if (divoc==0)
474    {
475      r=r+lcp*lpp;
476      p=p-lcp*lpp;
477    }
478  }
479  list res=r,q,mu;
480  return(res);
481}
482example
483{ "EXAMPLE:"; echo = 2;
484  ring R=(0,a,b,c),(x,y),dp;
485  "Divisor=";
486  poly f=(ab-ac)*xy+(ab)*x+(5c);
487  "Dividends=";
488  ideal F=ax+b,cy+a;
489  "(Remainder, quotients, factor)=";
490  def r=pdivi(f,F);
491  r;
492  "Verifying the division: r[3]*f-(r[2][1]*F[1]+r[2][2]*F[2])-r[1] =";
493  r[3]*f-(r[2][1]*F[1]+r[2][2]*F[2])-r[1];
494}
495
496// pspol : S-poly of two polynomials in @R
497// @R
498// input:
499//   poly f  (given in the ring @R)
500//   poly g (given in the ring @R)
501// output:
502//   list (S, red):  S is the S-poly(f,g) and red is a Boolean variable
503//                if red==1 then S reduces by Buchberger 1st criterion (not used)
504static proc pspol(poly f,poly g)
505{
506  def lcf=leadcoef(f);
507  def lcg=leadcoef(g);
508  def lpf=leadmonom(f);
509  def lpg=leadmonom(g);
510  def v=gcd(lpf,lpg);
511  def s=simpqcoeffs(lcf,lcg);
512  def vf=lpf/v;
513  def vg=lpg/v;
514  poly S=s[2]*vg*f-s[1]*vf*g;
515  return(S);
516}
517
518// facvar: Returns all the free-square factors of the elements
519//         of ideal J (non repeated). Integer factors are ignored,
520//         even 0 is ignored. It can be called from ideal @R, but
521//         the given ideal J must only contain poynomials in the
522//         parameters.
523//         Operates in the ring @P, but can be called from ring @R,
524//         and the ideal @P must be defined calling first setglobalrings();
525// input:   ideal J
526// output:  ideal Jc: Returns all the free-square factors of the elements
527//         of ideal J (non repeated). Integer factors are ignored,
528//         even 0 is ignored. It can be called from ideal @R, but
529//         the given ideal J must only contain poynomials in the
530//         parameters.
531static proc facvar(ideal J)
532//"USAGE:   facvar(J);
533//          J: an ideal in the parameters
534//RETURN:   all the free-square factors of the elements
535//          of ideal J (non repeated). Integer factors are ignored,
536//          even 0 is ignored. It can be called from ideal @R, but
537//          the given ideal J must only contain poynomials in the
538//          parameters.
539//NOTE:     Operates in the ring @P, and the ideal J must contain only
540//          polynomials in the parameters, but can be called from ring @R.
541//KEYWORDS: factor
542//EXAMPLE:  facvar; shows an example"
543{
544  int i;
545  def RR=basering;
546  setring(@P);
547  def Ja=imap(RR,J);
548  if(size(Ja)==0){return(ideal(0));}
549  Ja=elimintfromideal(Ja); // also in ideal @P
550  ideal Jb;
551  if (size(Ja)==0){Jb=ideal(0);}
552  else
553  {
554    for (i=1;i<=ncols(Ja);i++){if(size(Ja[i])!=0){Jb=Jb,factorize(Ja[i],1);}}
555    Jb=simplify(Jb,2+4+8);
556    Jb=cld(Jb);
557    Jb=elimintfromideal(Jb); // also in ideal @P
558  }
559  setring(RR);
560  def Jc=imap(@P,Jb);
561  return(Jc);
562}
563//example
564//{ "EXAMPLE:"; echo = 2;
565//  ring R=(0,a,b,c),(x,y,z),dp;
566//  setglobalrings();
567//  ideal J=a2-b2,a2-2ab+b2,abc-bc;
568//  facvar(J);
569//}
570
571// Wred: eliminate the factors in the polynom f that are in W
572//       in ring @RP
573// input:
574//   poly f:
575//   ideal W  of non-null conditions (already supposed that it is facvar)
576// output:
577//   poly f2  where the non-null conditions in W have been dropped from f
578static proc Wred(poly f, ideal W)
579{
580  if (f==0){return(f);}
581  def RR=basering;
582  setring(@RP);
583  def ff=imap(RR,f);
584  def RPW=imap(RR,W);
585  def l=factorize(ff,2);
586  int i;
587  poly f1=1;
588  for(i=1;i<=size(l[1]);i++)
589  {
590    if ((memberpos(l[1][i],RPW)[1]) or (memberpos(-l[1][i],RPW)[1])){;}
591    else{f1=f1*((l[1][i])^(l[2][i]));}
592  }
593  setring(RR);
594  def f2=imap(@RP,f1);
595  return(f2);
596}
597
598// pnormalform: reduces a polynomial wrt a red-spec dividing by N and eliminating factors in W.
599//              called in the ring @R
600//              operates in the ring @RP
601//              both ideals must be defined calling first setglobalrings();
602// input:
603//         poly  f
604//         ideal N  (depends only on the parameters)
605//         ideal W  (depends only on the parameters)
606//                   (N,W) must be a red-spec (depends only on the parameters)
607// output: poly f2 reduced wrt to the red-spec (N,W)
608// note:   for security a lot of work is done. If (N,W) is already a red-spec
609//         it should be simplified
610proc pnormalform(poly f, ideal N, ideal W)
611"USAGE:   pnormalform(f,N,W);
612          f: the polynomial to be reduced modulo (N,W) a reduced representation
613          of a segment in the parameters.
614          N: the null conditions ideal
615          W: the non-null conditions (set of irreducible polynomials)
616RETURN:   a reduced polynomial g of f, whose coefficients are reduced
617          modulo N and having no factor in W.
618NOTE:     Should be called from ring Q[a][x], and the global rings @R, @P
619          and @RP must be defined. These rings can be created by calling
620          previously setglobalrings();
621          Ideals N and W must be given by polynomials
622          in the parameters forming a reduced-representation (see
623          definition in the paper).
624KEYWORDS: division, pdivi, reduce
625EXAMPLE:  pnormalform; shows an example"
626{
627    def RR=basering;
628    setglobalrings();
629    setring(@RP);
630    def fa=imap(RR,f);
631    def Na=imap(RR,N);
632    def Wa=imap(RR,W);
633    option(redSB);
634    Na=std(Na);
635    def r=cld(reduce(fa,Na));
636    def f1=Wred(r[1],Wa);
637    setring(RR);
638    def f2=imap(@RP,f1);
639    return(f2)
640}
641example
642{ "EXAMPLE:"; echo = 2;
643  ring R=(0,a,b,c),(x,y),dp;
644  setglobalrings();
645  poly f=(b^2-1)*x^3*y+(c^2-1)*x*y^2+(c^2*b-b)*x+(a-bc)*y;
646  ideal N=(ab-c)*(a-b),(a-bc)*(a-b);
647  ideal W=a^2-b^2,bc;
648  def r=redspec(N,W);
649  pnormalform(f,r[1],r[2]);
650}
651
652// idint: ideal intersection
653//        in the ring @P.
654//        it works in an extended ring
655// input: two ideals in the ring @P
656// output the intersection of both (is not a GB)
657static proc idint(ideal I, ideal J)
658{
659  def RR=basering;
660  ring T=0,t,lp;
661  def K=T+RR;
662  setring(K);
663  def Ia=imap(RR,I);
664  def Ja=imap(RR,J);
665  ideal IJ;
666  int i;
667  for(i=1;i<=size(Ia);i++){IJ[i]=t*Ia[i];}
668  for(i=1;i<=size(Ja);i++){IJ[size(Ia)+i]=(1-t)*Ja[i];}
669  ideal eIJ=eliminate(IJ,t);
670  setring(RR);
671  return(imap(K,eIJ));
672}
673
674// redspec: generates a red-representation
675//          called in any ring
676//          it changes to the ring @P
677//          So the globalrings @P, @RP, @R, must be created before
678//          using it by calling setglobalrings();
679// input:
680//   ideal N : the ideal of null-conditions
681//   ideal W : set of non-null polynomials:
682//             if W corresponds to no non null conditions then W=ideal(0)
683//             otherwise it should be given as an ideal.
684// returns: list (Na,Wa,DGN)
685// the completely reduced representation:
686//   Na = ideal reduced and radical of the red-spec
687//   facvar(Wa) = ideal the reduced non-null set of polynomials of the red-spec.
688//             if it corresponds to no non null conditions then it is ideal(0)
689//             otherwise the ideal is returned.
690//   DGN = the list of prime ideals associated to Na (uses primASSGTZ in "primdec.lib")
691//   none of the polynomials in facvar(Wa) are contained in none of the ideals in DGN
692//   If the given conditions are not compatible, then N=ideal(1) and DGN=list(ideal(1))
693proc redspec(ideal Ni, ideal Wi)
694//"USAGE:   redspec(N,W);
695//          N: null conditions ideal
696//          W: set of non-null polynomials (ideal)
697//RETURN:   a list (N1,W1,L1) containing a red-representation of the segment (N,W).
698//          N1 is the radical reduced ideal characterizing the segment.
699//          V(N1) is the Zariski closure of the segment (N,W).
700//          The segment S=V(N1) \ V(h), where h=prod(w in W1)
701//          N1 is uniquely determined and no prime component of N1 contains none of
702//          the polynomials in W1. The polynomials in W1 are prime and reduced
703//          wrt N1, and are considered non-null on the segment.
704//          L1 contains the list of prime components of N1.
705//NOTE:     Called from ring @R it works in ring @P, that must be defined
706//          by the call to setglobalrings();
707//          Used in the old library redcgs.lib.
708//KEYWORDS: representation
709//EXAMPLE:  redspec; shows an example"
710{
711  ideal Nc;
712  ideal Wc;
713  def RR=basering;
714  setring(@P);
715  def N=imap(RR,Ni);
716  def W=imap(RR,Wi);
717  ideal Wa;
718  ideal Wb;
719  if(size(W)==0){Wa=ideal(0);}
720     //when there are no non-null conditions then W=ideal(0)
721  else
722  {
723    Wa=facvar(W);
724  }
725  if (size(N)==0)
726  {
727    setring(RR);
728    Wc=imap(@P,Wa);
729    return(list(ideal(0), Wc, list(ideal(0))));
730  }
731  int i;
732  list LNb;
733  list LNa;
734  def LN=minGTZ(N);
735  for (i=1;i<=size(LN);i++)
736  {
737    option(redSB);
738    LNa[i]=std(LN[i]);
739  }
740  poly h=1;
741  if (size(Wa)!=0)
742  {
743    for(i=1;i<=size(Wa);i++){h=h*Wa[i];}
744  }
745  ideal Na;
746  intvec save_opt=option(get);
747  if (size(N)!=0 and (size(LNa)>0))
748  {
749    option(returnSB);
750    Na=intersect(LNa[1..size(LNa)]);
751    option(redSB);
752    Na=std(Na);
753    option(set,save_opt);
754  }
755  attrib(Na,"isSB",1);
756  if (reduce(h,Na,1)==0)
757  {
758    setring(RR);
759    Wc=imap(@P,Wa);
760    return(list (ideal(1),Wc,list(ideal(1))));
761  }
762  i=1;
763  while(i<=size(LNa))
764  {
765    if (reduce(h,LNa[i],1)==0){LNa=delete(LNa,i);}
766    else{ i++;}
767  }
768  if (size(LNa)==0)
769  {
770    setring(RR);
771    return(list(ideal(1),ideal(0),list(ideal(1))));
772  }
773  option(returnSB);
774  ideal Nb=intersect(LNa[1..size(LNa)]);
775  option(redSB);
776  Nb=std(Nb);
777  option(set,save_opt);
778  if (size(Wa)==0)
779  {
780    setring(RR);
781    Nc=imap(@P,Nb);
782    Wc=imap(@P,Wa);
783    LNb=imap(@P,LNa);
784    return(list(Nc,Wc,LNb));
785  }
786  Wb=ideal(0);
787  attrib(Nb,"isSB",1);
788  for (i=1;i<=size(Wa);i++){Wb[i]=reduce(Wa[i],Nb);}
789  Wb=facvar(Wb);
790  if (size(LNa)!=0)
791  {
792    setring(RR);
793    Nc=imap(@P,Nb);
794    Wc=imap(@P,Wb);
795    LNb=imap(@P,LNa);
796    return(list(Nc,Wc,LNb))
797  }
798  else
799  {
800    setring(RR);
801    Nd=imap(@P,Nb);
802    Wc=imap(@P,Wb);
803    kill LNb;
804    list LNb;
805    return(list(Nd,Wc,LNb))
806  }
807}
808//example
809//{ "EXAMPLE:"; echo = 2;
810//  ring r=(0,a,b,c),(x,y),dp;
811//  setglobalrings();
812//  ideal N=(ab-c)*(a-b),(a-bc)*(a-b);
813//  ideal W=a^2-b^2,bc;
814//  redspec(N,W);
815//}
816
817// lesspol: compare two polynomials by its leading power products
818// input:  two polynomials f,g in the ring @R
819// output: 0 if f<g,  1 if f>=g
820static proc lesspol(poly f, poly g)
821{
822  if (leadmonom(f)<leadmonom(g)){return(1);}
823  else
824  {
825    if (leadmonom(g)<leadmonom(f)){return(0);}
826    else
827    {
828      if (leadcoef(f)<leadcoef(g)){return(1);}
829      else {return(0);}
830    }
831  }
832}
833
834// delfromideal: deletes the i-th polynomial from the ideal F
835static proc delfromideal(ideal F, int i)
836{
837  int j;
838  ideal G;
839  if (size(F)<i){ERROR("delfromideal was called incorrect arguments");}
840  if (size(F)<=1){return(ideal(0));}
841  if (i==0){return(F);}
842  for (j=1;j<=size(F);j++)
843  {
844    if (j!=i){G[size(G)+1]=F[j];}
845  }
846  return(G);
847}
848
849// delidfromid: deletes the polynomials in J that are in I
850// input: ideals I,J
851// output: the ideal J without the polynomials in I
852static proc delidfromid(ideal I, ideal J)
853{
854  int i; list r;
855  ideal JJ=J;
856  for (i=1;i<=size(I);i++)
857  {
858    r=memberpos(I[i],JJ);
859    if (r[1])
860    {
861      JJ=delfromideal(JJ,r[2]);
862    }
863  }
864  return(JJ);
865}
866
867// sortideal: sorts the polynomials in an ideal by lm in ascending order
868static proc sortideal(ideal Fi)
869{
870  def RR=basering;
871  setring(@RP);
872  def F=imap(RR,Fi);
873  def H=F;
874  ideal G;
875  int i;
876  int j;
877  poly p;
878  while (size(H)!=0)
879  {
880    j=1;
881    p=H[1];
882    for (i=1;i<=size(H);i++)
883    {
884      if(lesspol(H[i],p)){j=i;p=H[j];}
885    }
886    G[size(G)+1]=p;
887    H=delfromideal(H,j);
888  }
889  setring(RR);
890  def GG=imap(@RP,G);
891  return(GG);
892}
893
894// mingb: given a basis (gb reducing) it
895// order the polynomials is ascending order and
896// eliminate the polynomials whose lpp is divisible by some
897// smaller one
898static proc mingb(ideal F)
899{
900  int t; int i; int j;
901  def H=sortideal(F);
902  ideal G;
903  if (ncols(H)<=1){return(H);}
904  G=H[1];
905  for (i=2; i<=ncols(H); i++)
906  {
907    t=1;
908    j=1;
909    while (t and (j<i))
910    {
911      if((leadmonom(H[i])/leadmonom(H[j]))!=0) {t=0;}
912      j++;
913    }
914    if (t) {G[size(G)+1]=H[i];}
915  }
916  return(G);
917}
918
919// redgb: given a minimal basis (gb reducing) it
920// reduces each polynomial wrt to the others
921static proc redgb(ideal F, ideal N, ideal W)
922{
923  ideal G;
924  ideal H;
925  int i;
926  if (size(F)==0){return(ideal(0));}
927  for (i=1;i<=size(F);i++)
928  {
929    H=delfromideal(F,i);
930    G[i]=pnormalform(pdivi(F[i],H)[1],N,W);
931  }
932  return(G);
933}
934
935//********************Main routines for buildtree******************
936
937// splitspec: a new leading coefficient f is given to a red-spec
938//            then splitspec computes the two new red-spec by
939//            considering it null, and non null.
940// in ring @P
941// given f, and the red-spec (N,W)
942//     it outputs the null and the non-null red-spec adding f.
943//     if some of the output representations has N=1 then
944//     there must be no split and buildtree must continue on
945//     the compatible red-spec
946// input:  poly f coefficient to split if needed
947//         list r=(N,W,LN) redspec
948// output: list L = list(ideal N0, ideal W0), list(ideal N1, ideal W1), cond
949static proc splitspec(poly fi, list ri)
950{
951  def RR=basering;
952  def Ni=ri[1];
953  def Wi=ri[2];
954  setring(@P);
955  def f=imap(RR,fi);
956  def N=imap(RR,Ni);
957  def W=imap(RR,Wi);
958  f=Wred(f,W);
959  def N0=N;
960  def W1=W;
961  N0[size(N0)+1]=f;
962  def r0=redspec(N0,W);
963  W1[size(W1)+1]=f;
964  def r1=redspec(N,W1);
965  setring(RR);
966  def ra0=imap(@P,r0);
967  def ra1=imap(@P,r1);
968  def cond=imap(@P,f);
969  return (list(ra0,ra1,cond));
970}
971
972// redcoefs
973// 15/09/2010
974static proc redcoefs(poly f, ideal N)
975{
976  def f1=f; int test0=1; poly lc; poly lm;
977  poly lc1;
978  def RR=basering;
979  setring(@P);
980  poly lcp;
981  def Np=imap(RR,N);
982  attrib(Np,"isSB",1);
983  setring(RR);
984  while((test0==1) and (f1<>0))
985  {
986    lc=leadcoef(f1);
987    lm=leadmonom(f1);
988    setring(@P);
989    lcp=imap(RR,lc);
990    lcp=reduce(lcp,Np);
991    setring(RR);
992    lc1=imap(@P,lcp);
993    if(lc1<>0){test0=0;}
994    f1=f1+(lc1-lc)*lm;
995  }
996  return(f1);
997}
998
999// discusspolys: given a basis B and a red-spec (N,W), it analyzes the
1000//               leadcoef of the polynomials in B until it finds
1001//               that one of them can be either null or non null.
1002//               If at the end only the non null option is compatible
1003//               then the reduced B has all the leadcoef non null.
1004//               Else recbuildtree must split.
1005// ring @R
1006// input:  ideal B
1007//         ideal N
1008//         ideal W (a reduced-representation)
1009// output: list of ((N0,W0,LN0),(N1,W1,LN1),Br,cond)
1010//         cond is the condition to branch
1011static proc discusspolys(ideal B, list r)
1012{
1013  poly f;     poly f1;    poly f2;
1014  poly cond;
1015  def N=r[1]; def W=r[2]; def LN=r[3];
1016  def Ba=B;   def F=B;
1017  ideal N0=1; def W0=W;   list LN0=ideal(1);
1018  def N1=N;   def W1=W;   def LN1=LN;
1019  list L;
1020  list M;     list M0;    list M1;
1021  list rr;
1022  if (size(B)==0)
1023  {
1024    M0=N0,W0,LN0; // incompatible
1025    M1=N1,W1,LN1;
1026    M=M0,M1,B,poly(1);
1027    return(M);
1028  }
1029  while ((size(F)!=0) and ((N0[1]==1) or (N1[1]==1)))
1030  {
1031    f=F[1];
1032    F=delfromideal(F,1);
1033    f1=pnormalform(f,N,W);
1034    rr=memberpos(f,Ba);
1035    if (f1!=0)
1036    {
1037      Ba[rr[2]]=f1;
1038      if (pardeg(leadcoef(f1))!=0)
1039      {
1040        f2=Wred(leadcoef(f1),W);
1041        L=splitspec(f2,list(N,W,LN));
1042        N0=L[1][1]; W0=L[1][2]; LN0=L[1][3]; N1=L[2][1]; W1=L[2][2]; LN1=L[2][3];
1043        cond=L[3];
1044      }
1045    }
1046    else
1047    {
1048      Ba=delfromideal(Ba,rr[2]);
1049      N0=ideal(1); //F=ideal(0);
1050    }
1051  }
1052  M0=N0,W0,LN0;
1053  M1=N1,W1,LN1;
1054  M=M0,M1,Ba,cond;
1055  return(M);
1056}
1057
1058// discussSpolys: given a basis B and a red-spec (N,W), it analyzes the
1059//                leadcoef of the polynomials in B until it finds
1060//                that one of them can be either null or non null.
1061//                If at the end only the non null option is compatible
1062//                then the reduced B has all the leadcoef non null.
1063//                Else recbuildtree must split.
1064// ring @R
1065// input:  ideal B
1066//         ideal N
1067//         ideal W (a reduced-representation)
1068//         list  P current set of pairs of polynomials from B to be tested.
1069// output: list of (N0,W0,LN0),(N1,W1,LN1),Br,Pr,cond]
1070//         list Pr the not checked list of pairs.
1071static proc discussSpolys(ideal B, list r, list P)
1072{
1073  int i; int j; int k;
1074  int npols; int nSpols; int tt;
1075  poly cond=1;
1076  poly lm; poly lpf; poly lpg;
1077  def F=B; def Pa=P; list Pa0;
1078  def N=r[1]; def W=r[2]; def LN=r[3];
1079  ideal N0=1; def W0=W; list LN0=ideal(1);
1080  def N1=N; def W1=W; def LN1=LN;
1081  ideal Bw;
1082  poly S;
1083  list L; list L0; list L1;
1084  list M; list M0; list M1;
1085  list pair;
1086  list KK; int loc;
1087  int crit;
1088  poly h;
1089  if (size(B)==0)
1090  {
1091    M0=N0,W0,LN0;
1092    M1=N1,W1,LN1;
1093    M=M0,M1,ideal(0),Pa,cond;
1094    return(M);
1095  }
1096  tt=1;
1097  i=1;
1098  while ((tt) and (i<=size(B)))
1099  {
1100    h=B[i];
1101    for (j=1;j<=npars(@R);j++)
1102    {
1103      h=subst(h,par(j),0);
1104    }
1105    if (h!=B[i]){tt=0;}
1106    i++;
1107  }
1108  if (tt)
1109  {
1110    //"T_ a non parametric system occurred";
1111    def RR=basering;
1112    def RL=ringlist(RR);
1113    RL[1]=0;
1114    def LRR=ring(RL);
1115    setring(LRR);
1116    def BP=imap(RR,B);
1117    option(redSB);
1118    BP=std(BP);
1119    setring(RR);
1120    B=imap(LRR,BP);
1121    M0=ideal(1),W0,LN0;
1122    M1=N1,W1,LN1;
1123    M=M0,M1,B,list(),cond;
1124    return(M);
1125  }
1126  if (size(Pa)==0){npols=size(B); Pa=orderingpairs(F); nSpols=size(Pa);}
1127  while ((size(Pa)!=0) and (N0[1]==1) or (N1[1]==1))
1128  {
1129    pair=Pa[1];
1130    i=pair[1];
1131    j=pair[2];
1132    Pa=delete(Pa,1);
1133    // Buchberger 1st criterion (not needed here, it is already eliminated
1134    // when creating the list of pairs
1135    for (k=1;k<=size(Pa);k++){Pa0[k]=delete(Pa[k],3);}
1136    crit=0;
1137    if (not(crit))
1138    {
1139      S=pspol(F[i],F[j]);
1140      KK=pdivi(S,F);
1141      S=KK[1];
1142      if (S!=0)
1143      {
1144        S=pnormalform(S,N,W);
1145        if (S!=0)
1146        {
1147          L=discusspolys(ideal(S),list(N,W,LN));
1148          N0=L[1][1];
1149          W0=L[1][2];
1150          LN0=L[1][3];
1151          N1=L[2][1];
1152          W1=L[2][2];
1153          LN1=L[2][3];
1154          S=L[3][1];
1155          cond=L[4];
1156          if (S==1)
1157          {
1158            M0=ideal(1),W0,list(ideal(1));
1159            M1=N1,W1,LN1;
1160            M=M0,M1,ideal(1),list(),cond;
1161            return(M);
1162          }
1163          if (S!=0)
1164          {
1165            F[size(F)+1]=S;
1166            npols=size(F);
1167            for (k=1;k<size(F);k++)
1168            {
1169              lm=lcmlmonoms(F[k],S);
1170              // Buchberger 1st criterion
1171              lpf=leadmonom(F[k]);
1172              lpg=leadmonom(S);
1173              if (lpf*lpg!=lm)
1174              {
1175                pair=k,size(F),lm;
1176                Pa=placepairinlist(pair,Pa);
1177                nSpols=size(Pa);
1178              }
1179            }
1180            if (N0[1]==1){N=N1; W=W1; LN=LN1;}
1181          }
1182        }
1183      }
1184    }
1185  }
1186  M0=N0,W0,LN0;
1187  M1=N1,W1,LN1;
1188  M=M0,M1,F,Pa,cond;
1189  return(M);
1190}
1191
1192// lcmlmonoms: computes the lcm of the leading monomials
1193//             of the polynomils f and g
1194// ring @R
1195static proc lcmlmonoms(poly f,poly g)
1196{
1197  def lf=leadmonom(f);
1198  def lg=leadmonom(g);
1199  def gls=gcd(lf,lg);
1200  return((lf*lg)/gls);
1201}
1202
1203// placepairinlist
1204// 15/09/2010
1205// input:  given a new pair of the form (i,j,lmij)
1206//         and a list of pairs of the same form
1207// ring @R
1208// output: it inserts the new pair in ascending order of lmij
1209static proc placepairinlist(list pair,list P)
1210{
1211  list Pr;
1212  if (size(P)==0){Pr=insert(P,pair); return(Pr);}
1213  if (pair[3]<P[1][3]){Pr=insert(P,pair); return(Pr);}
1214  if (pair[3]>=P[size(P)][3]){Pr=insert(P,pair,size(P)); return(Pr);}
1215  kill Pr;
1216  list Pr;
1217  int j;
1218  int i=1;
1219  int loc=0;
1220  while((i<=size(P)) and (loc==0))
1221  {
1222    if (pair[3]>=P[i][3]){j=i; i++;}
1223    else{loc=1; j=i-1;}
1224  }
1225  Pr=insert(P,pair,j);
1226  return(Pr);
1227}
1228
1229// orderingpairs:
1230// input:  ideal F
1231// output: list of ordered pairs (i,j,lcmij) of F in ascending order of lcmij
1232//         if a pair verifies Buchberger 1st criterion it is not stored
1233// ring @R
1234static proc orderingpairs(ideal F)
1235{
1236  int i;
1237  int j;
1238  poly lm;
1239  poly lpf;
1240  poly lpg;
1241  list P;
1242  list pair;
1243  if (size(F)<=1){return(P);}
1244  for (i=1;i<=size(F)-1;i++)
1245  {
1246    for (j=i+1;j<=size(F);j++)
1247    {
1248      lm=lcmlmonoms(F[i],F[j]);
1249      // Buchberger 1st criterion
1250      lpf=leadmonom(F[i]);
1251      lpg=leadmonom(F[j]);
1252      if (lpf*lpg!=lm)
1253      {
1254        pair=(i,j,lm);
1255        P=placepairinlist(pair,P);
1256      }
1257    }
1258  }
1259  return(P);
1260}
1261
1262// Buchberger 2nd criterion
1263// input:  integers i,j
1264//         list P of pairs of the form (i,j) not yet verified
1265// ring @R
1266//         not used (it increases time)
1267static proc criterion(int i, int j, list P, ideal B)
1268{
1269  def lcmij=lcmlmonoms(B[i],B[j]);
1270  int crit=0;
1271  int k=1;
1272  list ik; list jk;
1273  while ((k<=size(B)) and (crit==0))
1274  {
1275    if ((k!=i) and (k!=j))
1276    {
1277      if (i<k){ik=i,k;} else{ik=k,i;}
1278      if (j<k){jk=i,k;} else{jk=k,j;}
1279      if (not((memberpos(ik,P)[1]) or (memberpos(jk,P)[1])))
1280      {
1281        if ((lcmij)/leadmonom(B[k])!=0){crit=1;}
1282      }
1283    }
1284    k++;
1285  }
1286  return(crit);
1287}
1288
1289// buildtree: Basic routine of the old redcgs.lib generating a
1290//     first reduced CGS
1291//     it will define the rings @R, @P and @RP as global rings
1292//     and the list @T a global list that will be killed at the output
1293// input:  ideal F in ring K[a][x];
1294// output: list T of lists whose list elements are of the form
1295//         T[i]=list(list lab, boolean terminal, ideal B, ideal N, ideal W, list of ideals decomp of N,
1296//              ideal of monomials lpp);
1297// all the ideals are in the ring K[a][x];
1298static proc buildtree(ideal F, list #)
1299//"USAGE:   buildtree(F);
1300//          F: ideal in Q[a][x] (parameters and variables) to be discussed.
1301//          It outputs the whole discussion tree to construct the
1302//          first disjoint reduced CGS. It is the old version of the new
1303//          cgsdr routine. It remains on the library for didactic purposes
1304//          and is, in general, less efficient.
1305//          Also, for some problems where cgsdr does stack, sometimes
1306//          buildtree is able to obtain the result.
1307//          The output of buildtree contains the whole information about the discussion
1308//          process (the whole tree discussion) and can be reduced to
1309//          somewhat similar to the output of cgsdr after calling
1310//          setglobalrings(); then applying finalcases and then groupsegments to the
1311//          output of buidtree. This is automatically done by the routine
1312//          cgsdrold also contained in the library, that outputs only the
1313//          CGS like the new cgsdr.
1314//
1315//RETURN:   Returns a list T describing the complete discussion tree
1316//          for obtaining a reduced and disjoint comprehensive
1317//          Groebner system (CGS) of the ideal F of Q[a][x] with
1318//          constant leading power products (lpp) of the reduced Groebner
1319//          basis.
1320//          The first element of the list is the root, and contains
1321//            [1] label: intvec(-1)
1322//            [2] number of children : int
1323//            [3] the ideal F
1324//            [4], [5], [6] the red-representation of the segment
1325//                (null, non-null conditions, prime components of the null
1326//                conditions) given (as option).
1327//                ideal (0), ideal (1), list(ideal(0)) is assumed if
1328//                no optional conditions are given.
1329//            [7] the set of lpp of ideal F
1330//            [8] condition that was taken to reach the vertex
1331//                (poly 1, for the root).
1332//          The remaining elements of the list represent vertices of the tree:
1333//          with the same structure:
1334//            [1] label: intvec (1,0,0,1,...) gives its position in the tree:
1335//                first branch condition is taken non-null, second null,...
1336//            [2] number of children (0 if it is a terminal vertex)
1337//            [3] the specialized ideal with the previous assumed conditions
1338//                to reach the vertex
1339//            [4],[5],[6] the red-representation of the segment corresponding
1340//                to the previous assumed conditions to reach the vertex
1341//            [7] the set of lpp of the specialized ideal at this stage
1342//            [8] condition that was taken to reach the vertex from the
1343//                father's vertex (that was taken non-null if the last
1344//                integer in the label is 1, and null if it is 0)
1345//          The terminal vertices form a disjoint partition of the parameter space
1346//          whose bases specialize to the reduced Groebner basis of the
1347//          specialized ideal on each point of the segment and preserve
1348//          the lpp. So they form a disjoint reduced CGS.
1349//NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
1350//          x=variables, and should be defined previously. The ideal must
1351//          be defined on R.
1352//          The call of finalcases applied to the output of buildtree
1353//          selects the terminal vertices forming the disjoint and reduced
1354//          CGS. To obtain the output similar
1355//          to that of the new cgsdr procedure one can call instead
1356//          cgsdrold.
1357//
1358//          The content of buildtree can be written in a file that is readable
1359//          by Maple in order to plot its content using buildtreetoMaple;
1360//          The file written by buildtreetoMaple when is read in a Maple
1361//          worksheet can be plotted using the dbgb routine tplot;
1362//
1363//KEYWORDS: CGS, disjoint, reduced, comprehensive Groebner system
1364//EXAMPLE:  buildtree; shows an example"
1365{
1366  list @T;
1367  exportto(Top,@T);
1368  setglobalrings();
1369  int i;
1370  int j;
1371  poly f;
1372  poly cond=1;
1373  list LN;
1374  LN[1]=ideal(0);
1375  def N=ideal(0);
1376  def W=ideal(1);
1377  int comment=0;
1378  list L=#;
1379  for(i=1;i<=size(L) div 2;i++)
1380  {
1381    if(L[2*i-1]=="null"){N=L[2*i];}
1382    else
1383    {
1384      if(L[2*i-1]=="nonnull"){W=L[2*i];}
1385      else
1386      {
1387        if(L[2*i-1]=="comment"){comment=L[2*i];}
1388      }
1389    }
1390  }
1391  ideal B;
1392  if(equalideals(N,ideal(0))==0)
1393  {
1394    def LL=redspec(N,W);
1395    N=LL[1];
1396    W=LL[2];
1397    LN=LL[3];
1398    for (i=1;i<=size(F);i++)
1399    {
1400      f=pnormalform(F[i],N,W);
1401      if (f!=0){B[size(B)+1]=f;}
1402    }
1403  }
1404  else {B=F;}
1405  def lpp=ideal(0);
1406  if (size(B)==0){lpp=ideal(0);}
1407  else
1408  {
1409     for (i=1;i<=size(B);i++){lpp[i]=leadmonom(B[i]);}
1410    // lpp=ideal of lead power product of the polys in B
1411  }
1412  intvec lab=-1;
1413  int term=0;
1414  list root;
1415  root[1]=lab;
1416  root[2]=term;
1417  root[3]=B;
1418  root[4]=N;
1419  root[5]=W;
1420  root[6]=LN;
1421  root[7]=lpp;
1422  root[8]=cond;
1423  @T[1]=root;
1424  list P;
1425  recbuildtree(root,P);
1426  def T=@T;
1427  kill @T;
1428  kill @P; kill @RP; kill @R;
1429  return(T)
1430}
1431//example
1432//{ "EXAMPLE:"; echo = 2;
1433//  ring R=(0,a0,a1,a2,a3,a4),(x1,x2,x3),dp;
1434//  "Casas conjecture for degree 4";
1435//  ideal F=x1^4+(4*a3)*x1^3+(6*a2)*x1^2+(4*a1)*x1+(a0),
1436//          x1^3+(3*a3)*x1^2+(3*a2)*x1+(a1),
1437//          x2^4+(4*a3)*x2^3+(6*a2)*x2^2+(4*a1)*x2+(a0),
1438//          x2^2+(2*a3)*x2+(a2),
1439//          x3^4+(4*a3)*x3^3+(6*a2)*x3^2+(4*a1)*x3+(a0),
1440//          x3+(a3);
1441//  def T=buildtree(F); "buildtree(F)="; T;
1442//  setglobalrings();
1443//  def FC=finalcases(T);
1444//  "finalcases(buildtree(F))="; FC;
1445//  "groupsegments(finalcases(buildtree(F)))=";
1446//  groupsegments(FC);
1447//  buildtreetoMaple(T,"Tb","Tb.txt"); " ";
1448//  "Compare with cgsdrold"; " ";
1449//  def CDR=cgsdrold(F);
1450//  "cgsdrold(F)="; CDR;
1451//}
1452
1453// recbuildtree: auxilliary recursive routine called by buildtree
1454static proc recbuildtree(list v, list P)
1455{
1456  def vertex=v;
1457  int i;
1458  int j;
1459  int pos;
1460  list P0;
1461  list P1;
1462  poly f;
1463  def lab=vertex[1];
1464  if ((size(lab)>1) and (lab[1]==-1))
1465  {lab=lab[2..size(lab)];}
1466  def term=vertex[2];
1467  def B=vertex[3];
1468  def N=vertex[4];
1469  def W=vertex[5];
1470  def LN=vertex[6];
1471  def lpp=vertex[7];
1472  def cond=vertex[8];
1473  def lab0=lab;
1474  def lab1=lab;
1475  if ((size(lab)==1) and (lab[1]==-1))
1476  {
1477    lab0=0;
1478    lab1=1;
1479  }
1480  else
1481  {
1482    lab0[size(lab)+1]=0;
1483    lab1[size(lab)+1]=1;
1484  }
1485  list vertex0;
1486  list vertex1;
1487  ideal B0;
1488  ideal lpp0;
1489  ideal lpp1;
1490  ideal N0=1;
1491  def W0=ideal(0);
1492  list LN0=ideal(1);
1493  def B1=B;
1494  def N1=N;
1495  def W1=W;
1496  list LN1=LN;
1497  list L;
1498  if (size(P)==0)
1499  {
1500    L=discusspolys(B,list(N,W,LN));
1501    N0=L[1][1];
1502    W0=L[1][2];
1503    LN0=L[1][3];
1504    N1=L[2][1];
1505    W1=L[2][2];
1506    LN1=L[2][3];
1507    B1=L[3];
1508    cond=L[4];
1509  }
1510  if ((size(B1)!=0) and (N0[1]==1))
1511  {
1512    L=discussSpolys(B1,list(N1,W1,LN1),P);
1513    N0=L[1][1];
1514    W0=L[1][2];
1515    LN0=L[1][3];
1516    N1=L[2][1];
1517    W1=L[2][2];
1518    LN1=L[2][3];
1519    B1=L[3];
1520    P1=L[4];
1521    cond=L[5];
1522    lpp=ideal(0);
1523    for (i=1;i<=size(B1);i++){lpp[i]=leadmonom(B1[i]);}
1524  }
1525  vertex[3]=B1;
1526  vertex[4]=N1; // unnecessary
1527  vertex[5]=W1; // unnecessary
1528  vertex[6]=LN1;// unnecessary
1529  vertex[7]=lpp;
1530  vertex[8]=cond;
1531  if (size(@T)>0)
1532  {
1533    pos=size(@T)+1;
1534    @T[pos]=vertex;
1535  }
1536  if ((N0[1]!=1) and (N1[1]!=1))
1537  {
1538    vertex1[1]=lab1;
1539    vertex1[2]=0;
1540    vertex1[3]=B1;
1541    vertex1[4]=N1;
1542    vertex1[5]=W1;
1543    vertex1[6]=LN1;
1544    vertex1[7]=lpp1;
1545    vertex1[8]=cond;
1546    if (size(B1)==0){B0=ideal(0); lpp0=ideal(0);}
1547    else
1548    {
1549      j=1;
1550      lpp0=ideal(0);
1551      for (i=1;i<=size(B1);i++)
1552      {
1553        f=pnormalform(B1[i],N0,W0);
1554        if (f!=0){B0[j]=f; lpp0[j]=leadmonom(f);j++;}
1555      }
1556    }
1557    vertex0[1]=lab0;
1558    vertex0[2]=0;
1559    vertex0[3]=B0;
1560    vertex0[4]=N0;
1561    vertex0[5]=W0;
1562    vertex0[6]=LN0;
1563    vertex0[7]=lpp0;
1564    vertex0[8]=cond;
1565    recbuildtree(vertex0,P0);
1566    recbuildtree(vertex1,P1);
1567  }
1568  else
1569  {
1570    if (equalideals(N1,ideal(1))==0)
1571    {
1572      vertex[2]=1;
1573      B1=mingb(B1);
1574      vertex[3]=redgb(B1,N1,W1);
1575      vertex[4]=N1;
1576      vertex[5]=W1;
1577      vertex[6]=LN1;
1578      lpp=ideal(0);
1579      for (i=1;i<=size(vertex[3]);i++){lpp[i]=leadmonom(vertex[3][i]);}
1580      vertex[7]=lpp;
1581      vertex[8]=cond;
1582      @T[pos]=vertex;
1583      //print(vertex);
1584    }
1585  }
1586}
1587
1588// RtoPrep
1589// Computes the P-representaion of a R-representaion (N,W,L) of a set
1590// input:
1591//    ideal N (null conditions, must be radical)
1592//    ideal W (non-null conditions ideal)
1593//    list L  must contain the radical decomposition of N.
1594// output:
1595//    the ((p_1,(p_11,..,p_1k_1)),..,(p_r,(p_r1,..,p_rk_r)));
1596//    the Prep of V(N) \ V(h), where h=prod(w in W).
1597static proc RtoPrep(ideal N, ideal W, list L)
1598{
1599  int i; int j; list L0;
1600  if (N[1]==1)
1601  {
1602    L0[1]=list(ideal(1),list(ideal(1)));
1603    return(L0);
1604  }
1605  def RR=basering;
1606  setring(@P);
1607  ideal Np=imap(RR,N);
1608  ideal Wp=imap(RR,W);
1609  list Lp=imap(RR,L);
1610  poly h=1;
1611  for (i=1;i<=size(Wp);i++){h=h*Wp[i];}
1612  list r; list Ti; list LL;
1613  for (i=1;i<=size(Lp);i++)
1614  {
1615    Ti=minGTZ(Lp[i]+h);
1616    for(j=1;j<=size(Ti);j++)
1617    {
1618      option(redSB);
1619      Ti[j]=std(Ti[j]);
1620    }
1621    //list LL[i];
1622    LL[i]=list(Lp[i],Ti);
1623  }
1624  setring(RR);
1625  return(imap(@P,LL));
1626}
1627
1628// groupRtoPrep
1629// input:  L (list) is the output of groupsegments
1630// output: LL (list) the same list but the segments are expressed
1631//                   in canonical representations:
1632//  ( (lpp, (lab BuildTree, basis,
1633//             ((P_1),(P_{11},...,P_{1t1}))
1634//             ...
1635//             ((P_j),(P_{j1},...,P_{jtj}))
1636//          )
1637//          ...
1638//          (lab BuildTree, basis,
1639//             ((P_1),(P_{11},...,P_{1t1}))
1640//             ...
1641//             ((P_j),(P_{j1},...,P_{jtj}))
1642//          )
1643//    )
1644//    ...
1645//    (lpp, (lab BuildTree, basis,
1646//             ((P_1),(P_{11},...,P_{1t1}))
1647//             ...
1648//             ((P_j),(P_{j1},...,P_{jtj}))
1649//          )
1650//          ...
1651//          (lab BuildTree, basis,
1652//             ((P_1),(P_{11},...,P_{1t1}))
1653//             ...
1654//             ((P_j),(P_{j1},...,P_{jtj}))
1655//          )
1656//    )
1657//  )
1658static proc groupRtoPrep(list L)
1659{
1660  int i; int j;
1661  list LL; list ct;
1662  // size(L)=number of lpp-segments
1663  for (i=1;i<=size(L);i++)
1664  {
1665    LL[i]=list();
1666    LL[i][1]=L[i][1];
1667    // L[i][1]=lpp
1668    LL[i][2]=list();
1669    for (j=1;j<=size(L[i][2]);j++)
1670    {
1671      ct=RtoPrep(L[i][2][j][3],L[i][2][j][4],L[i][2][j][5]);
1672      LL[i][2][j]=list();
1673      LL[i][2][j][1]=L[i][2][j][1];
1674      // L[i][2][j][1]=label
1675      LL[i][2][j][2]=L[i][2][j][2];
1676      // L[i][2][j][2]=basis
1677      LL[i][2][j][3]=ct;
1678    }
1679  }
1680  return(LL);
1681}
1682
1683// NEW
1684// input:  L (list) is the output of groupsegments
1685// output: LL (list) the same list but the segments are expressed
1686//                   in canonical representations:
1687//  ( (lpp, (lab BuildTree, basis,
1688//             ((1,u1),(lab,child,P_1)),
1689//             ((1,1,1),(lab,child,P_{11})),
1690//             ...
1691//             ((1,1,t1),(lab,child,P_{1t1})),
1692//             ...
1693//             ((1,u1),(lab,child,P_u1)),
1694//             ((1,u1,1),(lab,child,P_{u1,1})),
1695//             ...
1696//             ((1,u1,tu),(lab,child,P_{u1,tu})),
1697//          (lab BuildTree, basis,
1698//             ((1,u2),(lab,child,P_2)),
1699//             ((1,u1+1,1),(lab,child,P_{21})),
1700//             ...
1701//             ((1,u1+1,t2),(lab,child,P_{2,t2})),
1702//             ...
1703//             ((1,u1+..+ut),(lab,child,P_ut)),
1704//             ((1,u1+..+ut,1),(lab,child,P_{ut,1})),
1705//             ...
1706//             ((1,u1+..+ut,tu),(lab,child,P_{ut,tu})),
1707// ...
1708static proc groupredtocan(list L)
1709{
1710  int i; int j;
1711  list LL; list ct;
1712  for (i=1;i<=size(L);i++)
1713  {
1714    LL[i]=list();
1715    LL[i][1]=L[i][1];
1716    LL[i][2]=list();
1717    for (j=1;j<=size(L[i][2]);j++)
1718    {
1719      ct=redtocanspec(intvec(i),j-1,list(L[i][2][j][3],L[i][2][j][4],L[i][2][j][5]));
1720      LL[i][2][j]=list();
1721      LL[i][2][j][1]=L[i][2][j][1];
1722      LL[i][2][j][2]=L[i][2][j][2];
1723      LL[i][2][j][3]=ct;
1724    }
1725  }
1726  return(LL);
1727}
1728
1729//****************End of BuildTree*************************************
1730
1731//****************Begin BuildTree To Maple*****************************
1732
1733// buildtreetoMaple: writes the list provided by buildtree to a file
1734//    containing the table representing it in Maple
1735
1736// writes the list L=buildtree(F) to a file "writefile" that
1737// is readable by Maple whith name T
1738// input:
1739//   L: the list output by buildtree
1740//   T: the name (string) of the output table in Maple
1741//   writefile: the name of the datafile where the output is to be stored
1742// output:
1743//   the result is written on the datafile "writefile" containig
1744//   the assignement to the table with name "T"
1745proc buildtreetoMaple(list L, string T, string writefile)
1746"USAGE:   buildtreetoMaple(T, TM, writefile);
1747          T: is the list provided by grobcovold called with option "old",0;
1748          TM: is the name (string) of the table variable in Maple that will represent
1749          the output of cgsdrold;
1750          writefile: is the name (string) of the file whereas to write the
1751          content.
1752RETURN:   writes the list provided by grobcovold called with option "old",0,
1753          (old buildtree) to a file containing the table representing it in
1754          Maple.
1755KEYWORDS: cgsdrold, buildtree, Maple
1756EXAMPLE:  buildtreetoMaple; shows an example"
1757{
1758  def R=basering;
1759  if(size(T[1])!=8)
1760  {
1761    "  'Warning!' cgsdrold must be called with option 'old' set to 0 to be operative";
1762    return();
1763  }
1764  short=0;
1765  poly cond;
1766  int i;
1767  link LLw=":w "+writefile;
1768  string La=string("table(",T,");");
1769  write(LLw, La);
1770  close(LLw);
1771  link LLa=":a "+writefile;
1772  def RL=ringlist(R);
1773  list p=RL[1][2];
1774  string param=string(p[1]);
1775  if (size(p)>1)
1776  {
1777    for(i=2;i<=size(p);i++){param=string(param,",",p[i]);}
1778  }
1779  list v=RL[2];
1780  string vars=string(v[1]);
1781  if (size(v)>1)
1782  {
1783    for(i=2;i<=size(v);i++){vars=string(vars,",",v[i]);}
1784  }
1785  list xord;
1786  list pord;
1787  if (RL[1][3][1][1]=="dp"){pord=string("tdeg(",param);}
1788  if (RL[1][3][1][1]=="lp"){pord=string("plex(",param);}
1789  if (RL[3][1][1]=="dp"){xord=string("tdeg(",vars);}
1790  if (RL[3][1][1]=="lp"){xord=string("plex(",vars);}
1791  write(LLa,string(T,"[[9]]:=",xord,");"));
1792  write(LLa,string(T,"[[10]]:=",pord,");"));
1793  write(LLa,string(T,"[[11]]:=true; "));
1794  list S;
1795  for (i=1;i<=size(L);i++)
1796  {
1797    if (L[i][2]==0)
1798    {
1799      cond=L[i][8];
1800      S=btcond(T,L[i],cond);
1801      write(LLa,S[1]);
1802      write(LLa,S[2]);
1803    }
1804    S=btbasis(T,L[i]);
1805    write(LLa,S);
1806    S=btN(T,L[i]);
1807    write(LLa,S);
1808    S=btW(T,L[i]);
1809    write(LLa,S);
1810    if (L[i][2]==1) {S=btterminal(T,L[i]); write(LLa,S);}
1811    S=btlpp(T,L[i]);
1812    write(LLa,S);
1813  }
1814  close(LLa);
1815}
1816example
1817{ "EXAMPLE:"; echo = 2;
1818  ring R=(0,a1,a2,a3,a4),(x1,x2,x3,x4),dp;
1819  ideal F=x4-a4+a2,
1820   x1+x2+x3+x4-a1-a3-a4,
1821   x1*x3*x4-a1*a3*a4,
1822   x1*x3+x1*x4+x2*x3+x3*x4-a1*a4-a1*a3-a3*a4;
1823  def T=cgsdrold(F,"old",0); "T="; T;
1824  buildtreetoMaple(T,"Tb","Tb.txt");
1825}
1826
1827// auxiliary routine called by buildtreetoMaple
1828// input:
1829//   list L: element i of the list of buildtree(F)
1830// output:
1831//   the string of T[[lab,1]]:=label; in Maple
1832static proc btterminal(string T, list L)
1833{
1834  int i;
1835  string Li;
1836  string term;
1837  string coma=",";
1838  if (L[2]==0){term="false";} else {term="true";}
1839  def lab=L[1];
1840  string slab;
1841  if ((size(lab)==1) and lab[1]==-1)
1842  {slab="";coma="";} //if (size(lab)==0)
1843  else
1844  {
1845    slab=string(lab[1]);
1846    if (size(lab)>=1)
1847    {
1848      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1849    }
1850  }
1851  Li=string(T,"[[",slab,coma,"6]]:=",term,"; ");
1852  return(Li);
1853}
1854
1855// auxiliary routine called by buildtreetoMaple
1856// input:
1857//   list L: element i of the list of buildtree(F)
1858// output:
1859//   the string of T[[lab,3]] (basis); in Maple
1860static proc btbasis(string T, list L)
1861{
1862  int i;
1863  string Li;
1864  string coma=",";
1865  def lab=L[1];
1866  string slab;
1867  if ((size(lab)==1) and lab[1]==-1)
1868  {slab="";coma="";} //if (size(lab)==0)
1869  else
1870  {
1871    slab=string(lab[1]);
1872    if (size(lab)>=1)
1873    {
1874      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1875    }
1876  }
1877  Li=string(T,"[[",slab,coma,"3]]:=[",L[3],"]; ");
1878  return(Li);
1879}
1880
1881// auxiliary routine called by buildtreetoMaple
1882// input:
1883//   list L: element i of the list of buildtree(F)
1884// output:
1885//   the string of T[[lab,4]] (null conditions ideal); in Maple
1886static proc btN(string T, list L)
1887{
1888  int i;
1889  string Li;
1890  string coma=",";
1891  def lab=L[1];
1892  string slab;
1893  if ((size(lab)==1) and lab[1]==-1)
1894  {slab=""; coma="";}
1895  else
1896  {
1897    slab=string(lab[1]);
1898    if (size(lab)>=1)
1899    {
1900      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1901    }
1902  }
1903  if ((size(lab)==1) and lab[1]==-1)
1904    {Li=string(T,"[[",slab,coma,"4]]:=[ ]; ");}
1905  else
1906    {Li=string(T,"[[",slab,coma,"4]]:=[",L[4],"]; ");}
1907  return(Li);
1908}
1909
1910// auxiliary routine called by buildtreetoMaple
1911// input:
1912//   list L: element i of the list of buildtree(F)
1913// output:
1914//   the string of T[[lab,5]] (null conditions ideal); in Maple
1915static proc btW(string T, list L)
1916{
1917  int i;
1918  string Li;
1919  string coma=",";
1920  def lab=L[1];
1921  string slab;
1922  if ((size(lab)==1) and lab[1]==-1)
1923  {slab=""; coma="";}
1924  else
1925  {
1926    slab=string(lab[1]);
1927    if (size(lab)>=1)
1928    {
1929      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1930    }
1931  }
1932  if (size(L[5])==0)
1933    {Li=string(T,"[[",slab,coma,"5]]:={ }; ");}
1934  else
1935    {Li=string(T,"[[",slab,coma,"5]]:={",L[5],"}; ");}
1936  return(Li);
1937}
1938
1939// auxiliary routine called by buildtreetoMaple
1940// input:
1941//   list L: element i of the list of buildtree(F)
1942// output:
1943//   the string of T[[lab,12]] (lpp); in Maple
1944static proc btlpp(string T, list L)
1945{
1946  int i;
1947  string Li;
1948  string coma=",";;
1949  def lab=L[1];
1950  string slab;
1951  if ((size(lab)==1) and lab[1]==-1)
1952  {slab=""; coma="";}
1953  else
1954  {
1955    slab=string(lab[1]);
1956    if (size(lab)>=1)
1957    {
1958      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1959    }
1960  }
1961  if (size(L[7])==0)
1962  {
1963    Li=string(T,"[[",slab,coma,"12]]:=[ ]; ");
1964  }
1965  else
1966  {
1967    Li=string(T,"[[",slab,coma,"12]]:=[",L[7],"]; ");
1968  }
1969  return(Li);
1970}
1971
1972// auxiliary routine called by buildtreetoMaple
1973// input:
1974//   list L: element i of the list of buildtree(F)
1975// output:
1976//   the list of strings of (T[[lab,0]]=0,T[[lab,1]]<>0); in Maple
1977static proc btcond(string T, list L, poly cond)
1978{
1979  int i;
1980  string Li1;
1981  string Li2;
1982  def lab=L[1];
1983  string slab;
1984  string coma=",";;
1985    if ((size(lab)==1) and lab[1]==-1)
1986    {slab=""; coma="";}
1987  else
1988  {
1989    slab=string(lab[1]);
1990    if (size(lab)>=1)
1991    {
1992      for (i=2;i<=size(lab);i++){slab=string(slab,",",lab[i]);}
1993    }
1994  }
1995  Li1=string(T,"[[",slab+coma,"0]]:=",L[8],"=0; ");
1996  Li2=string(T,"[[",slab+coma,"1]]:=",L[8],"<>0; ");
1997  return(list(Li1,Li2));
1998}
1999
2000//*****************End of BuildtreetoMaple*********************
2001
2002//*****************Begin of Selectcases************************
2003
2004// given an intvec with sum=n
2005// it returns the list of intvect with the sum=n+1
2006static proc comp1(intvec l)
2007{
2008  list L;
2009  int p=size(l);
2010  int i;
2011  if (p==0){return(l);}
2012  if (p==1){return(list(intvec(l[1]+1)));}
2013  L[1]=intvec((l[1]+1),l[2..p]);
2014  L[p]=intvec(l[1..p-1],(l[p]+1));
2015  for (i=2;i<p;i++)
2016  {
2017    L[i]=intvec(l[1..(i-1)],(l[i]+1),l[(i+1)..p]);
2018  }
2019  return(L);
2020}
2021
2022// comp: p-compositions of n
2023// input
2024//   int n;
2025//   int p;
2026// return
2027//   the list of all intvec (p-composition of n)
2028static proc comp(int n,int p)
2029{
2030  if (n<0){ERROR("comp was called with negative argument");}
2031  if (n==0){return(list(0:p));}
2032  int i;
2033  int k;
2034  list L1=comp(n-1,p);
2035  list L=comp1(L1[1]);
2036  list l;
2037  list la;
2038  for (i=2; i<=size(L1);i++)
2039  {
2040    l=comp1(L1[i]);
2041    for (k=1;k<=size(l);k++)
2042    {
2043      if(not(memberpos(l[k],L)[1]))
2044      {L[size(L)+1]=l[k];}
2045    }
2046  }
2047  return(L);
2048}
2049
2050// given the matrices of coefficients and monomials m amd m1 of
2051// two polynomials (the first one contains all the terms of f
2052// and the second only those of f
2053// it returns the list with the comon monomials and the list of coefficients
2054// of the polynomial f with zeroes if necessary.
2055static proc adaptcoef(matrix m, matrix m1)
2056{
2057  int i;
2058  int j;
2059  int ncm=ncols(m);
2060  int ncm1=ncols(m1);
2061  ideal T;
2062  for (i=1;i<=ncm;i++){T[i]=m[1,i];}
2063  ideal C;
2064  for (i=1;i<=ncm;i++){C[i]=0;}
2065  for (i=1;i<=ncm;i++)
2066  {
2067    j=1;
2068    while((j<ncm1) and (m1[1,j]>m[1,i])){j++;}
2069    if (m1[1,j]==m[1,i]){C[i]=m1[2,j];}
2070  }
2071  return(list(T,C));
2072}
2073
2074// given teh ideal of non-null conditions and an intvec lambda
2075// with the exponents of each w in W
2076// it returns the polynomial prod (w_i)^(lambda_i).
2077static proc WW(ideal W, intvec lambda)
2078{
2079  if (size(W)==0){return(poly(1));}
2080  poly w=1;
2081  int i;
2082  for (i=1;i<=ncols(W);i++)
2083  {
2084    w=w*(W[i])^(lambda[i]);
2085  }
2086  return(w);
2087}
2088
2089// given a polynomial f and the non-null conditions W
2090// WPred eliminates the factors in f that are in W
2091// ring @PAB
2092// input:
2093//   poly f:
2094//   ideal W  of non-null conditions (already supposed that it is facvar)
2095// output:
2096//   poly f2  where the non-null conditions in W have been dropped from f
2097static proc WPred(poly f, ideal W)
2098{
2099  if (f==0){return(f);}
2100  def l=factorize(f,2);
2101  int i;
2102  poly f1=1;
2103  for(i=1;i<=size(l[1]);i++)
2104  {
2105    if (memberpos(l[1][i],W)[1]){;}
2106    else{f1=f1*((l[1][i])^(l[2][i]));}
2107  }
2108  return(f1);
2109}
2110
2111//genimage
2112// ring @R
2113//input:
2114//   poly f1, idel N1,ideal W1,poly f2, ideal N2, ideal W2
2115//   corresponding to two polynomials having the same lpp
2116//   f1 in the redspec given by N1,W1,  f2 in the redspec given by N2,W2
2117//output:
2118//   the list of (ideal GG, list(list r1, list r2))
2119//   where g an ideal whose elements have the same lpp as f1 and f2
2120//   that specialize well to f1 in N1,W1 and to f2 in N2,W2.
2121//   If it doesn't exist a genimage, then g=ideal(0).
2122static proc genimage(poly f1, ideal N1, ideal W1, poly f2, ideal N2, ideal W2)
2123{
2124  int i; ideal W12;  poly ff1; poly g1=0; ideal GG;
2125  int tt=1;
2126  // detect weather f1 reduces to 0 on segment 2
2127  ff1=pnormalform(f1,N2,W2);
2128  if (ff1==0)
2129  {
2130    // detect weather N1 is included in N2
2131    def RR=basering;
2132    setring @P;
2133    def NP1=imap(RR,N1);
2134    def NP2=imap(RR,N2);
2135    attrib(NP2,"isSB",1);
2136    poly nr;
2137    i=1;
2138    while ((tt) and (i<=size(NP1)))
2139    {
2140      nr=reduce(NP1[i],NP2);
2141      if (nr!=0){tt=0;}
2142      i++;
2143    }
2144    setring(RR);
2145  }
2146  else{tt=0;}
2147  if (tt==1)
2148  {
2149    // detect weather W1 intersect W2 is non-empty
2150    for (i=1;i<=size(W1);i++)
2151    {
2152      if (memberpos(W1[i],W2)[1])
2153      {
2154        W12[size(W12)+1]=W1[i];
2155      }
2156      else
2157      {
2158        if (nonnull(W1[i],N2,W2))
2159        {
2160          W12[size(W12)+1]=W1[i];
2161        }
2162      }
2163    }
2164    for (i=1;i<=size(W2);i++)
2165    {
2166      if (not(memberpos(W2[i],W12)[1]))
2167      {
2168        W12[size(W12)+1]=W2[i];
2169      }
2170    }
2171  }
2172  if (tt==1){g1=extendpoly(f1,N1,W12);}
2173  if (g1!=0)
2174  {
2175    if (pnormalform(g1,N1,W1)==0)
2176    {
2177      GG=f1,g1;
2178    }
2179    else
2180    {
2181      GG=g1;
2182    }
2183    return(GG);
2184  }
2185
2186  // begins the second step;
2187  int bound=6;
2188  // in ring @R
2189  int j; int g=0; int alpha; int r1; int s1=1; int s2=1;
2190  poly G;
2191  matrix qT;
2192  matrix T;
2193  ideal N10;
2194  poly GT;
2195  ideal N12=N1,N2;
2196  def varx=maxideal(1);
2197  int nx=size(varx);
2198  poly pvarx=1;
2199  for (i=1;i<=nx;i++){pvarx=pvarx*varx[i];}
2200  def m=coef(43*f1+157*f2,pvarx);
2201  def m1=coef(f1,pvarx);
2202  def m2=coef(f2,pvarx);
2203  list L1=adaptcoef(m,m1);
2204  list L2=adaptcoef(m,m2);
2205  ideal Tm=L1[1];
2206  ideal c1=L1[2];
2207  ideal c2=L2[2];
2208  poly ww1;
2209  poly ww2;
2210  poly cA1;
2211  poly cB1;
2212  matrix TT;
2213  poly H;
2214  list r;
2215  ideal q;
2216  poly mu;
2217  ideal N;
2218
2219  // in ring @PAB
2220  list Px=ringlist(@P);
2221  list v="@A","@B";
2222  Px[2]=Px[2]+v;
2223  def npx=size(Px[3][1][2]);
2224  Px[3][1][2]=1:(npx+size(v));
2225  def @PAB=ring(Px);
2226  setring(@PAB);
2227
2228  poly PH;
2229  ideal NP;
2230  list rP;
2231  def PN1=imap(@R,N1);
2232  def PW1=imap(@R,W1);
2233  def PN2=imap(@R,N2);
2234  def PW2=imap(@R,W2);
2235  def a1=imap(@R,c1);
2236  def a2=imap(@R,c2);
2237  matrix PT;
2238  ideal PN;
2239  ideal PN12=PN1,PN2;
2240  PN=liftstd(PN12,PT);
2241  list compos1;
2242  list compos2;
2243  list compos0;
2244  intvec comp0;
2245  poly w1=0;
2246  poly w2=0;
2247  poly h;
2248  poly cA=0;
2249  poly cB=0;
2250  int t=0;
2251  list l;
2252  poly h1;
2253  g=0;
2254  while ((g<=bound) and not(t))
2255  {
2256    compos0=comp(g,2);
2257    r1=1;
2258    while ((r1<=size(compos0)) and not(t))
2259    {
2260      comp0=compos0[r1];
2261      if (comp0[1]<=bound div 2)
2262      {
2263        compos1=comp(comp0[1],ncols(PW1));
2264        s1=1;
2265        while ((s1<=size(compos1)) and not(t))
2266        {
2267          if (comp0[2]<=bound div 2)
2268          {
2269            compos2=comp(comp0[2],ncols(PW2));
2270            s2=1;
2271            while ((s2<=size(compos2)) and not(t))
2272            {
2273              w1=WW(PW1,compos1[s1]);
2274              w2=WW(PW2,compos2[s2]);
2275              h=@A*w1*a1[1]-@B*w2*a2[1];
2276              h=reduce(h,PN);
2277              if (h==0){cA=1;cB=-1;}
2278              else
2279              {
2280                l=factorize(h,2);
2281                h1=1;
2282                for(i=1;i<=size(l[1]);i++)
2283                {
2284                  if ((memberpos(@A,variables(l[1][i]))[1]) or  (memberpos(@B,variables(l[1][i]))[1]))
2285                  {h1=h1*l[1][i];}
2286                }
2287                cA=diff(h1,@B);
2288                cB=diff(h1,@A);
2289              }
2290              if ((cA!=0) and (cB!=0) and (jet(cA,0)==cA) and (jet(cB,0)==cB))
2291              {
2292                t=1;
2293                alpha=1;
2294                while((t) and (alpha<=ncols(a1)))
2295                {
2296                  h=cA*w1*a1[alpha]+cB*w2*a2[alpha];
2297                  if (not(reduce(h,PN,1)==0)){t=0;}
2298                  alpha++;
2299                }
2300              }
2301              else{t=0;}
2302              s2++;
2303            }
2304          }
2305          s1++;
2306        }
2307      }
2308      r1++;
2309    }
2310    g++;
2311  }
2312  setring(@R);
2313  ww1=imap(@PAB,w1);
2314  ww2=imap(@PAB,w2);
2315  T=imap(@PAB,PT);
2316  N=imap(@PAB,PN);
2317  cA1=imap(@PAB,cA);
2318  cB1=imap(@PAB,cB);
2319  if (t)
2320  {
2321    G=0;
2322    for (alpha=1;alpha<=ncols(Tm);alpha++)
2323    {
2324      H=cA1*ww1*c1[alpha]+cB1*ww2*c2[alpha];
2325      setring(@PAB);
2326      PH=imap(@R,H);
2327      PN=imap(@R,N);
2328      rP=division(PH,PN);
2329      setring(@R);
2330      r=imap(@PAB,rP);
2331      if (r[2][1]!=0){ERROR("the division is not null and it should be");}
2332      q=r[1];
2333      qT=transpose(matrix(q));
2334      N10=N12;
2335      for (i=size(N1)+1;i<=size(N1)+size(N2);i++){N10[i]=0;}
2336      G=G+(cA1*ww1*c1[alpha]-(matrix(N10)*T*qT)[1,1])*Tm[alpha];
2337    }
2338    GG=ideal(G);
2339  }
2340  else{GG=ideal(0);}
2341  return(GG);
2342}
2343
2344// purpose: given a polynomial f (in the reduced basis)
2345//          the null-conditions ideal N in the segment
2346//          end the set of non-null polynomials common to the segment and
2347//          a new segment,
2348//          to obtain an equivalent polynomial with a leading coefficient
2349//          that is non-null in the second segment.
2350// input:
2351// poly f:    a polynomials of the reduced basis in the segment (N,W)
2352// ideal N:   the null-conditions ideal in the segment
2353// ideal W12: the set of non-null polynomials common to the segment and
2354//            a second segment
2355static proc extendpoly(poly f, ideal N, ideal W12)
2356{
2357  int bound=4;
2358  ideal cfs;
2359  ideal cfsn;
2360  ideal ppfs;
2361  poly p=f;
2362  poly fn;
2363  poly lm; poly lc;
2364  int tt=0;
2365  int i;
2366  while (p!=0)
2367  {
2368    lm=leadmonom(p);
2369    lc=leadcoef(p);
2370    cfs[size(cfs)+1]=lc;
2371    ppfs[size(ppfs)+1]=lm;
2372    p=p-lc*lm;
2373  }
2374  def lcf=cfs[1];
2375  int r1=0; int s1;
2376  def RR=basering;
2377  setring @P;
2378  list compos1;
2379  poly w1;
2380  ideal q;
2381  def lcfp=imap(RR,lcf);
2382  def W=imap(RR,W12);
2383  def Np=imap(RR,N);
2384  def cfsp=imap(RR,cfs);
2385  ideal cfspn;
2386  matrix T;
2387  ideal H=lcfp,Np;
2388  def G=liftstd(H,T);
2389  list r;
2390  while ((r1<=bound) and not(tt))
2391  {
2392    compos1=comp(r1,ncols(W));
2393    s1=1;
2394    while ((s1<=size(compos1)) and not(tt))
2395    {
2396      w1=WW(W,compos1[s1]);
2397      cfspn=ideal(0);
2398      cfspn[1]=w1;
2399      tt=1;
2400      i=2;
2401      while ((i<=size(cfsp)) and (tt))
2402      {
2403        r=division(w1*cfsp[i],G);
2404        if (r[2][1]!=0){tt=0;}
2405        else
2406        {
2407          q=r[1];
2408          cfspn[i]=(T*transpose(matrix(q)))[1,1];
2409        }
2410        i++;
2411      }
2412      s1++;
2413    }
2414    r1++;
2415  }
2416  setring RR;
2417  if (tt)
2418  {
2419    cfsn=imap(@P,cfspn);
2420    fn=0;
2421    for (i=1;i<=size(ppfs);i++)
2422    {
2423      fn=fn+cfsn[i]*ppfs[i];
2424    }
2425  }
2426  else{fn=0;}
2427  return(fn);
2428}
2429
2430// nonnull
2431// ring @P (or @R)
2432// input:
2433//   poly f
2434//   ideal N
2435//   ideal W
2436// output:
2437//   1 if f is nonnull in the segment (N,W)
2438//   0 if it can be zero
2439static proc nonnull(poly f, ideal N, ideal W)
2440{
2441  int tt;
2442  ideal N0=N;
2443  N0[size(N0)+1]=f;
2444  poly h=1;
2445  int i;
2446  for (i=1;i<=size(W);i++){h=h*W[i];}
2447  def RR=basering;
2448  setring(@P);
2449  list Px=ringlist(@P);
2450  list v="@C";
2451  Px[2]=Px[2]+v;
2452  def npx=size(Px[3][1][2]);
2453  Px[3][1][1]="dp";
2454  Px[3][1][2]=1:(npx+size(v));
2455  def @PC=ring(Px);
2456  setring(@PC);
2457  def N1=imap(RR,N0);
2458  def h1=imap(RR,h);
2459  ideal G=1-@C*h1;
2460  G=G+N1;
2461  option(redSB);
2462  ideal G1=std(G);
2463  if (G1[1]==1){tt=1;} else{tt=0;}
2464  setring(RR);
2465  return(tt);
2466}
2467
2468// decide
2469// input:
2470//   given two corresponding polynomials g1 and g2 with the same lpp
2471//   g1 belonging to the basis in the segment N1,W1
2472//   g2 belonging to the basis in the segment N2,W2
2473// output:
2474//   an ideal (with a single polynomial or more if a sheaf is needed)
2475//   that specializes well on both segments to g1 and g2 respectivelly.
2476//   If ideal(0) is output, then no such polynomial nor sheaf exists.
2477static proc decide(poly g1, ideal N1, ideal W1, poly g2, ideal N2, ideal W2)
2478{
2479  poly S;
2480  poly S1;
2481  poly S2;
2482  S=leadcoef(g2)*g1-leadcoef(g1)*g2;
2483  def RR=basering;
2484  setring(@RP);
2485  def SR=imap(RR,S);
2486  def N1R=imap(RR,N1);
2487  def N2R=imap(RR,N2);
2488  attrib(N1R,"isSB",1);
2489  attrib(N2R,"isSB",1);
2490  poly S1R=reduce(SR,N1R);
2491  poly S2R=reduce(SR,N2R);
2492  setring(RR);
2493  S1=imap(@RP,S1R);
2494  S2=imap(@RP,S2R);
2495  if ((S2==0) and (nonnull(leadcoef(g1),N2,W2))){return(ideal(g1));}
2496  if ((S1==0) and (nonnull(leadcoef(g2),N1,W1))){return(ideal(g2));}
2497  if ((S1==0) and (S2==0))
2498  {
2499    return(ideal(g1,g2));
2500  }
2501  return(ideal(genimage(g1,N1,W1,g2,N2,W2)));
2502}
2503
2504// input:  the tree (list) from buildtree output
2505// output: the list of terminal vertices.
2506static proc finalcases(list T)
2507//"USAGE:   finalcases(T);
2508//          T is the list provided by buildtree
2509//RETURN:   A list with the CGS determined by buildtree.
2510//          Each element of the list represents one segment
2511//          of the terminal vertices of buildtree givieng the CGS.
2512//          The list elements have the following structure:
2513//           [1]: label (an intvec(1,0,..)) that indicates the position
2514//                in the buildtree but that is irrelevant for the CGS
2515//           [2]: 1 (integer) it is also irrelevant and indicates
2516//                that this was a terminal vertex in buildtree.
2517//           [3]: the reduced basis of the segment.
2518//           [4], [5], [6]: the red-representation of the segment
2519//                [4] are the null-conditions radical ideal N,
2520//                [5] are the non-null polynomials set (ideal) W,
2521//                [6] is the set of prime components (ideals) of N.
2522//           [7]: is the set of lpp
2523//           [8]: poly 1 (irrelevant) is the condition to branch (but no
2524//                more branch is necessary in the discussion, so 1 is the result.
2525//NOTE:     It can be called having as argument the list output by buildtree
2526//KEYWORDS: buildtree, buildtreetoMaple, CGS
2527//EXAMPLE:  finalcases; shows an example"
2528{
2529  int i;
2530  list L;
2531  for (i=1;i<=size(T);i++)
2532  {
2533    if (T[i][2])
2534    {L[size(L)+1]=T[i];}
2535  }
2536  return(L);
2537}
2538//example
2539//{ "EXAMPLE:"; echo = 2;
2540//  ring R=(0,a1,a2,a3,a4),(x1,x2,x3,x4),dp;
2541//  ideal F=x4-a4+a2, x1+x2+x3+x4-a1-a3-a4, x1*x3*x4-a1*a3*a4, x1*x3+x1*x4+x2*x3+x3*x4-a1*a4-a1*a3-a3*a4;
2542//  def T=buildtree(F);
2543//  setglobalrings();
2544//  finalcases(T);
2545//}
2546
2547// input:  the list of terminal vertices of buildtree (output of finalcases)
2548// output: the same terminal vertices grouped by lpp
2549static proc groupsegments(list T)
2550{
2551  int i;
2552  list L;
2553  list lpp;
2554  list lp;
2555  list ls;
2556  int n=size(T);
2557  lpp[1]=T[n][7];
2558  L[1]=list(lpp[1],list(list(T[n][1],T[n][3],T[n][4],T[n][5],T[n][6])));
2559  if (n>1)
2560  {
2561    for (i=1;i<=size(T)-1;i++)
2562    {
2563      lp=memberpos(T[n-i][7],lpp);
2564      if(lp[1]==1)
2565      {
2566        ls=L[lp[2]][2];
2567        ls[size(ls)+1]=list(T[n-i][1],T[n-i][3],T[n-i][4],T[n-i][5],T[n-i][6]);
2568        L[lp[2]][2]=ls;
2569      }
2570      else
2571      {
2572        lpp[size(lpp)+1]=T[n-i][7];
2573        L[size(L)+1]=list(T[n-i][7],list(list(T[n-i][1],T[n-i][3],T[n-i][4],T[n-i][5],T[n-i][6])));
2574      }
2575    }
2576  }
2577  //"L in groupsegments="; L;
2578  return(L);
2579}
2580
2581// eliminates repeated elements form an ideal
2582static proc elimrepeated(ideal F)
2583{
2584  int i;
2585  int j;
2586  ideal FF;
2587  FF[1]=F[1];
2588  for (i=2;i<=ncols(F);i++;)
2589  {
2590    if (not(memberpos(F[i],FF)[1]))
2591    {
2592      FF[size(FF)+1]=F[i];
2593    }
2594  }
2595  return(FF);
2596}
2597
2598// decide F is the same as decide but allows as first element a sheaf F
2599static proc decideF(ideal F,ideal N,ideal W, poly f2, ideal N2, ideal W2)
2600{
2601  int i;
2602  ideal G=F;
2603  ideal g;
2604  if (ncols(F)==1) {return(decide(F[1],N,W,f2,N2,W2));}
2605  for (i=1;i<=ncols(F);i++)
2606  {
2607    G=G+decide(F[i],N,W,f2,N2,W2);
2608  }
2609  return(elimrepeated(G));
2610}
2611
2612// newredspec
2613// input:  two redspec in the form of N,W and Nj,Wj
2614// output: a redspec representing the minimal redspec segment that contains
2615//         both input segments.
2616static proc newredspec(ideal N,ideal W, ideal Nj, ideal Wj)
2617{
2618  ideal nN;
2619  ideal nW;
2620  int u;
2621  def RR=basering;
2622  setring(@P);
2623  list r;
2624  def Np=imap(RR,N);
2625  def Wp=imap(RR,W);
2626  def Njp=imap(RR,Nj);
2627  def Wjp=imap(RR,Wj);
2628  Np=intersect(Np,Njp);
2629  ideal WR;
2630  for(u=1;u<=size(Wjp);u++)
2631  {
2632    if(nonnull(Wjp[u],Np,Wp)){WR[size(WR)+1]=Wjp[u];}
2633  }
2634  for(u=1;u<=size(Wp);u++)
2635  {
2636    if((not(memberpos(Wp[u],WR)[1])) and (nonnull(Wp[u],Njp,Wjp)))
2637    {
2638      WR[size(WR)+1]=Wp[u];
2639    }
2640  }
2641  r=redspec(Np,WR);
2642  option(redSB);
2643  Np=std(r[1]);
2644  Wp=r[2];
2645  setring(RR);
2646  nN=imap(@P,Np);
2647  nW=imap(@P,Wp);
2648  return(list(nN,nW));
2649}
2650
2651// selectcases
2652// input:
2653//   list bT: the list output by buildtree.
2654// output:
2655//   list L   it contins the list of segments allowing a common
2656//            reduced basis. The elements of L are of the form
2657//            list (lpp,B,list(list(N,W,L),..list(N,W,L)) )
2658static proc selectcases(list bT)
2659{
2660  list T=groupsegments(finalcases(bT));
2661  //NEW
2662  //groupredtocan(T);
2663  list T0=bT[1];
2664             // first element of the list of buildtree
2665  list TT0;
2666  TT0[1]=list(T0[7],T0[3],list(list(T0[4],T0[5],T0[6])));
2667             // first element of the output of selectcases
2668  list T1=T; // the initial list; it is only actualized (split)
2669             // when a segment is completly revised (all split are
2670             // already be considered);
2671             // ( (lpp, ((lab,B,N,W,L),.. ()) ), .. (..) )
2672  list TT;   // the output list ( (lpp,B,((N,W,L),..()) ),.. (..) )
2673  // case i
2674  list S1;   // the segments in case i T1[i][2]; ( (lab,B,N,W,L),..() )
2675  list S2;   // the segments in case i that are being summarized in
2676             // actual segment ( (N,W,L),..() )
2677  list S3;   // the segments in case i that cannot be summarized in
2678             // the actual case. When the case is finished a new case
2679             // is created with them ( (lab,B,N,W,L),..() )
2680  list s3;   // list of integers s whose segment cannot be summarized
2681             // in the actual case
2682  ideal lpp; // the summarized lpp (can contain repetitions)
2683  ideal lppi;// in process of sumarizing lpp (can contain repetitions)
2684  ideal B;   // the summarized B (can contain polynomials with
2685             // the same lpp (sheaves))
2686  ideal Bi;  // in process of summarizing B (can contain polynomials with
2687             // the same lpp (sheaves))
2688  ideal N;   // the summarized N
2689  ideal W;   // the summarized W
2690  ideal F;   // the summarized poly j (can contain a sheaf instead of
2691             // a single poly)
2692  ideal FF;  // the same as F but it can be ideal(0)
2693  poly lpj;
2694  poly fj;
2695  ideal Nj;
2696  ideal Wj;
2697  ideal G;
2698  int i;     // the index of the case i in T1;
2699  int j;     // the index of the polynomial j of the basis
2700  int s;     // the index of the segment s in S1;
2701  int u;
2702  int tests; // true if al the polynomial in segment s have been generalized;
2703  list r;
2704  // initializing the new list
2705  i=1;
2706  while(i<=size(T1))
2707  {
2708    S1=T1[i][2]; // ((lab,B,N,W,L)..) of the segments in case i
2709    if (size(S1)==1)
2710    {
2711      TT[i]=list(T1[i][1],S1[1][2],list(list(S1[1][3],S1[1][4],S1[1][5])));
2712    }
2713    else
2714    {
2715      S2=list();
2716      S3=list(); // ((lab,B,N,W,L)..) of the segments in case i to
2717                 // create another segment i+1
2718      s3=list();
2719      B=S1[1][2];
2720      Bi=ideal(0);
2721      lpp=T1[i][1];
2722      j=1;
2723      tests=1;
2724      while (j<=size(S1[1][2]))
2725      { // j desings the new j-th polynomial
2726        N=S1[1][3];
2727        W=S1[1][4];
2728        F=ideal(S1[1][2][j]);
2729        s=2;
2730        while (s<=size(S1) and not(memberpos(s,s3)[1]))
2731        { // s desings the new segment s
2732          fj=S1[s][2][j];
2733          Nj=S1[s][3];
2734          Wj=S1[s][4];
2735          FF=decideF(F,N,W,fj,Nj,Wj);
2736          if (FF[1]==0)
2737          {
2738            if (@ish)
2739            {
2740              "Warning: Dealing with an homogeneous ideal";
2741              "mrcgs was not able to summarize all lpp cases into a single segment";
2742              "Please send a mail with your Problem to antonio.montes@upc.edu";
2743              "You found a counterexample of the complete success of the actual mrcgs algorithm";
2744              //NEW
2745              "f1:"; F; "N1:"; N; "W1:"; W; "f2:"; fj; "N2:"; Nj; "W2:"; Wj;
2746            }
2747            S3[size(S3)+1]=S1[s];
2748            s3[size(s3)+1]=s;
2749            tests=0;
2750          }
2751          else
2752          {
2753            F=FF;
2754            lpj=leadmonom(fj);
2755            r=newredspec(N,W,Nj,Wj);
2756            N=r[1];
2757            W=r[2];
2758          }
2759          s++;
2760        }
2761        if (Bi[1]==0){Bi=FF;}
2762        else
2763        {
2764          Bi=Bi+FF;
2765        }
2766        j++;
2767      }
2768      if (tests)
2769      {
2770        B=Bi;
2771        lpp=ideal(0);
2772        for (u=1;u<=size(B);u++){lpp[u]=leadmonom(B[u]);}
2773      }
2774      for (s=1;s<=size(T1[i][2]);s++)
2775      {
2776        if (not(memberpos(s,s3)[1]))
2777        {
2778          S2[size(S2)+1]=list(S1[s][3],S1[s][4],S1[s][5]);
2779        }
2780      }
2781      TT[i]=list(lpp,B,S2);
2782      // for (s=1;s<=size(s3);s++){S1=delete(S1,s);}
2783      T1[i][2]=S2;
2784      if (size(S3)>0){T1=insert(T1,list(T1[i][1],S3),i);}
2785    }
2786    i++;
2787  }
2788  for (i=1;i<=size(TT);i++){TT0[i+1]=TT[i];}
2789  return(TT0);
2790}
2791
2792//*****************End of Selectcases**************************
2793
2794//*****************Begin of CanTree****************************
2795
2796// equalideals
2797// input: 2 ideals F and G;
2798// output: 1 if they are identical (the same polynomials in the same order)
2799//         0 else
2800static proc equalideals(ideal F, ideal G)
2801{
2802  int i=1; int t=1;
2803  if (size(F)!=size(G)){return(0);}
2804  while ((i<=size(F)) and (t))
2805  {
2806    if (F[i]!=G[i]){t=0;}
2807    i++;
2808  }
2809  return(t);
2810}
2811
2812// delintvec
2813// input: intvec V
2814//        int i
2815// output:
2816//        intvec W (equal to V but the coordinate i is deleted
2817static proc delintvec(intvec V, int i)
2818{
2819  int j;
2820  intvec W;
2821  for (j=1;j<i;j++){W[j]=V[j];}
2822  for (j=i+1;j<=size(V);j++){W[j-1]=V[j];}
2823  return(W);
2824}
2825
2826// redtocanspec
2827// Computes the canonical representation of a redspec (N,W,L).
2828// input:
2829//    ideal N (null conditions, must be radical)
2830//    ideal W (non-null conditions ideal)
2831//    list L  must contain the radical decomposition of N.
2832// output:
2833//    the list of elements of the (ideal N1,list(ideal M11,..,ideal M1k))
2834//    determining the canonical representation of the difference of
2835//    V(N) \ V(h), where h=prod(w in W).
2836static proc redtocanspec(intvec lab, int child, list rs)
2837{
2838  ideal N=rs[1]; ideal W=rs[2]; list L=rs[3];
2839  intvec labi; intvec labij;
2840  int childi;
2841  int i; int j; list L0;
2842  L0[1]=list(lab,size(L));
2843  if (W[1]==0)
2844  {
2845    for (i=1;i<=size(L);i++)
2846    {
2847      labi=lab,child+i;
2848      L0[size(L0)+1]=list(labi,1,L[i]);
2849      labij=labi,1;
2850      L0[size(L0)+1]=list(labij,0,ideal(1));
2851    }
2852    return(L0);
2853  }
2854  if (N[1]==1)
2855  {
2856    L0[1]=list(lab,1);
2857    labi=lab,child+1;
2858    L0[size(L0)+1]=list(labi,1,ideal(1));
2859    labij=labi,1;
2860    L0[size(L0)+1]=list(labij,0,ideal(1));
2861  }
2862  def RR=basering;
2863  setring(@P);
2864  ideal Np=imap(RR,N);
2865  ideal Wp=imap(RR,W);
2866  poly h=1;
2867  for (i=1;i<=size(Wp);i++){h=h*Wp[i];}
2868  list Lp=imap(RR,L);
2869  list r; list Ti; list LL;
2870  LL[1]=list(lab,size(Lp));
2871  for (i=1;i<=size(Lp);i++)
2872  {
2873    Ti=minGTZ(Lp[i]+h);
2874    for(j=1;j<=size(Ti);j++)
2875    {
2876      option(redSB);
2877      Ti[j]=std(Ti[j]);
2878    }
2879    labi=lab,child+i;
2880    childi=size(Ti);
2881    LL[size(LL)+1]=list(labi,childi,Lp[i]);
2882    for (j=1;j<=childi;j++)
2883    {
2884      labij=labi,j;
2885      LL[size(LL)+1]=list(labij,0,Ti[j]);
2886    }
2887  }
2888  LL[1]=list(lab,size(Lp));
2889  setring(RR);
2890  return(imap(@P,LL));
2891}
2892
2893// difftocanspec
2894// Computes the canonical representation of a diffspec V(N) \ V(M)
2895// input:
2896//    intvec lab: label where to hang the canspec
2897//    list  N ideal of null conditions.
2898//    ideal M ideal of the variety to be substacted
2899// output:
2900//    the list of elements determining the canonical representation of
2901//    the difference  V(N) \ V(M):
2902//      ( (intvec(i),children), ...(lab, children, prime ideal),...)
2903static proc difftocanspec(intvec lab, int child, ideal N, ideal M)
2904{
2905  int i; int j; list LLL;
2906  def RR=basering;
2907  setring(@P);
2908  ideal Np=imap(RR,N);
2909  ideal Mp=imap(RR,M);
2910  def L=minGTZ(Np);
2911  for(j=1;j<=size(L);j++)
2912  {
2913    option(redSB);
2914    L[j]=std(L[j]);
2915  }
2916  intvec labi; intvec labij;
2917  int childi;
2918  list LL;
2919  if ((Mp[1]==0) or ((size(L)==1) and (L[1][1]==1)))
2920  {
2921    //LL[1]=list(lab,1);
2922    //labi=lab,1;
2923    //LL[2]=list(labi,1,ideal(1));
2924    //labij=labi,1;
2925    //LL[3]=list(labij,0,ideal(1));
2926    setring(RR);
2927    return(LLL);
2928  }
2929  list r; list Ti;
2930  def k=0;
2931  LL[1]=list(lab,0);
2932  for (i=1;i<=size(L);i++)
2933  {
2934    Ti=minGTZ(L[i]+Mp);
2935    for(j=1;j<=size(Ti);j++)
2936    {
2937      option(redSB);
2938      Ti[j]=std(Ti[j]);
2939    }
2940    if (not((size(Ti)==1) and (equalideals(L[i],Ti[1]))))
2941    {
2942      k++;
2943      labi=lab,child+k;
2944      childi=size(Ti);
2945      LL[size(LL)+1]=list(labi,childi,L[i]);
2946      for (j=1;j<=childi;j++)
2947      {
2948        labij=labi,j;
2949        LL[size(LL)+1]=list(labij,0,Ti[j]);
2950      }
2951    }
2952    else{setring(RR); return(LLL);}
2953  }
2954  if (size(LL)>0)
2955  {
2956    LL[1]=list(lab,k);
2957    setring(RR);
2958    return(imap(@P,LL));
2959  }
2960  else {setring(RR); return(LLL);}
2961}
2962
2963// tree
2964// purpose: given a label and the list L of vertices of the tree,
2965//          whose content
2966//          are of the form list(intvec lab, int children, ideal P)
2967//          to obtain the vertex and its position
2968// input:
2969//  intvec lab: label of the vertex
2970//  list:  L    the list containing the vertices
2971// output:
2972//  list   V    the vertex list(lab, children, P)
2973static proc tree(intvec lab,list L)
2974{
2975  int i=0; int tt=1; list V; intvec labi;
2976  while ((i<size(L)) and (tt))
2977  {
2978    i++;
2979    labi=L[i][1];
2980    if (labi==lab)
2981    {
2982      V=list(L[i],i);
2983      tt=0;
2984    }
2985  }
2986  if (tt==0){return(V);}
2987  else{return(list(list(intvec(0)),0));}
2988}
2989
2990// GCR (generalized canonical representation)
2991// new structure of a GCR
2992
2993// L is a list of vertices V of the GCR.
2994// first vertex=list(intvec lab, int children, ideal lpp, ideal B)
2995// other vertices=list(intvec lab, int children, ideal P)
2996// the individual vertices can be accessed with the function tree
2997// by the call  V=tree(lab,L), that outputs the vertex if it exists
2998// and its position in L, or nothing if it does not exist.
2999// The first element of the list must be the root of the tree and has
3000// label lab=i, and other information.
3001
3002// example:
3003// the canonical representation
3004// V(a^2-ac-ba+c-abc) \ (union( V(b,a), V(c,a), V(b,a-c), V(c,a-b)))
3005// is represented by  the list
3006// L=((intvec(i),children=1,lpp,B),(intvec(i,1),4,ideal(a^2-ac-ba+c-abc)),
3007//    (intvec(i,1,1),0,ideal(b,a)),     (intvec(i,1,2),0,ideal(c,a)),
3008//    (intvec(i,1,3),0,ideal(b,a-c)),   (intvec(i,1,4),0,ideal(c,a-b))
3009//   )
3010// example:
3011// the canonical representation
3012// (V(a)\(union(V(c,a),V(b+c,a),V(b,a)))) union
3013// (V(b)\(union(V(b,a),V(b,a-c))))        union
3014// (V(c)\(union(V(c,a),V(c,a-b))))
3015// is represented by  the list
3016// L=((i,children=3,lpp,B),
3017//    (intvec(i,1),3,ideal(a)),
3018//    (intvec(i,1,1),0,(c,a)),(intvec(i,1,2),0,(b+c,a)),(intvec(i,1,3),0,(b,a)),
3019//    (intvec(i,2),2,ideal(b)),
3020//    (intvec(i,2,1),0,(b,a)),(intvec(i,2,2),0,(b,a-c)),
3021//    (intvec(i,3),2,ideal(c)),
3022//    (intvec(i,3,1),0,(c,a)),(intvec(i,3,2),0,(c,a-b))
3023//   )
3024// If L is the list in the last example, the call
3025// tree(intvec(i,2,1),L) will output   ((intvec(i,2,1),0,(b,a)),7)
3026
3027// GCR
3028// input: list T is supposed to be an element L[i] of selectcases:
3029//        T= list( ideal lpp, ideal B, list(N,W,L),.., list(N,W,L))
3030// output: the list L of vertices being the GCR of the addition of
3031//         all the segments in T.
3032//         list(list(intvec lab, int children, ideal lpp, ideal B),
3033//              list(intvec lab, int children, ideal P),..
3034//         )
3035static proc GCR(intvec lab, list case)
3036{
3037  int i; int ii; int t;
3038  list @L;
3039  @L[1]=list(lab,0,case[1],case[2]);
3040  exportto(Top,@L);
3041  int j;
3042  list u; intvec labu; int childu;
3043  list v; intvec labv; int childv;
3044  list T=case[3];
3045  for (j=1;j<=size(T);j++)
3046  {
3047    t=addcase(lab,T[j]);
3048    deletebrotherscontaining(lab);
3049  }
3050  relabelingindices(lab,lab);
3051  list L=@L;
3052  kill @L;
3053  return(L);
3054}
3055
3056// sorbylab:
3057// pupose: given the list of mrcgs to order is by increasing label
3058static proc sortbylab(list L)
3059{
3060  int n=L[1][2];
3061  int i; int j;
3062  list H=L;
3063  list LL;
3064  list L1;
3065  //LL[1]=L[1];
3066  //H=delete(H,1);
3067  while (size(H)!=0)
3068  {
3069    j=1;
3070    L1=H[1];
3071    for (i=1;i<=size(H);i++)
3072    {
3073      if(lesslab(H[i],L1)){j=i;L1=H[j];}
3074    }
3075    LL[size(LL)+1]=L1;
3076    H=delete(H,j);
3077  }
3078  return(LL);
3079}
3080
3081// lesslab
3082// purpose: given two elements of the list of mrcgs it
3083// returns 1 if the label of the first is less than that of the second
3084static proc lesslab(list l1, list l2)
3085{
3086  intvec lab1=l1[1];
3087  intvec lab2=l2[1];
3088  int n1=size(lab1);
3089  int n2=size(lab2);
3090  int n=n1;
3091  if (n2<n1){n=n2;}
3092  int tt=0;
3093  int j=1;
3094  while ((lab1[j]==lab2[j]) and (j<n)){j++;}
3095  if (lab1[j]<lab2[j]){tt=1;}
3096  if ((j==n) and (lab1[j]==lab2[j]) and (n2>n1)){tt=1;}
3097  return(tt);
3098}
3099
3100// cantree
3101// input:  the list provided by selectcases
3102// output: the list providing the canonicaltree
3103static proc cantree(list S)
3104{
3105  string method=" ";
3106  list T0=S[1];
3107    // first element of the list of selectcases
3108  int i; int j;
3109  list L;
3110  list T;
3111  L[1]=list(intvec(0),size(S)-1,T0[1],T0[2],T0[3][1],method);
3112  for (i=2;i<=size(S);i++)
3113  {
3114    T=GCR(intvec(i-1),S[i]);
3115    T=sortbylab(T);
3116    for (j=1;j<=size(T);j++)
3117    {L[size(L)+1]=T[j];}
3118  }
3119  return(L);
3120}
3121
3122// addcase
3123// recursive routine that adds to the list @L, (an alredy GCR)
3124// a new redspec rs=(N,W,L);
3125// and returns the test t whose value is
3126// 0 if the new canspec is not to be hung to the fathers vertex,
3127// 1 if yes.
3128static proc addcase(intvec labu, list rs)
3129{
3130  int i; int j; int childu; ideal Pu;
3131  list T; int nchildu;
3132  def N=rs[1]; def W=rs[2]; def PN=rs[3];
3133  ideal NN; ideal MM;
3134  int tt=1;
3135  poly h=1; for (i=1;i<=size(W);i++){h=h*W[i];}
3136  list u=tree(labu,@L); childu=u[1][2];
3137  list v; intvec labv; int childv; list w; intvec labw;
3138  if (childu>0)
3139  {
3140    v=firstchild(u[1][1]);
3141    while(v[2][1]!=0)
3142    {
3143      labv=v[1][1];
3144      w=firstchild(labv);
3145      while(w[2][1]!=0)
3146      {
3147        labw=w[1][1];
3148        if(addcase(labw,rs)==0)
3149        {tt=0;}
3150        w=nextbrother(labw);
3151      }
3152      u=tree(labu,@L);
3153      childu=u[1][2];
3154      v=nextbrother(v[1][1]);
3155    }
3156    deletebrotherscontaining(labu);
3157    relabelingindices(labu,labu);
3158  }
3159  if (tt==1)
3160  {
3161    u=tree(labu,@L);
3162    nchildu=lastchildrenindex(labu);
3163    if (size(labu)==1)
3164    {
3165      T=redtocanspec(labu,nchildu,rs);
3166      tt=0;
3167    }
3168    else
3169    {
3170      NN=N;
3171      if (containedP(u[1][3],N)){tt=0;}
3172      for (i=1;i<=size(u[1][3]);i++)
3173      {
3174        NN[size(NN)+1]=u[1][3][i];
3175      }
3176      MM=NN;
3177      MM[size(MM)+1]=h;
3178      T=difftocanspec(labu,nchildu,NN,MM);
3179    }
3180    if (size(T)>0)
3181    {
3182      @L[u[2]][2]=@L[u[2]][2]+T[1][2];
3183      for (i=2;i<=size(T);i++){@L[size(@L)+1]=T[i];}
3184      if (size(labu)>1)
3185      {
3186        simplifynewadded(labu);
3187      }
3188    }
3189    else{tt=1;}
3190  }
3191  return(tt);
3192}
3193
3194// reduceR
3195// reduces the polynomial f wrt N, in the ring @P
3196static proc reduceR(poly f, ideal N)
3197{
3198  def RR=basering;
3199  setring(@P);
3200  poly fP=imap(RR,f);
3201  ideal NP=imap(RR,N);
3202  attrib(NP,"isSB",1);
3203  poly rp=reduce(fP,NP);
3204  setring(RR);
3205  return(imap(@P,rp));
3206}
3207
3208// containedP
3209// returns 1 if ideal Pu is contained in ideal Pv
3210// returns 0 if not
3211// in ring @P
3212static proc containedP(ideal Pu,ideal Pv)
3213{
3214  int t=1;
3215  int n=ncols(Pu);
3216  int i=0;
3217  poly r=0;
3218  while ((t) and (i<n))
3219  {
3220    i++;
3221    r=reduceR(Pu[i],Pv);
3222    if (r!=0){t=0;}
3223  }
3224  return(t);
3225}
3226
3227// simplifynewadded
3228// auxiliary routine of addcase
3229// when a new redspec is added to a non terminal vertex,
3230// it is applied to simplify the addition.
3231// When Pu==Pv, the children of w are hung from u fathers
3232// and deleted the whole new addition.
3233// Finally, deletebrotherscontaining is applied to u fathers
3234// in order to eliminate branches contained.
3235static proc simplifynewadded(intvec labu)
3236{
3237  int t; int ii; int k; int kk; int j;
3238  intvec labfu=delintvec(labu,size(labu)); list fu; int childfu;
3239  list u=tree(labu,@L); int childu=u[1][2]; ideal Pu=u[1][3];
3240  list v; intvec labv; int childv; ideal Pv;
3241  list w; intvec labw; intvec nlab; list ww;
3242  if (childu>0)
3243  {
3244    v=firstchild(u[1][1]); labv=v[1][1]; childv=v[1][2]; Pv=v[1][3];
3245    ii=0;
3246    t=0;
3247    while ((not(t)) and (ii<childu))
3248    {
3249      ii++;
3250      if (equalideals(Pu,Pv))
3251      {
3252        fu=tree(labfu,@L);
3253        childfu=fu[1][2];
3254        j=lastchildrenindex(fu[1][1])+1;
3255        k=0;
3256        w=firstchild(v[1][1]);
3257        childv=v[1][2];
3258        for (kk=1;kk<=childv;kk++)
3259        {
3260          if (kk<childv){ww=nextbrother(w[1][1]);}
3261          nlab=labfu,j;
3262          @L[w[2]][1]=nlab;
3263          j++;
3264          if (kk<childv){w=ww;}
3265        }
3266        childfu=fu[1][2]+childv-1;
3267        @L[fu[2]][2]=childfu;
3268        @L[v[2]][2]=0;
3269        t=1;
3270        deleteverts(labu);
3271      }
3272    }
3273  }
3274  deletebrotherscontaining(labfu);
3275}
3276
3277// given the the label labfu of the vertex fu it returns the last
3278// int of the label of the last existing children.
3279// if no child exists, then it ouputs 0.
3280static proc lastchildrenindex(intvec labfu)
3281{
3282  int i;
3283  int lastlabi; intvec labi; intvec labfi;
3284  int lastlab=0;
3285  for (i=1;i<=size(@L);i++)
3286  {
3287    labi=@L[i][1];
3288    if (size(labi)>1)
3289    {
3290      labfi=delintvec(labi,size(labi));
3291      if (labfu==labfi)
3292      {
3293        lastlabi=labi[size(labi)];
3294        if (lastlab<lastlabi)
3295        {
3296          lastlab=lastlabi;
3297        }
3298      }
3299    }
3300  }
3301  return(lastlab);
3302}
3303
3304// given the the vertex u it provides the next brother of u.
3305// if it does not exist, then it ouputs v=list(list(intvec(0)),0)
3306static proc nextbrother(intvec labu)
3307{
3308  list L; int i; int j; list next;
3309  int lastlabu=labu[size(labu)];
3310  intvec labfu=delintvec(labu,size(labu));
3311  int lastlabi; intvec labi; intvec labfi;
3312  for (i=1;i<=size(@L);i++)
3313  {
3314    labi=@L[i][1];
3315    if (size(labi)>1)
3316    {
3317      labfi=delintvec(labi,size(labi));
3318      if (labfu==labfi)
3319      {
3320        lastlabi=labi[size(labi)];
3321        if (lastlabu<lastlabi)
3322        {L[size(L)+1]=list(lastlabi,list(@L[i],i));}
3323      }
3324    }
3325  }
3326  if (size(L)==0){return(list(intvec(0),0));}
3327  next=L[1];
3328  for (i=2;i<=size(L);i++)
3329  {
3330    if (L[i][1]<next[1]){next=L[i];}
3331  }
3332  return(next[2]);
3333}
3334
3335// gives the first child of vertex fu
3336static proc firstchild(labfu)
3337{
3338  intvec labfu0=labfu;
3339  labfu0[size(labfu0)+1]=0;
3340  return(nextbrother(labfu0));
3341}
3342
3343// purpose: eliminate the children vertices of fu and all its descendents
3344// whose prime ideal Pu contains a prime ideal Pv of some brother vertex w.
3345static proc deletebrotherscontaining(intvec labfu)
3346{
3347  int i; int t;
3348  list fu=tree(labfu,@L);
3349  int childfu=fu[1][2];
3350  list u; intvec labu; ideal Pu;
3351  list v; intvec labv; ideal Pv;
3352  u=firstchild(labfu);
3353  for (i=1;i<=childfu;i++)
3354  {
3355    labu=u[1][1];
3356    Pu=u[1][3];
3357    v=firstchild(fu[1][1]);
3358    t=1;
3359    while ((t) and (v[2]!=0))
3360    {
3361      labv=v[1][1];
3362      Pv=v[1][3];
3363      if (labu!=labv)
3364      {
3365        if (containedP(Pv,Pu))
3366        {
3367          deleteverts(labu);
3368          fu=tree(labfu,@L);
3369          @L[fu[2]][2]=fu[1][2]-1;
3370          t=0;
3371        }
3372      }
3373      if (t!=0)
3374      {
3375        v=nextbrother(v[1][1]);
3376      }
3377    }
3378    if (i<childfu)
3379    {
3380      u=nextbrother(u[1][1]);
3381    }
3382  }
3383}
3384
3385// purpose: delete all descendent vertices from u included u
3386// from the list @L.
3387// It must be noted that after the operation, the number of children
3388// in fathers vertex must be decreased in 1 unitity. This operation is not
3389// performed inside this recursive routine.
3390static proc deleteverts(intvec labu)
3391{
3392  int i; int ii; list v; intvec labv;
3393  list u=tree(labu,@L);
3394  int childu=u[1][2];
3395  @L=delete(@L,u[2]);
3396  if (childu>0)
3397  {
3398    v=firstchild(labu);
3399    labv=v[1][1];
3400    for (ii=1;ii<=childu;ii++)
3401    {
3402      deleteverts(labv);
3403      if (ii<childu)
3404      {
3405        v=nextbrother(v[1][1]);
3406        labv=v[1][1];
3407      }
3408    }
3409  }
3410}
3411
3412// purpose: starting from vertex olab (initially nlab=olab)
3413// relabels the vertices of @L to be consecutive
3414static proc relabelingindices(intvec olab, intvec nlab)
3415{
3416  int i;
3417  intvec nlabi; intvec labv;
3418  list u=tree(olab,@L);
3419  int childu=u[1][2];
3420  list v;
3421  if (childu==0){@L[u[2]][1]=nlab;}
3422  else
3423  {
3424    v=firstchild(u[1][1]);
3425    @L[u[2]][1]=nlab;
3426    i=1;
3427    while(v[2]!=0)
3428    {
3429      labv=v[1][1];
3430      nlabi=nlab,i;
3431      relabelingindices(labv,nlabi);
3432      v=nextbrother(labv);
3433      i++;
3434    }
3435  }
3436}
3437
3438// mrcgs
3439// input: F = ideal in ring R=Q[a][x]
3440// output: a list L representing the tree of the mrcgs.
3441static proc mrcgs(ideal F, list #)
3442//"USAGE:   mrcgs(F);
3443//          F is the ideal from which to obtain the Minimal Reduced CGS.
3444//          From the old library redcgs.lib.
3445//          Alternatively, as option:
3446//          mrcgs(F,L);
3447//          Options: We can give a list of options in the list L
3448//          of the form
3449//          ("null",ideal N,"nonnull",ideal W,"comment",0-1).
3450//          One can give none till 3 of these options by giving the
3451//          name of the option and the content.
3452//          When options "null" and/or "nonnull" are given, then the
3453//          parameter space is restricted to V(N)\V(h), where h is the product of
3454//          the non null polynomials in W. If the option ("comment",1) is set,
3455//          then information about the total number of segments of the
3456//          output is printed.
3457//          By default N=ideal(0), W=ideal(1), ("comment",0).
3458//          mrcgs is the fundamental routine of the old library redcgs.lib,
3459//          computing the minimal reduced comprehensive Groebner system.
3460//RETURN:   The list T representing the Minimal Reduced CGS.
3461//          The description given here is identical for rcgs and crcgs.
3462//          The elements of the list T computed by mrcgs are lists representing
3463//          a rooted tree.
3464//          Each element of the list T has the two first entries with the following content:
3465//           [1]: The label (intvec) representing the position in the rooted
3466//                tree:  0 for the root (and this is a special element)
3467//                       i for the root of the segment i
3468//                       (i,...) for the children of the segment i
3469//           [2]: the number of children (int) of the vertex.
3470//          There thus three kind of vertices:
3471//           (1) the root (first element labelled 0),
3472//           (2) the vertices labelled with a single integer i,
3473//           (3) the rest of vertices labelled with more indices.
3474//          Description of the root. Vertex type (1)
3475//           There is a special vertex (the first one) whose content is
3476//           the following:
3477//             [3] lpp of the given ideal
3478//             [4] the given ideal
3479//             [5] the red-representation  of the (optional) given null and non-null
3480//                 conditions (see redspec for the description).
3481//             [6] MRCGS (to remember which algorithm has been used). If the
3482//                 algorithm used is rcgs of crcgs then this will be stated
3483//                 at this vertex (RCGS or CRCGS).
3484//           Description of vertices type (2). These are the vertices that
3485//           initiate a segment, and are labelled with a single integer.
3486//             [3] lpp (ideal) of the reduced basis. If they are repeated lpp's this
3487//                 will correspond to a sheaf.
3488//             [4] the reduced basis (ideal) of the segment.
3489//           Description of vertices type (3). These vertices have as first
3490//           label i and descend form vertex i in the position of the label
3491//           (i,...). They contain moreover a unique prime ideal in the parameters
3492//           and form ascending chains of ideals.
3493//          How is to be read the mrcgs tree? The vertices with an even number of
3494//          integers in the label are to be considered as additive and those
3495//          with an odd number of integers in the label are to be considered as
3496//          substraction. As an example consider the following vertices:
3497//          v1=((i),2,lpp,B),
3498//          v2=((i,1),2,P_(i,1)),
3499//          v3=((i,1,1),2,P_(i,1,1)),
3500//          v4=((i,1,1,1),1,P_(i,1,1,1)),
3501//          v5=((i,1,1,1,1),0,P_(i,1,1,1,1)),
3502//          v6=((i,1,1,2),1,P_(i,1,1,2)),
3503//          v7=((i,1,1,2,1),0,P_(i,1,1,2,1)),
3504//          v8=((i,1,2),0,P_(i,1,2)),
3505//          v9=((i,2),1,P_(i,2)),
3506//          v10=((i,2,1),0,P_(i,2,1)),
3507//          They represent the segment:
3508//          (V(i,1)\(((V(i,1,1) \ ((V(i,1,1,1) \ V(i,1,1,1,1)) u (V(i,1,1,2) \ V(i,1,1,2,1)))))
3509//          u V(i,1,2))) u (V(i,2) \ V(i,2,1))
3510//          and can also be represented by
3511//          (V(i,1) \ (V(i,1,1) u V(i,1,2))) u
3512//          (V(i,1,1,1) \ V(i,1,1,1)) u
3513//          (V(i,1,1,2) \ V(i,1,1,2,1)) u
3514//          (V(i,2) \ V(i,2,1))
3515//          where V(i,j,..) = V(P_(i,j,..))
3516//NOTE:     There are three fundamental routines in the old library redcgs.lib:
3517//          mrcgs, rcgs and crcgs.
3518//          mrcgs (Minimal Reduced CGS) is an algorithm that packs so much as it
3519//          is able to do (using algorithms adhoc) the segments with the same lpp,
3520//          obtaining the minimal number of segments. The hypothesis is that this
3521//          is very close to be canonical, but there is no proof of the uniqueness
3522//          of this minimal packing. Moreover, the segments obtained are not
3523//          locally closed, i.e. there are not always the difference of two varieties,
3524//          but are a union of differences of varieties.
3525//          The output can be visualized using cantreetoMaple, that will
3526//          write a file with the content of mrcgs that can be read in Maple
3527//          and plotted using the Maple plotcantree routine of the Monte's dpgb library
3528//KEYWORDS: rcgs, crcgs, buildtree, cantreetoMaple,
3529//EXAMPLE:  mrcgs; shows an example"
3530{
3531  int i=1;
3532  int @ish=1;
3533  exportto(Top,@ish);
3534  while((@ish) and (i<=size(F)))
3535  {
3536    @ish=ishomog(F[i]);
3537    i++;
3538  }
3539  int comment=0;
3540  def N=ideal(0);
3541  def W=ideal(1);
3542  list L=#;
3543  for(i=1;i<=size(L) div 2;i++)
3544  {
3545    if(L[2*i-1]=="null"){N=L[2*i];}
3546    else
3547    {
3548      if(L[2*i-1]=="nonnull"){W=L[2*i];}
3549      else
3550      {
3551        if(L[2*i-1]=="comment"){comment=L[2*i];}
3552      }
3553    }
3554  }
3555  def RR=basering;
3556  list LL=buildtree(F, #);
3557  setglobalrings();
3558  list S=selectcases(LL);
3559  list T=cantree(S);
3560  if(equalideals(N,ideal(0))==0)
3561  {
3562    T=reduceconds(T,N,W);
3563  }
3564  T[1][6]="MRCGS";
3565  T[1][4]=F;
3566  for (i=1;i<=size(F);i++)
3567  {
3568    T[1][3][i]=leadmonom(F[i]);
3569  }
3570  kill @ish;
3571  kill @P; kill @RP; kill @R;
3572  return(T);
3573}
3574//example
3575//{ "EXAMPLE:"; echo = 2;
3576//  ring R=(0,a1,a2,a3,a4),(x1,x2,x3,x4),dp;
3577//  ideal F=x4-a4+a2, x1+x2+x3+x4-a1-a3-a4, x1*x3*x4-a1*a3*a4, x1*x3+x1*x4+x2*x3+x3*x4-a1*a4-a1*a3-a3*a4;
3578//  "System="; F;
3579//  def T=mrcgs(F);
3580//  setglobalrings();
3581//  "mrcgs(F)="; T;
3582//  cantreetoMaple(T,"Tm","Tm.txt");
3583//  "cantodiffcgs(T)="; cantodiffcgs(T);
3584//  kill R;
3585//  ring R=(0,b,c,d,e,f),(x,y),dp;
3586//  ideal F1=x^2+b*y^2+2*c*x*y+2*d*x+2*e*y+f, 2*x+2*c*y+2*d, 2*b*y+2*c*x+2*e;
3587//  "System="; F1;
3588//  def T1=mrcgs(F1);
3589//  setglobalrings();
3590//  "mrcgs(F1)="; T1;
3591//  cantreetoMaple(T1,"T1m","T1m.txt");
3592//}
3593
3594// reduceconds: when null and nonnull conditions are specified it
3595//              takes the output of cantree and reduces the tree
3596//              assuming the null and nonnull conditions
3597// input: list T (the output of cantree computed with null and nonull conditions
3598//        ideal N: null conditions
3599//        ideal W: non-null conditions
3600// output: the list T assuming the null and non-null conditions
3601static proc reduceconds(list T,ideal N,ideal W)
3602{
3603  int i; intvec lab; intvec labfu; list fu; int j; int t;
3604  list @L=T;
3605  exportto(Top,@L);
3606  int n=size(W);
3607  for (i=2;i<=size(@L);i++)
3608  {
3609    t=0; j=0;
3610    while ((not(t)) and (j<n))
3611    {
3612      j++;
3613      if (size(@L[i][1])>1)
3614      {
3615        if (memberpos(W[j],@L[i][3])[1])
3616        {
3617          t=1;
3618          @L[i][3]=ideal(1);
3619        }
3620      }
3621    }
3622  }
3623  for (i=2;i<=size(@L);i++)
3624  {
3625    if (size(@L[i][1])>1)
3626    {
3627      @L[i][3]=delidfromid(N,@L[i][3]);
3628    }
3629  }
3630  for (i=2;i<=size(@L);i++)
3631  {
3632    if ((size(@L[i][1])>1) and (size(@L[i][1]) mod 2==1) and (equalideals(@L[i][3],ideal(0))))
3633    {
3634      lab=@L[i][1];
3635      labfu=delintvec(lab,size(lab));
3636      fu=tree(labfu,@L);
3637      @L[fu[2]][2]=@L[fu[2]][2]-1;
3638      deleteverts(lab);
3639    }
3640  }
3641  for (j=2; j<=size(@L); j++)
3642  {
3643    if (@L[j][2]>0)
3644    {
3645      deletebrotherscontaining(@L[j][1]);
3646    }
3647  }
3648  for (i=1;i<=@L[1][2];i++)
3649  {
3650    relabelingindices(intvec(i),intvec(i));
3651  }
3652  list TT=@L;
3653  kill @L;
3654  return(TT);
3655}
3656
3657//**************End of cantree******************************
3658
3659//**************Begin of CanTreeTo Maple********************
3660
3661// cantreetoMaple
3662// input:  list L: the output of cantree
3663//         string T: the name of the table of Maple that represents L
3664//                   in Maple
3665//         string writefile: the name of the file where the table T
3666//                           is written
3667proc cantreetoMaple(list L, string T, string writefile)
3668"USAGE:   cantreetoMaple(T, TM, writefile);
3669          T: is the list provided by grobcovold with option ("out",1),
3670          TM: is the name (string) of the table variable in Maple that will
3671             represent the output of the fundamental routines,
3672          writefile: is the name (string) of the file where to write the content.
3673RETURN:   writes the list provided by grobcovold to a file
3674          containing the table representing it in Maple.
3675NOTE:     It can be called from the output of grobcovold with option ("out",1)
3676KEYWORDS: grobcovold, Maple
3677EXAMPLE:  cantreetoMaple; shows an example"
3678{
3679  short=0;
3680  if(size(L[1])!=6)
3681  {
3682    "  'Warning!' grobcovold must be called with option 'out' set to 1 to be operative";
3683    return();
3684  }
3685  int i;
3686  def R=basering;
3687  list L0=L[1];
3688  int numcases=L0[2];
3689  link LLw=":w "+writefile;
3690  string La=string("table(",T,");");
3691  write(LLw, La);
3692  close(LLw);
3693  link LLa=":a "+writefile;
3694  def RL=ringlist(R);
3695  list p=RL[1][2];
3696  string param=string(p[1]);
3697  if (size(p)>1)
3698  {
3699    for(i=2;i<=size(p);i++){param=string(param,",",p[i]);}
3700  }
3701  list v=RL[2];
3702  string vars=string(v[1]);
3703  if (size(v)>1)
3704  {
3705    for(i=2;i<=size(v);i++){vars=string(vars,",",v[i]);}
3706  }
3707  list xord;
3708  list pord;
3709  if (RL[1][3][1][1]=="dp"){pord=string("tdeg(",param);}
3710  else
3711  {
3712    if (RL[1][3][1][1]=="lp"){pord=string("plex(",param);}
3713  }
3714  if (RL[3][1][1]=="dp"){xord=string("tdeg(",vars);}
3715  else
3716  {
3717    if (RL[3][1][1]=="lp"){xord=string("plex(",vars);}
3718  }
3719  write(LLa,string(T,"[[___xord]]:=",xord,");"));
3720  write(LLa,string(T,"[[___pord]]:=",pord,");"));
3721  //write(LLa,string(T,"[[11]]:=true; "));
3722  list S;
3723  S=string(T,"[[0]]:=",numcases,";");
3724  write(LLa,S);
3725  S=string(T,"[[___method]]:=",L[1][6],";");
3726  // Method L[1][6];
3727  write(LLa,S);
3728  S=string(T,"[[___basis]]:=[",L0[4],"];");
3729  write(LLa,S);
3730  S=string(T,"[[___nullcond]]:=[",L0[5][1],"];");
3731  write(LLa,S);
3732  S=string(T,"[[___notnullcond]]:={",L0[5][2],"};");
3733  write(LLa,S);
3734  for (i=1;i<=numcases;i++)
3735  {
3736    S=ctlppbasis(T,L,intvec(i));
3737    write(LLa,S[1]);
3738    write(LLa,S[2]);
3739    write(LLa,S[3]);
3740    //write(LLa,S[4]);
3741    ctrecwrite(LLa, L, T, intvec(i),S[4]);
3742  }
3743  close(LLa);
3744}
3745example
3746{ "EXAMPLE:"; echo = 2;
3747  ring R=(0,b,c,d,e,f),(x,y),dp;
3748  ideal F=x^2+b*y^2+2*c*x*y+2*d*x+2*e*y+f, 2*x+2*c*y+2*d, 2*b*y+2*c*x+2*e;
3749  def T=grobcovold(F,"out",1);
3750  T;
3751  cantreetoMaple(T,"Tm","Tm.txt");
3752}
3753
3754// ctlppbasis: auxiliary cantreetoMaple routine
3755// input:
3756//   string T: the name of the table in Maple
3757//   intvec lab: the label of the case
3758//   ideal B: the basis of the case
3759// output:
3760//   the string of T[[lab]] (basis); in Maple
3761static proc ctlppbasis(string T, list L, intvec lab)
3762{
3763  list u;
3764  intvec lab0=lab,0;
3765  u=tree(lab,L);
3766  list Li;
3767  Li[1]=string(T,"[[",lab,",___lpp]]:=[",u[1][3],"]; ");
3768  Li[2]=string(T,"[[",lab,"]]:=[",u[1][4],"]; ");
3769  Li[3]=string(T,"[[",lab0,"]]:=",u[1][2],"; ");
3770  Li[4]=u[1][2];
3771  return(Li);
3772}
3773
3774// ctlppbasis: auxiliary cantreetoMaple routine
3775// recursive routine to write all elements
3776static proc ctrecwrite(LLa, list L, string T, intvec lab, int n)
3777{
3778  int i;
3779  intvec labi; intvec labi0;
3780  string S;
3781  list u;
3782  for (i=1;i<=n;i++)
3783  {
3784    labi=lab,i;
3785    u=tree(labi,L);
3786    S=string(T,"[[",labi,"]]:=[",u[1][3],"];");
3787    write(LLa,S);
3788    labi0=labi,0;
3789    S=string(T,"[[",labi0,"]]:=",u[1][2],";");
3790    write(LLa,S);
3791    ctrecwrite(LLa, L, T, labi, u[1][2]);
3792  }
3793}
3794
3795//**************End of CanTreeTo Maple********************
3796
3797//**************Begin homogenizing************************
3798
3799// ishomog:
3800// Purpose: test if a polynomial is homogeneous in the variables or not
3801// input:  poly f
3802// output  1 if f is homogeneous, 0 if not
3803static proc ishomog(f)
3804{
3805  int i; poly r; int d; int dr;
3806  if (f==0){return(1);}
3807  d=deg(f); dr=d; r=f;
3808  while ((d==dr) and (r!=0))
3809  {
3810    r=r-lead(r);
3811    dr=deg(r);
3812  }
3813  if (r==0){return(1);}
3814  else{return(0);}
3815}
3816
3817static proc rcgs(ideal F, list #)
3818//"USAGE:   rcgs(F);
3819//          F is the ideal from which to obtain the Reduced CGS.
3820//          From the old library redcgs.lib.
3821//          Alternatively, as option:
3822//          rcgs(F,L);
3823//          Options: We can give a list of options in the list L
3824//          of the form
3825//          ("null",ideal N,"nonnull",ideal W,"comment",int comment).
3826//          One can give none till 3 of these options by giving the
3827//          name of the option and the content.
3828//          When options "null" and/or "nonnull" are given, then the
3829//          parameter space is restricted to V(N)\V(h), where h is the product of
3830//          the non null polynomials in W. If the option "comment" is set to 1,
3831//          then information about the total number of segments of the
3832//          output is printed.
3833//          By default N=ideal(0) and W=ideal(1).
3834//          rcgs is the a routine whose output segments are always
3835//          locally closed and correspond to homogenizing the basis
3836//          compute its mrcgs and then reduce and de-homogenizing the result.
3837//          The result is a Reduced Comprehensive Groebner System.
3838//RETURN:   The list T representing the Reduced CGS.
3839//          The description given here is identical for mrcgs and crcgs.
3840//          The elements of the list T computed by rcgs are lists representing
3841//          a rooted tree.
3842//          Each element of the list T has the two first entries with the following content:
3843//           [1]: The label (intvec) representing the position in the rooted
3844//                tree:  0 for the root (and this is a special element)
3845//                       i for the root of the segment i
3846//                       (i,...) for the children of the segment i
3847//           [2]: the number of children (int) of the vertex.
3848//          There thus three kind of vertices:
3849//           (1) the root (first element labelled 0),
3850//           (2) the vertices labelled with a single integer i,
3851//           (3) the rest of vertices labelled with more indices.
3852//          Description of the root. Vertex type (1)
3853//           There is a special vertex (the first one) whose content is
3854//           the following:
3855//             [3] lpp of the given ideal
3856//             [4] the given ideal
3857//             [5] the red-representation  of the (optional) given null and non-null conditions
3858//                 (see redspec for the description)
3859//             [6] RCGS (to remember which algorithm has been used). If the
3860//                 algorithm used is mrcgs of crcgs then this will be stated
3861//                 at this vertex (MRCGS or CRCGS).
3862//           Description of vertices type (2). These are the vertices that
3863//           initiate a segment, and are labelled with a single integer.
3864//             [3] lpp (ideal) of the reduced basis. If they are repeated lpp's this
3865//                 will correspond to a sheaf.
3866//             [4] the reduced basis (ideal) of the segment.
3867//           Description of vertices type (3). These vertices have as first
3868//           label i and descend form vertex i in the position of the label
3869//           (i,...). They contain moreover a unique prime ideal in the parameters
3870//           and form ascending chains of ideals.
3871//          How is to be read the rcgs tree? The vertices with an even number of
3872//          integers in the label are to be considered as additive and those
3873//          with an odd number of integers in the label are to be considered as
3874//          substraction. As an example consider the following vertices:
3875//          v1=((i),2,lpp,B),
3876//          v2=((i,1),2,P_(i,1)),
3877//          v3=((i,1,1),2,P_(i,1,1)),
3878//          v4=((i,1,1,1),1,P_(i,1,1,1)),
3879//          v5=((i,1,1,1,1),0,P_(i,1,1,1,1)),
3880//          v6=((i,1,1,2),1,P_(i,1,1,2)),
3881//          v7=((i,1,1,2,1),0,P_(i,1,1,2,1)),
3882//          v8=((i,1,2),0,P_(i,1,2)),
3883//          v9=((i,2),1,P_(i,2)),
3884//          v10=((i,2,1),0,P_(i,2,1)),
3885//          They represent the segment:
3886//          (V(i,1)\(((V(i,1,1) \ ((V(i,1,1,1) \ V(i,1,1,1,1)) u (V(i,1,1,2) \ V(i,1,1,2,1)))))
3887//          u V(i,1,2))) u (V(i,2) \ V(i,2,1))
3888//          and can also be represented by
3889//          (V(i,1) \ (V(i,1,1) u V(i,1,2))) u
3890//          (V(i,1,1,1) \ V(i,1,1,1)) u
3891//          (V(i,1,1,2) \ V(i,1,1,2,1)) u
3892//          (V(i,2) \ V(i,2,1))
3893//          where V(i,j,..) = V(P_(i,j,..))
3894//NOTE:     There are three fundamental routines in the old library redcgs.lib:
3895//          mrcgs, rcgs and crcgs.
3896//          The output can be visualized using cantreetoMaple, that will
3897//          write a file with the content of rcgs that can be read in Maple
3898//          and plotted using the Maple plotcantree routine of the Monte's dpgb library
3899//KEYWORDS: mrcgs, crcgs, buildtree, cantreetoMaple,
3900//EXAMPLE:  rcgs; shows an example"
3901{
3902  int j; int i;
3903  poly f;
3904  int comment=0;
3905  def N=ideal(0);
3906  def W=ideal(1);
3907  list L=#;
3908  for(i=1;i<=size(L) div 2;i++)
3909  {
3910    if(L[2*i-1]=="null"){N=L[2*i];}
3911    else
3912    {
3913      if(L[2*i-1]=="nonnull"){W=L[2*i];}
3914      else
3915      {
3916        if(L[2*i-1]=="comment"){comment=L[2*i];}
3917      }
3918    }
3919  }
3920  i=1; int postred=0;
3921  int ish=1;
3922  while ((ish) and (i<=size(F)))
3923  {
3924    ish=ishomog(F[i]);
3925    i++;
3926  }
3927  if (ish){return(mrcgs(F, #));}
3928  def RR=basering;
3929  list RRL=ringlist(RR);
3930  //if (RRL[3][1][1]!="dp"){ERROR("the order must be dp");}
3931  poly @t;
3932  ring H=0,@t,dp;
3933  def RH=RR+H;
3934  setring(RH);
3935  def FH=imap(RR,F);
3936  list u; ideal B; ideal lpp; intvec lab;
3937  FH=homog(FH,@t);
3938  def Nh=imap(RR,N);
3939  def Wh=imap(RR,W);
3940  list LL;
3941  if ((size(Nh)>0) or (size(Wh)>0))
3942  {
3943    LL=mrcgs(FH,list("null",Nh,"nonnull",Wh));
3944  }
3945  else
3946  {
3947    LL=mrcgs(FH);
3948  }
3949  setglobalrings();
3950  LL[1][3]=subst(LL[1][3],@t,1);
3951  LL[1][4]=subst(LL[1][4],@t,1);
3952  for (i=1; i<=LL[1][2]; i++)
3953  {
3954    lab=intvec(i);
3955    u=tree(lab,LL);
3956    postred=difflpp(u[1][3]);
3957    B=sortideal(subst(LL[u[2]][4],@t,1));
3958    lpp=sortideal(subst(LL[u[2]][3],@t,1));
3959    if (memberpos(1,B)[1]){B=ideal(1); lpp=ideal(1);}
3960    if (postred)
3961    {
3962      lpp=ideal(0);
3963      B=postredgb(mingb(B));
3964      for (j=1;j<=size(B);j++){lpp[j]=leadmonom(B[j]);}
3965    }
3966    else{"Sheaves present, not reduced bases in the case lpp = ";lpp;}
3967    LL[u[2]][4]=B;
3968    LL[u[2]][3]=lpp;
3969  }
3970  setring(RR);
3971  list LLL=imap(RH,LL);
3972  kill @P; kill @R; kill @RP;
3973  LLL[1][6]="RCGS";
3974  return(LLL);
3975}
3976//example
3977//{ "EXAMPLE:"; echo = 2;
3978//  ring R=(0,b,c,d,e,f),(x,y),dp;
3979//  ideal F=x^2+b*y^2+2*c*x*y+2*d*x+2*e*y+f, 2*x+2*c*y+2*d, 2*b*y+2*c*x+2*e;
3980//  def T=rcgs(F);
3981//  T;
3982//  cantreetoMaple(T,"Tr","Tr.txt");
3983//  cantodiffcgs(T);
3984//}
3985
3986static proc difflpp(ideal lpp)
3987{
3988  int t=1; int i;
3989  poly lp1=lpp[1];
3990  poly lp;
3991  i=2;
3992  while ((i<=size(lpp)) and (t))
3993  {
3994    lp=lpp[i];
3995    if (lp==lp1){t=0;}
3996    lp1=lp;
3997    i++;
3998  }
3999  return(t);
4000}
4001
4002// redgb: given a minimal bases (gb reducing) it
4003// reduces each polynomial wrt to the others
4004static proc postredgb(ideal F)
4005{
4006  ideal G;
4007  ideal H;
4008  int i;
4009  if (size(F)==0){return(ideal(0));}
4010  for (i=1;i<=size(F);i++)
4011  {
4012    H=delfromideal(F,i);
4013    G[i]=pdivi(F[i],H)[1];
4014  }
4015  return(G);
4016}
4017
4018static proc crcgs(ideal F, list #)
4019//"USAGE:   crcgs(F);
4020//          F is the ideal from which to obtain the Canonical Reduced CGS.
4021//          From the old library redcgs.lib.
4022//          Alternatively, as option:
4023//          crcgs(F,L);
4024//          Options: We can give a list of options in the list L
4025//          of the form
4026//          ("null",ideal N,"nonnull",ideal W,"comment",int comment).
4027//          One can give none till 3 of these options by giving the
4028//          name of the option and the content.
4029//          When options "null" and/or "nonnull" are given, then the
4030//          parameter space is restricted to V(N)\V(h), where h is the product of
4031//          the non null polynomials in W. If the option "comment" is set to 1,
4032//          then information about the total number of segments of the
4033//          output is printed.
4034//          By default N=ideal(0) and W=ideal(1).
4035//          crcgs is a routine whose output segments are always
4036//          locally closed and correspond to homogenizing the ideal
4037//          compute its mrcgs and then reduce and de-homogenizing the result.
4038//          The result is in principle the Canonical Comprehensive Groebner System,
4039//          similar to the result obtained by the fundamental routine grobcov,
4040//          but the output is less friendly and not certified to be always
4041//          the canonical Groebner cover.
4042//RETURN:   The list T representing the canonical Reduced CGS.
4043//          The description given here is identical for mrcgs and rcgs.
4044//          The elements of the list T computed by crcgs are lists representing
4045//          a rooted tree.
4046//          Each element of the list T has the two first entries with the following content:
4047//           [1]: The label (intvec) representing the position in the rooted
4048//                tree:  0 for the root (and this is a special element)
4049//                       i for the root of the segment i
4050//                       (i,...) for the children of the segment i
4051//           [2]: the number of children (int) of the vertex.
4052//          There thus three kind of vertices:
4053//           (1) the root (first element labelled 0),
4054//           (2) the vertices labelled with a single integer i,
4055//           (3) the rest of vertices labelled with more indices.
4056//          Description of the root. Vertex type (1)
4057//           There is a special vertex (the first one) whose content is
4058//           the following:
4059//             [3] lpp of the given ideal
4060//             [4] the given ideal
4061//             [5] the red-representation  of the (optional) given null and non-null conditions
4062//                 (see redspec for the description)
4063//             [6] CRCGS (to remember which algorithm has been used). If the
4064//                 algorithm used is mrcgs of rcgs then this will be stated
4065//                 at this vertex (MRCGS or RCGS).
4066//           Description of vertices type (2). These are the vertices that
4067//           initiate a segment, and are labelled with a single integer.
4068//             [3] lpp (ideal) of the reduced basis. If they are repeated lpp's this
4069//                 will correspond to a sheaf.
4070//             [4] the reduced basis (ideal) of the segment.
4071//           Description of vertices type (3). These vertices have as first
4072//           label i and descend form vertex i in the position of the label
4073//           (i,...). They contain moreover a unique prime ideal in the parameters
4074//           and form ascending chains of ideals.
4075//          How is to be read the crcgs tree? The vertices with an even number of
4076//          integers in the label are to be considered as additive and those
4077//          with an odd number of integers in the label are to be considered as
4078//          substraction. As an example consider the following vertices:
4079//          v1=((i),2,lpp,B),
4080//          v2=((i,1),2,P_(i,1)),
4081//          v3=((i,1,1),2,P_(i,1,1)),
4082//          v4=((i,1,1,1),1,P_(i,1,1,1)),
4083//          v5=((i,1,1,1,1),0,P_(i,1,1,1,1)),
4084//          v6=((i,1,1,2),1,P_(i,1,1,2)),
4085//          v7=((i,1,1,2,1),0,P_(i,1,1,2,1)),
4086//          v8=((i,1,2),0,P_(i,1,2)),
4087//          v9=((i,2),1,P_(i,2)),
4088//          v10=((i,2,1),0,P_(i,2,1)),
4089//          They represent the segment:
4090//          (V(i,1)\(((V(i,1,1) \ ((V(i,1,1,1) \ V(i,1,1,1,1)) u (V(i,1,1,2) \ V(i,1,1,2,1)))))
4091//          u V(i,1,2))) u (V(i,2) \ V(i,2,1))
4092//          and can also be represented by
4093//          (V(i,1) \ (V(i,1,1) u V(i,1,2))) u
4094//          (V(i,1,1,1) \ V(i,1,1,1)) u
4095//          (V(i,1,1,2) \ V(i,1,1,2,1)) u
4096//          (V(i,2) \ V(i,2,1))
4097//          where V(i,j,..) = V(P_(i,j,..))
4098//NOTE:     There are three fundamental routines in the old library redcgs.lib:
4099//          mrcgs, rcgs and crcgs.
4100//          The output can be visualized using cantreetoMaple, that will
4101//          write a file with the content of rcgs that can be read in Maple
4102//          and plotted using the Maple plotcantree routine of the Monte's dpgb library
4103//KEYWORDS: mrcgs, crcgs, buildtree, cantreetoMaple,
4104//EXAMPLE:  rcgs; shows an example"
4105{
4106  int ish=1; int i=1;
4107  while ((ish) and (i<=size(F)))
4108  {
4109    ish=ishomog(F[i]);
4110    i++;
4111  }
4112  if (ish){return(mrcgs(F, #));}
4113  def RR=basering;
4114//  int comment=0;
4115//  def N=ideal(0);
4116//  def W=ideal(1);
4117//  list L=#;
4118//  for(i=1;i<=size(L) div 2;i++)
4119//  {
4120//    if(L[2*i-1]=="null"){N=L[2*i];}
4121//    else
4122//    {
4123//      if(L[2*i-1]=="nonnull"){W=L[2*i];}
4124//      else
4125//      {
4126//        if(L[2*i-1]=="comment"){comment=L[2*i];}
4127//      }
4128//    }
4129//  }
4130  setglobalrings();
4131  setring(@RP);
4132  ideal FP=imap(RR,F);
4133  option(redSB);
4134  def G=std(FP);
4135  setring(RR);
4136  def GR=imap(@RP,G);
4137  kill @P; kill @RP; kill @R;
4138  list LL;
4139  LL=rcgs(GR, #);
4140  LL[1][6]="CRCGS";
4141  return(LL);
4142}
4143//example
4144//{ "EXAMPLE:"; echo = 2;
4145//  ring R=(0,b,c,d,e,f),(x,y),dp;
4146//  ideal F=x^2+b*y^2+2*c*x*y+2*d*x+2*e*y+f, 2*x+2*c*y+2*d, 2*b*y+2*c*x+2*e;
4147//  def T=crcgs(F);
4148//  T;
4149//  cantreetoMaple(T,"Tc","Tc.txt");
4150//  cantodiffcgs(T);
4151//}
4152
4153//purpose ideal intersection called in @R and computed in @P
4154static proc idintR(ideal N, ideal M)
4155{
4156  def RR=basering;
4157  setring(@P);
4158  def Np=imap(RR,N);
4159  def Mp=imap(RR,M);
4160  def Jp=idint(Np,Mp);
4161  setring(RR);
4162  return(imap(@P,Jp));
4163}
4164
4165//purpose reduced groebner basis called in @R and computed in @P
4166static proc gbR(ideal N)
4167{
4168  def RR=basering;
4169  setring(@P);
4170  def Np=imap(RR,N);
4171  option(redSB);
4172  Np=std(Np);
4173  setring(RR);
4174  return(imap(@P,Np));
4175}
4176
4177// purpose: given the output of a locally closed CGS (i.e. from rcgs or crcgs)
4178//          it returns the segments as difference of varieties.
4179static proc cantodiffcgs(list L)
4180//"USAGE:   canttodiffcgs(T);
4181//          T: is the list provided by mrcgs or crcgs or crcgs,
4182//RETURN:   The list transforming the content of these routines to a simpler
4183//          output where each segment corresponds to a single element of the list
4184//          that is described as difference of two varieties.
4185//
4186//          The first element of the list is identical to the first element
4187//          of the list provided by the corresponding cgs algorithm, and
4188//          contains general information on the call (see mrcgs).
4189//          The remaining elements are lists of 4 elements,
4190//          representing segments. These elements are
4191//           [1]: the lpp of the segment
4192//           [2]: the basis of the segment
4193//           [3]; the ideal of the first variety (radical)
4194//           [4]; the ideal of the second variety (radical)
4195//          The segment is V([3]) \ V([4]).
4196//
4197//NOTE:     It can be called from the output of mrcgs or rcgs of crcgs
4198//KEYWORDS: mrcgs, rcgs, crcgs, Maple
4199//EXAMPLE:  cantodiffcgs; shows an example"
4200{
4201  int i; int j; int k; int depth; list LL; list u; list v; list w;
4202  ideal N; ideal Nn; ideal M; ideal Mn; ideal N0; ideal W0;
4203  LL[1]=L[1];
4204  N0=L[1][5][1];
4205  W0=L[1][5][2];
4206  def RR=basering;
4207  setring(@P);
4208  def N0P=imap(RR,N0);
4209  def W0P=imap(RR,N0);
4210  ideal NP;
4211  ideal MP;
4212  setring(RR);
4213  for (i=2;i<=size(L);i++)
4214  {
4215    depth=size(L[i][1]);
4216    if (depth>3){ERROR("the given CGS has non locally closed segments");}
4217  }
4218  for (i=1;i<=L[1][2];i++)
4219  {
4220    N=ideal(1);
4221    M=ideal(1);
4222    u=tree(intvec(i),L);
4223    for (j=1;j<=u[1][2];j++)
4224    {
4225      v=tree(intvec(i,j),L);
4226      Nn=v[1][3];
4227      N=idintR(N,Nn);
4228      for (k=1;k<=v[1][2];k++)
4229      {
4230        w=tree(intvec(i,j,k),L);
4231        Mn=w[1][3];
4232        M=idintR(M,Mn);
4233      }
4234    }
4235    setring(@P);
4236    NP=imap(RR,N);
4237    MP=imap(RR,M);
4238    MP=MP+N0P;
4239    for (j=1;j<=size(W0P);j++){MP=MP+ideal(W0P[j]);}
4240    NP=NP+N0P;
4241    NP=gbR(NP);
4242    MP=gbR(MP);
4243    setring(RR);
4244    N=imap(@P,NP);
4245    M=imap(@P,MP);
4246    LL[i+1]=list(u[1][3],u[1][4],N,M);
4247  }
4248  return(LL);
4249}
4250//example
4251//{ "EXAMPLE:"; echo = 2;
4252//  ring R=(0,b,c,d,e,f),(x,y),dp;
4253//  ideal F=x^2+b*y^2+2*c*x*y+2*d*x+2*e*y+f, 2*x+2*c*y+2*d, 2*b*y+2*c*x+2*e;
4254//  def T=crcgs(F);
4255//  T;
4256//  cantreetoMaple(T,"Tc","Tc.txt");
4257//  cantodiffcgs(T);
4258//}
4259
4260//**************End homogenizing************************
4261
4262//**************End of redcgs************************
4263
4264//**************Begin of Groebner Cover*****************
4265
4266// incquotient
4267// incremental quotient
4268// Input: ideal N: a Groebner basis of an ideal
4269//        poly f:
4270// Output: Na = N:<f>
4271static proc incquotient(ideal N, poly f)
4272{
4273  poly g; int i;
4274  ideal Nb; ideal Na=N;
4275
4276  // begins incquotient
4277  if (size(Na)==1)
4278  {
4279    g=gcd(Na[1],f);
4280    if (g!=1)
4281    {
4282      Na[1]=Na[1]/g;
4283    }
4284    attrib(Na,"IsSB",1);
4285    return(Na);
4286  }
4287  def P=basering;
4288  poly @t;
4289  ring H=0,@t,lp;
4290  def HP=H+P;
4291  setring(HP);
4292  def fh=imap(P,f);
4293  def Nh=imap(P,N);
4294  ideal Nht;
4295  for (i=1;i<=size(Nh);i++)
4296  {
4297    Nht[i]=Nh[i]*@t;
4298  }
4299  attrib(Nht,"isSB",1);
4300  def fht=(1-@t)*fh;
4301  option(redSB);
4302  Nht=std(Nht,fht);
4303  ideal Nc; ideal v;
4304  for (i=1;i<=size(Nht);i++)
4305  {
4306    v=variables(Nht[i]);
4307    if(memberpos(@t,v)[1]==0)
4308    {
4309      Nc[size(Nc)+1]=Nht[i]/fh;
4310    }
4311  }
4312  setring(P);
4313  ideal HH;
4314  def Nd=imap(HP,Nc); Nb=Nd;
4315  option(redSB);
4316  Nb=std(Nd);
4317  return(Nb);
4318}
4319
4320// RrepNN: given a red-representation of a locally closed set and a new
4321//         assumed non-null polynomial f, it returns the new R-representation.
4322//         Called in any @P
4323//         13/09/2010
4324// input:
4325//   ideal N : the ideal of null-conditions
4326//   ideal W : non-null set of polynomials. (N,W) is a R-representation of the
4327//             initial locally closed set.
4328//   poly f  : A new assumed non-null polynomial
4329// returns: list (N1,W1), the new R-representation:
4330//   N1 = new radical of the null conditions of the R-representation
4331//   W1 = non-null list of polynomials of the new R-representation.
4332//   If the given conditions are not compatible, then N1=ideal(1). This should not
4333//     happen, because this has to be tested before using RrepNN.
4334
4335static proc RrepNN(ideal N, ideal W, poly f)
4336//"USAGE:   RrepNN(N,W,f);
4337//          N: null conditions ideal of the initial R-representation
4338//          W: non-null list of polynomials of the initial R-representation
4339//          f: new assumed non-null polynomial
4340//RETURN:   a list (N1,W1) containing the new R-representation of the segment
4341//          (N,W) adding the new non-null condition f.
4342//NOTE:     Called from parameter ring (@P).
4343//KEYWORDS: representation
4344//EXAMPLE:  RrepNN; shows an example"
4345{
4346  ideal F=f; ideal W1=W;
4347  def N1=incquotient(N,f);
4348  option(redSB);
4349  N1=std(N1);
4350  //attrib(N1,"IsSB",1);
4351  def H=sqrfree(f);
4352  int i;
4353  for(i=1;i<=size(H);i++){W1[size(W1)+1]=reduce(H[i],N1);}
4354
4355  W1=facvar(W1);
4356  if (size(W1)==0){W1=1;}
4357  return(list(N1,W1));
4358}
4359//example
4360//{ "EXAMPLE:"; echo = 2;
4361//  ring r=(0,a,b,c),(x,y),dp;
4362//  setglobalrings();
4363//  ideal N=(ab-c)*(a-b),(a-bc)*(a-b);
4364//  poly  h=(a+b)bc;
4365//  poly f=a-b;
4366//}
4367
4368// RrepN:  given a red-representation of a locally closed set and a new
4369//         assumed null polynomial f, that is not identically null, it returns
4370//         the new red-representation.
4371//         Called in ring @P
4372//         13/09/2010
4373// input:
4374//   ideal N : the ideal of null-conditions
4375//   ideal W : non-null list of polynomials. (N,W) is a R-representation of the
4376//     initial locally closed set.
4377//   poly f  : A new assumed null polynomial
4378// returns: list (N1,W1), the new R-representation:
4379//   N1 = new radical of the null conditions of the R-representation
4380//   W1 = non-null list of polynomials of the new R-representation.
4381//   If the given conditions are not compatible, then N1=ideal(1).
4382static proc RrepN(ideal N, ideal W, poly f)
4383//"USAGE:   RrepN(N,W,f);
4384//          N: null conditions ideal of the initial R-representation
4385//          W: non-null list of polynomials of the initial R-representation
4386//          f: new assumed null polynomial
4387//RETURN:   a list (N1,W1) containing the new R-representation of the segment
4388//          (N,W) adding the new non-null condition f.
4389//NOTE:     Called from parameter ring (@P).
4390//KEYWORDS: representation
4391//EXAMPLE:  RrepN; shows an example"
4392{
4393  attrib(N,"isSB",1);
4394  def N1=std(N,f);
4395  option(redSB);
4396  N1=std(radical(N1));
4397  int i;
4398  poly h;
4399  for (i=1;i<=size(W);i++)
4400  {
4401    h=W[i];
4402    N1=incquotient(N1,h);
4403  }
4404  option(redSB);
4405  N1=std(N1);
4406  def W1=W;
4407  if (size(W1)==0){W1=1;}
4408  return(list(N1,W1));
4409}
4410//example
4411//{ "EXAMPLE:"; echo = 2;
4412//  ring r=(0,a,b,c),(x,y),dp;
4413//  setglobalrings();
4414//  ideal N=(ab-c)*(a-b),(a-bc)*(a-b);
4415//  poly  h=(a+b)bc;
4416//  poly f=a-b;
4417//  RrepN(N,h,f);
4418//}
4419
4420// Rrep: generates a R-representation
4421//       called from any ring
4422//       it uses ring @P, thus the globalrings @P, @RP, @R must be
4423//       active by a previous call to setglobalrings();
4424//       13/09/2010
4425// input:
4426//   ideal N : the ideal of null-conditions (not necessarily radical nor canonical)
4427//   ideal W : set of non-null polynomials: if W corresponds to no non null
4428//             conditions then W=ideal(0)
4429//             otherwise it should be given as an ideal.
4430// returns: list (Na,Wa)
4431//   the R-representation of (N,W):
4432//   ideal Na = radical of the R-representation (canonical)
4433//   ideal Wa = set of non-null polynomials in the R-representation.
4434//             if it corresponds to no non null conditions then it is ideal(0)
4435//             otherwise the ideal is returned.
4436//   If the given conditions are not compatible, then N=ideal(1).
4437static proc Rrep(ideal Ni, ideal Wi)
4438//"USAGE:   Rrep(N,W);
4439//          N: null conditions ideal
4440//          W: set of non-null polynomials (ideal)
4441//RETURN:   a list (N1,W1) containing the R-representation of the segment (N,W).
4442//          N1 is the radical reduced ideal characterizing the segment.
4443//          V(N1) is the Zarisky closure of the segment (N,W).
4444//          The segment S=V(N1) \ V(h), where h=prod(w in W1)
4445//          N1 is uniquely determined and no prime component of N1 contains none of
4446//          the polynomials in W1.
4447//NOTE:     Can be called from ring @R but it works in ring @P. Thus
4448//          the globalrings @P, @RP, @R must be active by a previous call
4449//          to setglobalrings();
4450//KEYWORDS: R-representation
4451//EXAMPLE:  Rrep shows an example"
4452{
4453  def RR=basering;
4454  setring(@P);
4455  def N=imap(RR,Ni);
4456  option(redSB);
4457  N=std(radical(N));
4458  def W=imap(RR,Wi);
4459  if(size(W)==0){W=ideal(0);}
4460     //when there are no non-null conditions then W=ideal(1)
4461  else
4462  {
4463    W=facvar(W);
4464  }
4465  if (size(W)==0)
4466  {
4467    setring(RR);
4468    //def Wb=imap(@P,W);
4469    return(list(imap(@P,N), ideal(1)));
4470  }
4471  else
4472  {
4473    int i; //ideal F;
4474    for (i=1;i<=size(W);i++)
4475    {
4476      //F=W[i];
4477      N=incquotient(N,W[i]);
4478    }
4479    option(redSB);
4480    N=std(N);
4481    setring(RR);
4482    def Nb=imap(@P,N);
4483    def Wb=imap(@P,W);
4484    if (equalideals(Wb,ideal(0))){Wb=ideal(1);}
4485    return(list(Nb,Wb));
4486  }
4487}
4488//example
4489//{ "EXAMPLE:"; echo = 2;
4490//  ring R=(0,a,b,c),(x,y),dp;
4491//  setglobalrings();
4492//  ideal N=(ab-c)*(a-b),(a-bc)*(a-b);
4493//  ideal W=a^2-b^2,bc;
4494//  Rrep(N,W);
4495//}
4496
4497
4498// eliminate the ith element from a list
4499static proc elimfromlist(list l, int i)
4500{
4501  list L; int j;
4502  for(j=1;j<=i-1;j++)
4503  {L[j]=l[j];}
4504  for(j=i+1;j<=size(l);j++)
4505  {L[j-1]=l[j];}
4506  return(L);
4507}
4508
4509static proc idbefid(ideal a, ideal b)
4510{
4511  poly fa; poly fb; poly la; poly lb;
4512  int te=1; int i; int j;
4513  int na=size(a);
4514  int nb=size(b);
4515  int nm;
4516  if (na<=nb){nm=na;} else{nm=nb;}
4517  for (i=1;i<=nm; i++)
4518  {
4519    fa=a[i]; fb=b[i];
4520    while((fa!=0) or (fb!=0))
4521    {
4522      la=lead(fa);
4523      lb=lead(fb);
4524      fa=fa-la;
4525      fb=fb-lb;
4526      la=leadmonom(la);
4527      lb=leadmonom(lb);
4528      if(leadmonom(la+lb)!=la){return(1);}
4529      else{if(leadmonom(la+lb)!=lb){return(2);}}
4530    }
4531  }
4532  if(na<nb){return(1);} else{if(na>nb){return(2);} else{return(0);}}
4533}
4534
4535static proc sortlistideals(list L)
4536{
4537  int i; int j; int n;
4538  ideal a; ideal b;
4539  list LL=L;
4540  list NL;
4541  int k; int te;
4542  i=1;
4543  while(size(LL)>0)
4544  {
4545    k=1;
4546    for(j=2;j<=size(LL);j++)
4547    {
4548      te=idbefid(LL[k],LL[j]);
4549      if (te==2){k=j;}
4550    }
4551    NL[size(NL)+1]=LL[k];
4552    n=size(LL);
4553    if (n>1){LL=elimfromlist(LL,k);} else{LL=list();}
4554  }
4555  return(NL);
4556}
4557
4558// returns 1 if the two lists of ideals are equal and 0 if not
4559static proc equallistideals(list L, list M)
4560{
4561  int t; int i;
4562  if (size(L)!=size(M)){return(0);}
4563  else
4564  {
4565    t=1;
4566    if (size(L)>0)
4567    {
4568      i=1;
4569      while ((t==1) and (i<=size(L)))
4570      {
4571        if (equalideals(L[i],M[i])==0){t=0;}
4572        i++;
4573      }
4574    }
4575    return(t);
4576  }
4577}
4578
4579// RtoPrepNew
4580// Computes the P-representaion of a R-representaion (N,W) of a set
4581// input:
4582//    ideal N (null conditions, must be radical)
4583//    ideal W (non-null conditions ideal)
4584//    list L  must contain the radical decomposition of N.
4585// output:
4586//    the ((p_1,(p_11,..,p_1k_1)),..,(p_r,(p_r1,..,p_rk_r)));
4587//    the Prep of V(N) \ V(h), where h=prod(w in W).
4588static proc RtoPrepNew(ideal N, ideal W)
4589{
4590  int i; int j; list L0;
4591  if (N[1]==1)
4592  {
4593    L0[1]=list(ideal(1),list(ideal(1)));
4594    return(L0);
4595  }
4596  def RR=basering;
4597  setring(@P);
4598  ideal Np=imap(RR,N);
4599  ideal Wp=imap(RR,W);
4600  list Lp=minGTZ(Np);
4601  for(i=1;i<=size(Lp);i++)
4602  {
4603    option(redSB);
4604    Lp[i]=std(Lp[i]);
4605  }
4606  //list Lp=imap(RR,L);
4607  poly h=1;
4608  for (i=1;i<=size(Wp);i++){h=h*Wp[i];}
4609  list r; list Ti; list LL;
4610  for (i=1;i<=size(Lp);i++)
4611  {
4612    Ti=minGTZ(Lp[i]+h);
4613    for(j=1;j<=size(Ti);j++)
4614    {
4615      option(redSB);
4616      Ti[j]=std(Ti[j]);
4617    }
4618    //list LL[i];
4619    LL[i]=list(Lp[i],Ti);
4620  }
4621  setring(RR);
4622  return(imap(@P,LL));
4623}
4624
4625// splitR: a new leading coefficient f is given to a R-representation
4626//        then splitR computes the two new R-representation by
4627//        considering it null, and non null.
4628//        Can be called from any ring but it works in ring @P
4629//        14/09/2010
4630// given the R-representation (N,W) and a new`polynomial f,
4631//        it outputs the null and the non-null R-representations adding f.
4632//        if the output R-representation (N0,W0) has N0==ideal(1) then
4633//        there must be no split and recbtcgs must continue on
4634//        the compatible (N1,W1) R-representation.
4635// input:
4636//    ideal N: null-ideal of the R-representation
4637//    ideal W: non-null list of polynomials of the R-representation
4638//    poly f coefficient to split if needed
4639// output:
4640//    list L = (list(ideal N0, ideal W0), list(ideal N1, ideal W1))
4641static proc splitR(ideal Ni, ideal Wi, poly fi)
4642{
4643  def RR=basering;
4644  setring(@P);
4645  def f=imap(RR,fi);
4646  def N=imap(RR,Ni);
4647  def W=imap(RR,Wi);
4648  def L0=RrepN(N,W,f);
4649  if(L0[1][1]==1)
4650  {
4651    setring(RR);
4652    def LL0=list(ideal(1),ideal(1));
4653    list LL1=list(Ni,Wi);
4654    return(list(LL0,LL1));
4655  }
4656  else
4657  {
4658    def L1=RrepNN(N,W,f);
4659    setring(RR);
4660    def LL0=imap(@P,L0);
4661    def LL1=imap(@P,L1);
4662    return(list(LL0,LL1));
4663  }
4664}
4665
4666// Prep
4667// Computes the P-representation of V(N) \ V(M).
4668// input:
4669//    ideal N (null ideal) (not necessarily radical nor maximal)
4670//    ideal M (hole ideal) (not necessarily containing N)
4671// output:
4672//    the ((p_1,(p_11,p_1k_1)),..,(p_r,(p_r1,p_rk_r)));
4673//    the Prep of V(N)\V(M)
4674// Assumed to work in the ring @P of the parameters
4675static proc Prep(ideal N, ideal M)
4676{
4677  if (N[1]==1)
4678  {
4679    //L0=list(list(ideal(1),list(ideal(1))));
4680    return(list(list(ideal(1),list(ideal(1)))));
4681  }
4682  def RR=basering;
4683  setring(@P);
4684  ideal Np=imap(RR,N);
4685  ideal Mp=imap(RR,M);
4686  int i; int j; list L0;
4687
4688  list Ni=minGTZ(Np);
4689  list prep;
4690  for(j=1;j<=size(Ni);j++)
4691  {
4692    option(redSB);
4693    Ni[j]=std(Ni[j]);
4694  }
4695  list Mij;
4696  for (i=1;i<=size(Ni);i++)
4697  {
4698    Mij=minGTZ(Ni[i]+Mp);
4699    for(j=1;j<=size(Mij);j++)
4700    {
4701      option(redSB);
4702      Mij[j]=std(Mij[j]);
4703    }
4704    if ((size(Mij)==1) and (equalideals(Ni[i],Mij[1])==1)){;}
4705    else
4706    {
4707        prep[size(prep)+1]=list(Ni[i],Mij);
4708    }
4709  }
4710  if (size(prep)==0){prep=list(list(ideal(1),list(ideal(1))));}
4711  setring(RR);
4712  return(imap(@P,prep));
4713}
4714
4715// PtoCrep
4716// Computes the C-representation from the P-representation.
4717// input:
4718//    list ((p_1,(p_11,p_1k_1)),..,(p_r,(p_r1,p_rk_r)));
4719//         the P-representation of V(N)\V(M)
4720// output:
4721//    list (ideal ida, ideal idb)
4722//    the C-represen taion of V(N)\V(M) = V(ida)\V(idb)
4723// Assumed to work in the ring @P of the parameters
4724static proc PtoCrep(list L)
4725{
4726  def RR=basering;
4727  setring(@P);
4728  def Lp=imap(RR,L);
4729  int i; int j;
4730  ideal ida=ideal(1); ideal idb=ideal(1); list Lb; ideal N;
4731  for (i=1;i<=size(Lp);i++)
4732  {
4733    option(returnSB);
4734    N=Lp[i][1];
4735    ida=intersect(ida,N);
4736    Lb=Lp[i][2];
4737    for(j=1;j<=size(Lb);j++)
4738    {
4739      idb=intersect(idb,Lb[j]);
4740    }
4741  }
4742  def La=list(ida,idb);
4743  setring(RR);
4744  return(imap(@P,La));
4745}
4746
4747// addnewpairs:
4748// 14/09/2010
4749// input:
4750//    ideal F, the given ideal
4751//    list P: the list of existing pairs to be computed
4752//    int l (the new index to add S-pols)
4753// output: list of ordered pairs (i,j,lcmij) of F in ascending order of lcmij
4754//         adding the new (i,l,lcmil) and placing them in order of ascending lcm
4755//         if a pair verifies Buchberger 1st criterion it is not stored
4756// ring @R
4757static proc addnewpairs(ideal F, list P, int l)
4758{
4759  int i;
4760  poly lm;
4761  poly lpf;
4762  poly lpg;
4763  list P1=P;
4764  list pair;
4765  if (size(F)<=1){return(P);}
4766  for (i=1;i<l;i++)
4767  {
4768    lm=lcmlmonoms(F[i],F[l]);
4769    // Buchberger 1st criterion
4770    lpf=leadmonom(F[i]);
4771    lpg=leadmonom(F[l]);
4772    if (lpf*lpg!=lm)
4773    {
4774      pair=(i,l,lm);
4775      P1=placepairinlist(pair,P1);
4776    }
4777  }
4778  return(P1);
4779}
4780
4781// DiscussPolys: given the data in a vertex of btcgs (BuildTree), it analyzes the
4782//               leadcoef of the polynomials in B until it finds
4783//               that one of them can be either null or non null.
4784//               In that case, recbtcgs has to split into two branches, and then
4785//               l < size(B)
4786//               If not, and at the end only the non null option is compatible
4787//               then the reduced B has all the leadcoef non null, and then l=size(B).
4788//               15/09/2010
4789// ring @R
4790// input:
4791//    B:   (ideal) the actual basis
4792//    N:   (ideal) null conditions (R-rep)
4793//    W:   (ideal) non-null conditions set (R-rep)
4794//    P:   (list) of pairs of indices of S-polynomials that can and must be computed
4795//         (its leading coefficients are non-null, and using Buchberger's
4796//          criterions they are to be computed)
4797//    l:   (integer) representing the last polynomial in B for which the leading
4798//         coefficient is already assumed non-null.
4799// output: list of (cond,lpp,B,N0,W0,P0,l0,N1,W1,P1,l1)
4800//         cond (poly) is the polynomial responsible of the branch
4801//         B is the new discussed basis. (It can contain less polynomials when
4802//         some polynomial has been reduced to 0 by previous null-assumptions.
4803//         (N0,W0,P0,l0) and (N1,W1,P1,l1) are respectively the R-representation,
4804//         list of S-polys to be computed, and the last poly with assumed non-null
4805//         coefficient in both the null side and the non-null side.
4806static proc DiscussPolys(ideal B, ideal N, ideal W, list P, int l)
4807{
4808  list Pn=P; ideal Bn=B; int ln=l; ideal Nn=N; ideal Wn=W;
4809  int testsplit=0;
4810  poly f; poly lc; list L; int j;
4811  int l0; int l1; list P0; list P1; ideal N0; ideal W0; ideal N1; ideal W1;
4812  while((testsplit==0) and (ln<size(Bn)))
4813  {
4814    //f=redcoefs(Bn[ln+1],Nn);
4815    f=pnormalform(Bn[ln+1],Nn,Wn);
4816    if (f==0)
4817    {
4818      Bn=delfromideal(Bn,ln+1); //lppn=delfromideal(lppn,ln+1);
4819    }
4820    else
4821    {
4822      Bn[ln+1]=f;
4823      lc=leadcoef(f);
4824      L=splitR(Nn,Wn,lc);
4825      N0=L[1][1];
4826      W0=L[1][2];
4827      N1=L[2][1];
4828      W1=L[2][2];
4829      P1=addnewpairs(Bn,Pn,ln+1); // uses Buchberger pair selection and standard order
4830      if(N0[1]<>1)
4831      {
4832        testsplit=1;
4833        l0=ln; l1=ln+1;
4834        P0=Pn;
4835      }
4836      else
4837      {
4838        Pn=P1; P0=list(); ln=ln+1; Nn=N1; Wn=W1; l1=ln;
4839      }
4840    }
4841  }
4842  if(testsplit==0)
4843  {
4844    N1=Nn; W1=Wn; N0=ideal(1); W0=ideal(0); P0=list();
4845    l0=size(Bn); l1=size(Bn); P1=Pn;
4846  }
4847  return(list(lc,Bn,N0,W0,P0,l0,N1,W1,P1,l1));
4848}
4849
4850// DiscussSPolys: given the data in a vertex of btcgs (BuildTree),
4851//               and when DiscussPolys has already built a vertex where
4852//               all the leadcoef are non-null in the R-representation,
4853//               it computes and reduces the S-polys in the list P in order
4854//               until it finds some non-reducing one. Then adds it to the
4855//               basis and modifies the list P.
4856//               Then it calls splitR and if the leadcoef non-null is, it
4857//               continues with the next S-poly in the list.
4858//               Else it finishes and recbtcgs will need to split.
4859//               15/09/2010
4860// ring @R
4861// input:
4862//    B:   (ideal) the actual basis
4863//    N:   (ideal) null conditions (R-rep)
4864//    W:   (ideal) non-null conditions set (R-rep)
4865//    P:   (list) of pairs of indices of S-polynomials that can and must be computed
4866//         (its leading coefficients are non-null, and using Buchberger's
4867//          criterions they are to be computed)
4868//    l:   (integer) representing the last polynomial in B for which the leading
4869//         coefficient is already assumed non-null.
4870// output: list of (cond,lpp,B,N0,W0,P0,l0,N1,W1,P1,l1)
4871//         cond (poly) is the polynomial responsible of the branch
4872//         B is the new discussed basis. (It can contain less polynomials when
4873//         some polynomial has been reduced to 0 by previous null-assumptions.
4874//         (N0,W0,P0,l0) and (N1,W1,P1,l1) are respectively the R-representation,
4875//         list of S-polys to be computed, and the last poly with assumed non-null
4876//         coefficient in both the null side and the non-null side.
4877static proc DiscussSPolys(ideal B,ideal N,ideal W,list P,int l)
4878{
4879  def RR=basering;
4880  list Pn=P; ideal Bn=B; int ln=l; ideal Nn=N; ideal Wn=W;
4881  int testsplit=0;
4882  poly lc; list L; int i; int j; poly S; list pair;
4883  int l0; int l1; list P0; list P1; ideal N0; ideal W0; ideal N1; ideal W1;
4884//  poly lc0;
4885  while((testsplit==0) and (size(Pn)<>0))
4886  {
4887    pair=Pn[1];
4888    i=pair[1]; j=pair[2];
4889    Pn=delete(Pn,1);
4890    lc=1; N1=Nn; W1=Wn;
4891    S=pspol(Bn[i],Bn[j]);
4892    S=pdivi(S,Bn)[1];
4893    //S=redcoefs(S,Nn);
4894    S=pnormalform(S,Nn,Wn);
4895    if (S<>0)
4896    {
4897      Bn[size(Bn)+1]=S;
4898      lc=leadcoef(S);
4899      ln=ln+1;
4900      L=splitR(Nn,Wn,lc);
4901      N0=L[1][1];
4902      W0=L[1][2];
4903      N1=L[2][1];
4904      W1=L[2][2];
4905      P1=addnewpairs(Bn,Pn,ln); // uses Buchberger pair selection and standard order
4906      if(N0[1]<>1)
4907      {
4908        testsplit=1;
4909        l0=ln-1; l1=ln;
4910        P0=Pn;
4911      }
4912      else
4913      {
4914        Pn=P1;  Nn=N1; Wn=W1; P0=list(); W0=ideal(0);
4915      }
4916    }
4917  }
4918  if(testsplit==0)
4919  {
4920    N0=ideal(1); W0=ideal(0); P0=list(); l0=0;  N1=Nn; W1=Wn;
4921    l1=size(Bn);
4922  }
4923  return(list(lc,Bn,N0,W0,P0,l0,N1,W1,P1,l1));
4924}
4925
4926// cgsdr
4927// 20/09/2010
4928proc cgsdr(ideal F, list #)
4929"USAGE:   cgsdr(F); To compute a disjoint, reduced CGS.
4930          cgsdr is the starting point of the fundamental routine grobcov.
4931          It is to be used if only a disjoint reduced CGS is required.
4932          F: ideal in Q[a][x] (parameters and variables) to be discussed.
4933
4934          Options: To modify the default options, pairs of arguments
4935          -option name, value- of valid options must be added to the call.
4936
4937          Options:
4938            "null",ideal N: The default is "null",ideal(0).
4939            "nonnull",ideal W: The default "nonnull",ideal(1).
4940                When options "null" and/or "nonnull" are given, then
4941                the parameter space is restricted to V(N) \ V(h), where
4942                h is the product of the polynomials w in W.
4943            "comment",0-1: The default is "comment",0. Setting "comments",1
4944                will provide information about the development of the
4945                computation.
4946          One can give none till 3 of these options.
4947RETURN:   Returns a list T describing a reduced and disjoint comprehensive
4948          Groebner system (CGS), and whose segments correspond to
4949          constant leading power products (lpp) of the reduced Groebner
4950          basis. The returned list is of the form:
4951          (
4952            (lpp, (basis,segment),...,(basis,segment)),
4953            ..,,
4954            (lpp, (basis,segment),...,(basis,segment))
4955          )
4956          The bases are the reduced Groebner bases (after normalization)
4957          for each point of the corresponding segment.
4958          Each segment is given by a reduced representation (Ni,Wi), with
4959          Ni radical and V(Ni)=Zariski closure of the segment Si=V(Ni)\V(hi),
4960          where hi is the product of the polynomials w in Wi.
4961NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
4962          x=variables, and should be defined previously, and the ideal
4963          defined on R.
4964KEYWORDS: CGS, disjoint, reduced, comprehensive Groebner system
4965EXAMPLE:  cgsdr; shows an example"
4966{
4967  list @T;
4968  exportto(Top,@T);
4969  setglobalrings();
4970  int i;
4971  ideal B;
4972  poly f;
4973  def N=ideal(0);
4974  def W=ideal(1);
4975  int comment=0;
4976  list L=#;
4977  for(i=1;i<=size(L) div 2;i++)
4978  {
4979    if(L[2*i-1]=="null"){N=L[2*i];}
4980    else
4981    {
4982      if(L[2*i-1]=="nonnull"){W=L[2*i];}
4983      else
4984      {
4985        if(L[2*i-1]=="comment"){comment=L[2*i];}
4986      }
4987    }
4988  }
4989  if(N!=0)
4990  {
4991    def LL=Rrep(N,W);
4992    N=LL[1];
4993    W=LL[2];
4994    for (i=1;i<=size(F);i++)
4995    {
4996      f=pnormalform(F[i],N,W);
4997      if (f!=0){B[size(B)+1]=f;}
4998    }
4999  }
5000  else {B=F;}
5001  reccgsdr(B,N,W,list(),0);
5002  def T=@T;
5003  if (comment==1)
5004  {string("Number of segments in cgsdr (total) = ",size(T));}
5005  kill @T;
5006  kill @P; kill @RP; kill @R;
5007  return(grsegments(T));
5008}
5009example
5010{ "EXAMPLE:"; echo = 2;
5011  "Casas conjecture for degree 4";
5012  ring R=(0,a0,a1,a2,a3,a4),(x1,x2,x3),dp;
5013  ideal F=x1^4+(4*a3)*x1^3+(6*a2)*x1^2+(4*a1)*x1+(a0),
5014          x1^3+(3*a3)*x1^2+(3*a2)*x1+(a1),
5015          x2^4+(4*a3)*x2^3+(6*a2)*x2^2+(4*a1)*x2+(a0),
5016          x2^2+(2*a3)*x2+(a2),
5017          x3^4+(4*a3)*x3^3+(6*a2)*x3^2+(4*a1)*x3+(a0),
5018          x3+(a3);
5019  cgsdr(F);
5020}
5021
5022//reccgsdr
5023// 20/09/2010
5024static proc reccgsdr(ideal B, ideal N, ideal W, list P, int l)
5025{
5026  ideal Bn=B; ideal Nn=N; ideal Wn=W; list Pn=P; int ln=l;  ideal lppn;
5027  list L; int i;
5028  poly lc; ideal N0; ideal W0; list P0; int l0;
5029  ideal N1=Nn; ideal W1=Wn; list P1=Pn; int l1=ln;
5030  if (l>0)
5031  {
5032    if (size(variables(B[l]))==0)
5033    {
5034      lppn=1; Bn=1;
5035      @T[size(@T)+1]=list(lppn,Bn,N,W);
5036      return();
5037    }
5038  }
5039  if (ln<size(Bn))
5040  {
5041    L=DiscussPolys(Bn, Nn, Wn, Pn, ln);
5042    lc=L[1]; Bn=L[2]; N0=L[3]; W0=L[4]; P0=L[5]; l0=L[6];
5043                                 N1=L[7]; W1=L[8]; P1=L[9]; l1=L[10];
5044    ln=l0;
5045  }
5046  if ((ln==size(Bn)) and (size(Bn)<>0))
5047  {
5048    L=DiscussSPolys(Bn, N1, W1, P1, l1);
5049    lc=L[1]; Bn=L[2]; N0=L[3]; W0=L[4]; P0=L[5]; l0=L[6];
5050                                 N1=L[7]; W1=L[8]; P1=L[9]; l1=L[10];
5051  }
5052  if (N0[1]<>1)
5053  {
5054    reccgsdr(Bn, N0,W0,P0,l0);
5055    reccgsdr(Bn, N1,W1,P1,l1);
5056  }
5057  else
5058  {
5059    if (equalideals(N1,ideal(1))==0)
5060    {
5061      Bn=mingb(Bn);
5062      Bn=redgb(Bn,N1,W1);
5063      lppn=ideal(0);
5064      for (i=1; i<=size(Bn);i++){lppn[i]=leadmonom(Bn[i]);}
5065      @T[size(@T)+1]=list(lppn,Bn,N1,W1);
5066    }
5067  }
5068}
5069
5070// input:  internal routine called by cgsdr at the end to improve the output
5071// output: grouped segments by lpp obtained in cgsdr
5072static proc grsegments(list T)
5073{
5074  int i;
5075  list L;
5076  list lpp;
5077  list lp;
5078  list ls;
5079  int n=size(T);
5080  lpp[1]=T[n][1];
5081  L[1]=list(lpp[1],list(list(T[n][2],T[n][3],T[n][4])));
5082  if (n>1)
5083  {
5084    for (i=1;i<=size(T)-1;i++)
5085    {
5086      lp=memberpos(T[n-i][1],lpp);
5087      if(lp[1]==1)
5088      {
5089        ls=L[lp[2]][2];
5090        ls[size(ls)+1]=list(T[n-i][2],T[n-i][3],T[n-i][4]);
5091        L[lp[2]][2]=ls;
5092      }
5093      else
5094      {
5095        lpp[size(lpp)+1]=T[n-i][1];
5096        L[size(L)+1]=list(T[n-i][1],list(list(T[n-i][2],T[n-i][3],T[n-i][4])));
5097      }
5098    }
5099  }
5100  //"L in groupsegments="; L;
5101  return(L);
5102}
5103
5104// grRtoPrep
5105// input:  L (list) is the output of cgsdr
5106// output: LL (list) the same list but the segments are expressed
5107//                   in canonical representations:
5108//  ( (lpp, (basis,
5109//             ((P_1),(P_{11},...,P_{1t1}))
5110//             ...
5111//             ((P_j),(P_{j1},...,P_{jtj}))
5112//          )
5113//          ...
5114//          (basis,
5115//             ((P_1),(P_{11},...,P_{1t1}))
5116//             ...
5117//             ((P_j),(P_{j1},...,P_{jtj}))
5118//          )
5119//    )
5120//    ...
5121//    (lpp, (basis,
5122//             ((P_1),(P_{11},...,P_{1t1}))
5123//             ...
5124//             ((P_j),(P_{j1},...,P_{jtj}))
5125//          )
5126//          ...
5127//          (basis,
5128//             ((P_1),(P_{11},...,P_{1t1}))
5129//             ...
5130//             ((P_j),(P_{j1},...,P_{jtj}))
5131//          )
5132//    )
5133//  )
5134static proc grRtoPrep(list L)
5135{
5136  int i; int j;
5137  list LL; list ct;
5138  // size(L)=number of lpp-segments
5139  for (i=1;i<=size(L);i++)
5140  {
5141    LL[i]=list();
5142    LL[i][1]=L[i][1];
5143    // L[i][1]=lpp
5144    LL[i][2]=list();
5145    for (j=1;j<=size(L[i][2]);j++)
5146    {
5147      ct=RtoPrepNew(L[i][2][j][2],L[i][2][j][3]); // ,L[i][2][j][5]
5148      LL[i][2][j]=list();
5149      LL[i][2][j][1]=L[i][2][j][1];
5150      // L[i][2][j][1]=label
5151      LL[i][2][j][2]=L[i][2][j][2];
5152      // L[i][2][j][2]=basis
5153      LL[i][2][j][3]=ct;
5154    }
5155  }
5156  return(LL);
5157}
5158
5159// idcontains
5160// input: ideal p, ideal q
5161// output: 1 if p contains q,  0 otherwise
5162static proc idcontains(ideal p, ideal q)
5163{
5164  int t; int i;
5165  t=1; i=1;
5166  def RR=basering;
5167  setring @P;
5168  def P=imap(RR,p);
5169  def Q=imap(RR,q);
5170  attrib(P,"isSB",1);
5171  poly r;
5172  while ((t==1) and (i<=size(Q)))
5173  {
5174    r=reduce(Q[i],P);
5175    if (r!=0){t=0;}
5176    i++;
5177  }
5178  setring RR;
5179  return(t);
5180}
5181
5182// selectminindeals
5183//   given a list of ideals returns the list of integers corresponding
5184//   to the minimal ideals in the list
5185// input: L (list of ideals)
5186// output: the list of integers corresponding to the minimal ideals in L
5187static proc selectminideals(list L)
5188{
5189  if (size(L)==0){return(L);}
5190  def RR=basering;
5191  setring @P;
5192  def Lp=imap(RR,L);
5193  int i; int j; int t; intvec notsel;
5194  list P;
5195  for (i=1;i<=size(Lp);i++)
5196  {
5197    if(memberpos(i,notsel)[1]==1)
5198    {
5199      i++;
5200      if(i>size(Lp)){break;}
5201    }
5202    t=1;
5203    j=1;
5204    while ((t==1) and (j<=size(Lp)))
5205    {
5206      if (i==j){j++;}
5207      if ((j<=size(Lp)) and (memberpos(j,notsel)[1]==0))
5208      {
5209
5210        if (idcontains(Lp[i],Lp[j])==1)
5211        {
5212          notsel[size(notsel)+1]=i;
5213          t=0;
5214        }
5215      }
5216      j++;
5217    }
5218    if (t==1){P[size(P)+1]=i;}
5219  }
5220  setring(RR);
5221  return(P);
5222}
5223
5224// LCUnion
5225// Given a list of the P-representations of locally closed segments
5226// for which we know that the union is also locally closed
5227// it returns the P-representation of its union
5228// input:  L list of segments in P-representation
5229//      ((p_j^i,(p_j1^i,...,p_jk_j^i | j=1..t_i)) | i=1..s )
5230//      where i represents a segment
5231// output: P-representation of the union
5232//       ((P_j,(P_j1,...,P_jk_j | j=1..t)))
5233static proc LCUnion(list LL)
5234{
5235  def RR=basering;
5236  setring(@P);
5237  def L=imap(RR,LL);
5238  int i; int j; int k; list H; list C; list T;
5239  list L0; list P0; list P; list Q0; list Q;
5240  for (i=1;i<=size(L);i++)
5241  {
5242    for (j=1;j<=size(L[i]);j++)
5243    {
5244      P0[size(P0)+1]=L[i][j][1];
5245      L0[size(L0)+1]=intvec(i,j);
5246    }
5247  }
5248  Q0=selectminideals(P0);
5249  for (i=1;i<=size(Q0);i++)
5250  {
5251    Q[i]=L0[Q0[i]];
5252    P[i]=L[Q[i][1]][Q[i][2]];
5253  }
5254  // P is the list of the maximal components of the union
5255  //   with the corresponding initial holes.
5256  // Q is the list of intvec positions in L of the first element of the P's
5257  //   Its elements give (num of segment, num of max component (=min ideal))
5258  for (k=1;k<=size(Q);k++)
5259  {
5260    H=P[k][2]; // holes of P[k][1]
5261    for (i=1;i<=size(L);i++)
5262    {
5263      if (i!=Q[k][1])
5264      {
5265        for (j=1;j<=size(L[i]);j++)
5266        {
5267          C[size(C)+1]=L[i][j];
5268        }
5269      }
5270    }
5271    T[size(T)+1]=list(Q[k],P[k][1],addpart(H,C));
5272  }
5273  setring(RR);
5274  def TT=imap(@P,T);
5275  return(TT);
5276}
5277
5278// Called by LCUnion to modify the holes of a primepart of the union
5279// by the addition of the segments that do not correspond to that part
5280// Works on @P ring.
5281// Input:
5282//   H=(p_i1,..,p_is) the holes of a component to be transformed by the addition of
5283//        the segments C that do not correspond to that component
5284//   C=((q_1,(q_11,..,q_1l_1)),..,(q_k,(q_k1,..,q_kl_k)))
5285//        the list of segments to be added to the holes
5286static proc addpart(list H, list C)
5287{
5288  list Q; int i; int j; int k; int l; int t; int t1;
5289  Q=H; intvec notQ; list QQ; list addq;
5290  ideal q;
5291  i=1;
5292  while (i<=size(Q))
5293  {
5294    if (memberpos(i,notQ)[1]==0)
5295    {
5296      q=Q[i];
5297      t=1; j=1;
5298      while ((t==1) and (j<=size(C)))
5299      {
5300        if (equalideals(q,C[j][1])==1)
5301        {
5302          t=0;
5303          for (k=1;k<=size(C[j][2]);k++)
5304          {
5305            t1=1;
5306            //kill addq;
5307            //list addq;
5308            l=1;
5309            while((t1==1) and (l<=size(Q)))
5310            {
5311              if ((l!=i) and (memberpos(l,notQ)[1]==0))
5312              {
5313                if (idcontains(C[j][2][k],Q[l])==1)
5314                {
5315                  t1=0;
5316                }
5317              }
5318              l++;
5319            }
5320            if (t1==1)
5321            {
5322              addq[size(addq)+1]=C[j][2][k];
5323            }
5324          }
5325          if((size(notQ)==1) and (notQ[1]==0)){notQ[1]=i;}
5326          else {notQ[size(notQ)+1]=i;}
5327        }
5328        j++;
5329      }
5330      if (size(addq)>0)
5331      {
5332        for (k=1;k<=size(addq);k++)
5333        {
5334          Q[size(Q)+1]=addq[k];
5335        }
5336        kill addq;
5337        list addq;
5338      }
5339      //print("Q="); Q; print("notQ="); notQ;
5340    }
5341    i++;
5342  }
5343  for (i=1;i<=size(Q);i++)
5344  {
5345    if(memberpos(i,notQ)[1]==0)
5346    {
5347      QQ[size(QQ)+1]=Q[i];
5348    }
5349  }
5350  if (size(QQ)==0){QQ[1]=ideal(1);}
5351  return(addpartfine(QQ,C));
5352}
5353
5354// Called by addpart to finish the modification of the holes of a primepart
5355// of the union by the addition of the segments that do not correspond to
5356// that part.
5357// Works on @P ring.
5358static proc addpartfine(list H, list C0)
5359{
5360  int i; int j; int k; int te; intvec notQ; int l; list sel; int used;
5361  intvec jtesC;
5362  if ((size(H)==1) and (equalideals(H[1],ideal(1)))){return(H);}
5363  if (size(C0)==0){return(H);}
5364  def RR=basering;
5365  setring(@P);
5366  list newQ; list nQ; list Q; list nQ1; list Q0;
5367  def Q1=imap(RR,H);
5368  //Q1=sortlistideals(Q1);
5369  def C=imap(RR,C0);
5370  while(equallistideals(Q0,Q1)==0)
5371  {
5372    Q0=Q1;
5373    i=0;
5374    Q=Q1;
5375    kill notQ; intvec notQ;
5376    while(i<size(Q))
5377    {
5378      i++;
5379      for(j=1;j<=size(C);j++)
5380      {
5381        te=idcontains(Q[i],C[j][1]);
5382        if(te==1)
5383        {
5384          for(k=1;k<=size(C[j][2]);k++)
5385          {
5386            if(idcontains(Q[i],C[j][2][k])==1)
5387            {
5388              te=0; break;
5389            }
5390          }
5391          if (te==1)
5392          {
5393            used++;
5394            if ((size(notQ)==1) and (notQ[1]==0)){notQ[1]=i;}
5395            else{notQ[size(notQ)+1]=i;}
5396            kill newQ; list newQ;
5397            for(k=1;k<=size(C[j][2]);k++)
5398            {
5399              nQ=minGTZ(Q[i]+C[j][2][k]);
5400              for(l=1;l<=size(nQ);l++)
5401              {
5402                option(redSB);
5403                nQ[l]=std(nQ[l]);
5404                newQ[size(newQ)+1]=nQ[l];
5405              }
5406            }
5407            sel=selectminideals(newQ);
5408            kill nQ1; list nQ1;
5409            for(l=1;l<=size(sel);l++)
5410            {
5411              nQ1[l]=newQ[sel[l]];
5412            }
5413            newQ=nQ1;
5414            for(l=1;l<=size(newQ);l++)
5415            {
5416              Q[size(Q)+1]=newQ[l];
5417            }
5418            break;
5419          }
5420        }
5421      }
5422    }
5423    kill Q1; list Q1;
5424    for(i=1;i<=size(Q);i++)
5425    {
5426      if(memberpos(i,notQ)[1]==0)
5427      {
5428        Q1[size(Q1)+1]=Q[i];
5429      }
5430    }
5431    sel=selectminideals(Q1);
5432    kill nQ1; list nQ1;
5433    for(l=1;l<=size(sel);l++)
5434    {
5435      nQ1[l]=Q1[sel[l]];
5436    }
5437    Q1=nQ1;
5438  }
5439  setring(RR);
5440  //if(used>0){string("addpartfine was ", used, " times used");}
5441  return(imap(@P,Q1));
5442}
5443
5444//// specswell
5445//// used only in specswellonlpp (not used, can be deleted)
5446//// input:
5447////   given two corresponding polynomials g1 and g2 with the same lpp
5448////   g1 belonging to the basis in the segment N1,W1
5449////   g2 belonging to the basis in the segment N2,W2
5450//// output:
5451////   1 if g1 spezializes well to g2 on the whole (N2,W2) segment
5452////   0 if not
5453//proc specswell(poly g1, poly g2, ideal N2, ideal W2)
5454//{
5455//  poly S;
5456//  S=leadcoef(g2)*g1-leadcoef(g1)*g2;
5457//  def RR=basering;
5458//  setring(@RPt);
5459//  def SR=imap(RR,S);
5460//  def N2R=imap(RR,N2);
5461//  attrib(N2R,"isSB",1);
5462//  poly S2R=reduce(SR,N2R);
5463//  setring(RR);
5464//  def S2=imap(@RPt,S2R);
5465//  //if (S2==0)
5466//  //if (nonnull(leadcoef(g1),N2,W2)==1)
5467//  if ((S2==0) and (nonnull(leadcoef(g1),N2,W2)))
5468//  {return(1);}
5469//  else {return(0);}
5470//}
5471//
5472//// specswellonlpp
5473//// not used, can be deleted
5474//// input:
5475////   given a generic polynomial g with given lpp
5476////   and the list of tripets (p,N,W) of all the segments in
5477////   the same lpp-segment, where p is the correct image of g on (N,W)
5478//// output:
5479////   1 if g spezializes well to p on the whole (N,W) segment for all segments
5480////   0 if not
5481//proc specswellonlpp(poly g, list L)
5482//{
5483//  int i=1; int t=1;
5484//  while ((t==1) and (i<=size(L)))
5485//  {
5486//    t=specswell(g, L[i][1],L[i][2],L[i][3]);
5487//    i++;
5488//  }
5489//  return(t);
5490//}
5491
5492// specswellCrep
5493// input:
5494//   given two corresponding polynomials g1 and g2 with the same lpp
5495//   g1 belonging to the basis in the segment ida1,idb1
5496//   g2 belonging to the basis in the segment ida2,idb2
5497// output:
5498//   1 if g1 spezializes well to g2 on the whole (ida2,idb2) segment
5499//   0 if not
5500static proc specswellCrep(poly g1, poly g2, ideal ida2)
5501{
5502  poly S;
5503  S=leadcoef(g2)*g1-leadcoef(g1)*g2;
5504  def RR=basering;
5505  setring(@RPt);
5506  def SR=imap(RR,S);
5507  def ida2R=imap(RR,ida2);
5508  attrib(ida2R,"isSB",1);
5509  poly S2R=reduce(SR,ida2R);
5510  setring(RR);
5511  def S2=imap(@RPt,S2R);
5512  if (S2==0){return(1);}   // and (nonnullCrep(leadcoef(g1),ida2,idb2))
5513  else {return(0);}
5514}
5515
5516
5517// gcover
5518// input: ideal F: a generating set of a homogeneous ideal in Q[a][x]
5519//    list GenCase: Containing the generic case with basis 1 if it exists
5520//    list #: optional
5521// output: the list
5522//   S=((lpp, generic basis, Rrep, Crep),..,(lpp, generic basis, Rrep, Crep))
5523//      where a Rrep is ( (p1,(p11,..,p1k_1)),..,(pj,(pj1,..,p1k_j)) )
5524//            a Crep is ( ida, idb )
5525static proc gcover(ideal F,list GenCase, list #)
5526{
5527  int i; int j; int k; ideal lpp; list GPi2; list pairspP; ideal B; int ti;
5528  int i1; int tes; int j1; int selind; int i2; int m;
5529  list prep; list crep; list LCU; poly p; poly lcp; list L; ideal FF;
5530  list NW=#;
5531  int CGS=NW[3];
5532  int comment=NW[4];
5533  NW=NW[1],NW[2];
5534  list GS; list GP;
5535  def RR=basering;
5536  int start=timer; int start0=start; int start1=start;
5537  if (CGS==0)
5538  {
5539    def BT=buildtree(F,list("null",NW[1],"nonnull",NW[2]));
5540    setglobalrings();
5541    def FC=finalcases(BT);
5542    GS=groupsegments(FC);
5543    if(comment==1)
5544    {
5545      string("Number of segments in buildtree (total) = ",size(FC));
5546      string("Number of lpp segments in groupsegments = ",size(GS));
5547      string("Time in buildtree = ",timer-start," sec");
5548    }
5549    start=timer;
5550    GP=groupRtoPrep(GS);
5551    if (comment==1){string("Time in groupRtoPrep = ",timer-start," sec");}
5552  }
5553  else
5554  {
5555    GS=cgsdr(F,list("null",NW[1],"nonnull",NW[2],"comment",comment));
5556    setglobalrings();
5557    if(comment==1)
5558    {
5559      string("Number of lpp segments in cgsdr = ",size(GS));
5560      string("Time in cgsdr = ",timer-start," sec");
5561    }
5562    start=timer;
5563    GP=grRtoPrep(GS);
5564    if(comment==1){string("Time in grRtoPrep = ",timer-start," sec");}
5565  }
5566  for(i=1;i<=size(GP);i++)
5567  {
5568    if(size(GP[i][2])>1){GP[i][3]=1;}
5569    else{GP[i][3]=0;}
5570  }
5571  int SizeGC=size(GenCase);
5572  if (SizeGC>0)
5573  {
5574    int te=0;
5575    list NewGen; list CH;
5576    for (i=1;i<=size(GP);i++)
5577    {
5578      if(equalideals(GP[i][1],ideal(1))==1)
5579      {
5580        te=1;
5581        NewGen[1]=GenCase;
5582        for(j=1;j<=size(GP[i][2]);j++)
5583        {
5584          NewGen[j+1]=GP[i][2][j];
5585        }
5586        GP[i][2]=NewGen;
5587        if(i!=1)
5588        { \\exchange cases i and 1
5589          CH=GP[i];
5590          GP[i]=GP[1];
5591          GP[1]=CH;
5592        }
5593        break;
5594      }
5595    }
5596    if (te==0) // add GenCase as a new case
5597    {
5598      CH[1]=GenCase;
5599      //CH[1]=list(ideal(1),list(GenCase));
5600      for (i=1;i<=size(GP);i++)
5601      {
5602        CH[i+1]=GP[i];
5603      }
5604      GP=CH;
5605    }
5606  }
5607  for(i=1;i<=size(GP);i++)
5608  {
5609    GP[i][3]=size(GP[i][2]);
5610  }
5611  list LL;
5612  list S;
5613  poly sp;
5614  ideal BB;
5615  start1=timer;
5616  for (i=1;i<=size(GP);i++)
5617  {
5618    kill LL;
5619    list LL;
5620    lpp=GP[i][1];
5621    GPi2=GP[i][2];
5622    kill pairspP; list pairspP;
5623    for(j=1;j<=size(GPi2);j++)
5624    {
5625      pairspP[size(pairspP)+1]=GPi2[j][3];
5626    }
5627    LCU=LCUnion(pairspP);
5628    kill prep; list prep;
5629    for(k=1;k<=size(LCU);k++)
5630    {
5631      prep[k]=list(LCU[k][2],LCU[k][3]);
5632      if (CGS==0)
5633      {
5634        B=GPi2[LCU[k][1][1]][2];
5635      }
5636      else
5637      {
5638        B=GPi2[LCU[k][1][1]][1];
5639      }
5640      LCU[k][1]=B;
5641    }
5642    // Deciding if combine is needed
5643    kill BB;
5644    ideal BB;
5645    tes=1; m=1;
5646    while((tes==1) and (m<=size(LCU[1][1])))
5647    {
5648      j=1;
5649      while((tes==1) and (j<=size(LCU)))
5650      {
5651        k=1;
5652        while((tes==1) and (k<=size(LCU)))
5653        {
5654          if(j!=k)
5655          {
5656            sp=pnormalform(pspol(LCU[j][1][m],LCU[k][1][m]),LCU[k][2],NW[2]);
5657            if(sp!=0){tes=0;}
5658          }
5659          k++;
5660        }
5661        if(tes==1)
5662        {
5663          BB[m]=LCU[j][1][m];
5664        }
5665        j++;
5666      }
5667      if(tes==0){break;}
5668      m++;
5669    }
5670    crep=PtoCrep(prep);
5671    if(tes==0)
5672    {
5673      // combine is needed
5674      kill B; ideal B;
5675      for (j=1;j<=size(LCU);j++)
5676      {
5677        LL[j]=LCU[j][2];
5678      }
5679      if (size(LCU)>1)
5680      {
5681        FF=precombint(LL);
5682      }
5683      for (k=1;k<=size(lpp);k++)
5684      {
5685        kill L; list L;
5686        for (j=1;j<=size(LCU);j++)
5687        {
5688          L[j]=list(LCU[j][2],LCU[j][1][k]);
5689        }
5690        if (size(LCU)>1)
5691        {
5692          B[k]=combine(L,FF);
5693        }
5694        else{B[k]=L[1][2];}
5695      }
5696    }
5697    else{B=BB;}
5698    for(j=1;j<=size(B);j++)
5699    {
5700      B[j]=pnormalform(B[j],crep[1],NW[2]);
5701    }
5702    S[i]=list(lpp,B,prep,crep,GP[i][3]);
5703  }
5704  if(comment==1)
5705  {
5706    string("Time in LCUnion + combine = ",timer-start1," sec");
5707  }
5708  kill @P; kill @RP; kill @R;
5709  return(S);
5710}
5711
5712// grobcov
5713// input:
5714//    ideal F: a parametric ideal in Q[a][x], where a are the parameters
5715//             and x the variables
5716//    list #: (options) list("null",N,"nonnull",W,"can",Method,"cgs",CGS), where
5717//            N is the null conditions ideal (if desired)
5718//            W is the ideal of non-null conditions (if desired)
5719//            Method is 1 by default and can be set to 0 if we do not
5720//            need to obtain the canonical GC, but only a GC.
5721//            CGS is 1 by default and uses cgsdr. It can be set to 0 to
5722//            use the old buildtree instead.
5723// output:
5724//    list S: ((lpp,basis,(idp_1,(idp_11,..,idp_1s_1))), ..
5725//             (lpp,basis,(idp_r,(idp_r1,..,idp_rs_r))) ) where
5726//            each element of S corresponds to a lpp-segment
5727//            given by the lpp, the basis, and the P-representation of the segment
5728proc grobcov(ideal F,list #)
5729"USAGE:   grobcov(F); This is the fundamental routine of the
5730          library. It computes the Groebner cover of a parametric ideal
5731          (see (*) Montes A., Wibmer M., Groebner Bases for Polynomial
5732          Systems with parameters. JSC 45 (2010) 1391-1425.)
5733          The Groebner cover of a parametric ideal consist of a set of pairs
5734          (S_i,B_i), where the S_i are disjoint locally closed segments
5735          of the parameter space, and the B_i are the reduced Groebner
5736          bases of the ideal on every point of S_i.
5737
5738          The ideal F must be defined on a parametric ring Q[a][x].
5739          Options: To modify the default options, pair of arguments
5740          -option name, value- of valid options must be added to the call.
5741
5742          Options:
5743            "null",ideal N: The default is "null",ideal(0).
5744            "nonnull",ideal W: The default "nonnull",ideal(1).
5745                When options "null" and/or "nonnull" are given, then
5746                the parameter space is restricted to V(N) \ V(h), where
5747                h is the product of the polynomials w in W.
5748            "can",0-1: The default is "can",1. With the default option
5749                the homogenized ideal is computed before obtaining the
5750                Groebner cover, so that the result is the canonical
5751                Groebner cover. Setting "can",0 only homogenizes the basis
5752                so the result is not exactly canonical, but the computation
5753                is more efficient.
5754            "ext",0-1: The default is "ext",1. With the default option the
5755                full representation of the bases is computed (possible
5756                shaves) and often a simpler result is obtained. Setting
5757                "ext",0 only the generic representation is computed
5758                (single polynomials, but not specializing to non-zero at
5759                each point of the segment.
5760            "cgs",0-1: The default is "cgs",1. The default option uses the
5761                cgsdr routine of the actual library to compute the initial
5762                CGS (more efficient). Setting "cgs",0 it uses the routine
5763                cgsdrold of the old library redcgs.lib. This option can be
5764                tested if the default option does not terminate.
5765            "comment",0-1: The default is "comment",0. Setting "comments",1
5766                will provide information about the development of the
5767                computation.
5768          One can give none till 6 of these options.
5769RETURN:   The list
5770          (
5771           (lpp_1,basis_1,P-representation_1),
5772           ...
5773           (lpp_s,basis_s,P-represntation_s)
5774          )
5775
5776          The lpp are constant over a segment and correspond to the
5777          set of lpp of the reduced Groebner basis for each point
5778          of the segment.
5779
5780          Basis: to each element of lpp corresponds an I-regular function given          Groebner basis, and it is given in full representation (by
5781          in full representation (by default option "ext",1) or in
5782          generic representation (option "ext",0). The regular function is
5783          the corresponding element of the reduced Groebner basis for
5784          each point of the segment with the given lpp.
5785          For each point in the segment, the polynomial or the set of
5786          polynomials representing it, if they do not specialize to 0,
5787          then after normalization, specialize to the corresponding
5788          element of the reduced Groebner basis.
5789
5790          The P-representation of a segment is of the form
5791          ((p_1,(p_11,..,p_1k1)),..,(p_r,(p_r1,..,p_rkr))
5792          representing the segment U_i (V(p_i) \ U_j (V(p_ij))), where the
5793          p's are prime ideals.
5794
5795NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
5796          x=variables, and should be defined previously. The ideal must
5797          be defined on R.
5798KEYWORDS: Groebner cover, parametric ideal, canonical, discussion of
5799          parametric ideal, multigrobcov, gencase1.
5800EXAMPLE:  grobcov; shows an example"
5801{
5802  list S; int i; int ish=1; list GBR; list BR; int j; int k;
5803  list NW; ideal idp; ideal idq; int s; ideal ext; list SS;
5804  ideal N; ideal W; int canop;  int extop; int CGS; int repop;
5805  int gradorder; int comment=0; int m;
5806  list L=#;
5807  // default options
5808  int start=timer;
5809  def RR=basering;
5810  list NW0;
5811  W=ideal(1);
5812  N=ideal(0);
5813  canop=1; // canop=0 for homogenizing the basis but not the ideal (not canonical)
5814           // canop=1 for working with the homogenized ideal
5815  repop=0; // repop=0 for representing the segments in Prep
5816           // repop=1 for representing the segments in Crep
5817           // repop=2 for representing the segments in Prep and Crep
5818  extop=1; // extop=1 if the full representation of the bases are to be computed
5819           // extop=0 if only generic representation of the bases are to be computed
5820  CGS=1;   // CGS=1 if cgsdr is to be used (default)
5821           // CGS=0 if buildtree is to be used instead
5822  for(i=1;i<=size(L) div 2;i++)
5823  {
5824    if(L[2*i-1]=="can"){canop=L[2*i];}
5825    else
5826    {
5827      if(L[2*i-1]=="ext"){extop=L[2*i];}
5828      else
5829      {
5830        if(L[2*i-1]=="rep"){repop=L[2*i];}
5831        else
5832        {
5833          if(L[2*i-1]=="null"){N=L[2*i];}
5834          else
5835          {
5836            if(L[2*i-1]=="nonnull"){W=L[2*i];}
5837            else
5838            {
5839              if (L[2*i-1]=="cgs"){CGS=L[2*i];}
5840              else
5841              {
5842                if (L[2*i-1]=="comment"){comment=L[2*i];}
5843              }
5844            }
5845          }
5846        }
5847      }
5848    }
5849  }
5850  if (comment==1){string("Options: can = ",canop,", extend = ",extop,", cgs = ",CGS,", rep = ",repop);}
5851  for (i=1;i<=size(F);i++){ish=ishomog(F[i]); if(ish==0){break;}}
5852  NW0=list(N,W,CGS,comment);
5853  if (ish==1)
5854  {
5855    kill S;
5856    list gc;
5857    def S=gcover(F,gc,NW0);
5858    setglobalrings();
5859  }
5860  else
5861  {
5862    list RRL=ringlist(RR);
5863    if (RRL[3][1][1]=="dp"){gradorder=1;} else {gradorder=0;}
5864    RRL[3][1][1]="dp";
5865    //RRL[1][3][1][1]="dp"; // COMMENTED GIVES ERROR IN S53.
5866    def Pa=ring(RRL[1]);
5867    list Lx;
5868    Lx[1]=0;
5869    Lx[2]=RRL[2]+RRL[1][2];
5870    Lx[3]=RRL[1][3];
5871    Lx[4]=RRL[1][4];
5872    RRL[1]=0;
5873    def D=ring(RRL);
5874    def RP=D+Pa;
5875    setring(RP);
5876    def F1=imap(RR,F);
5877    def NW1=imap(RR,NW0);
5878    int gcyes=0;
5879    if (canop==1)
5880    {
5881      option(redSB);
5882      def F11=std(F1);
5883      setring(RR);
5884      list gc;
5885      def F2=imap(RP,F11);
5886      def NW2=imap(RP,NW1);
5887      if (size(NW2[1])==0)
5888      {
5889        gc=gencase1(F2,"compbas",0);
5890        if (size(gc)>0)
5891        {
5892          gcyes=1;
5893          NW2[1]=gc[4];
5894          //gc=delete(gc,4);
5895          list gcn;
5896          gcn[1]=ideal(1); // lpp
5897          gcn[2]=list(list(ideal(1),ideal(0),list(gc[3])));
5898          gc=gcn;
5899        }
5900      }
5901    }
5902    else
5903    {
5904      setring(RR);
5905      def NW2=NW0;
5906      def F2=imap(RP,F1);
5907    }
5908    //setglobalrings();
5909    setring RR; // ja hi es ?
5910    RRL=ringlist(RR);
5911    //if (RRL[3][1][1]!="dp"){ERROR("the order must be dp");}
5912    poly @t;
5913    ring H=0,@t,dp;
5914    def RH=RR+H;
5915    setring(RH);
5916    //kill @P;
5917    //kill @RP;
5918    //kill @R;
5919    //setglobalrings();
5920    //setring(@Rt);
5921    def FH=imap(RR,F2);
5922    list gcH;
5923    if (gcyes==1)
5924    {
5925      gcH=imap(RR,gc);
5926    }
5927    def NWH=imap(RR,NW2);
5928    for (i=1;i<=size(FH);i++)
5929    {
5930      FH[i]=homog(FH[i],@t);
5931    }
5932    def G=gcover(FH,gcH,NWH); // list(NWH[1],NWH[2],CGS,comment));
5933    for (i=1;i<=size(G);i++)
5934    {
5935      G[i][1]=subst(G[i][1],@t,1);
5936      G[i][2]=subst(G[i][2],@t,1);
5937    }
5938    setring(RR);
5939    setglobalrings();
5940    S=imap(RH,G);
5941    for (i=1;i<=size(S);i++)
5942    {
5943      S[i][2]=postredgb(mingb(S[i][2]));
5944      S[i][1]=postredgb(mingb(S[i][1]));
5945    }
5946  }
5947  // Now Extend;
5948  poly leadc;
5949  if (extop==1)
5950  {
5951    int start1=timer;
5952    for (i=1;i<=size(S);i++)
5953    {
5954      m=size(S[i][2]);
5955      for (j=1;j<=size(S[i][2]);j++)
5956      {
5957        idp=S[i][4][1];
5958        idq=S[i][4][2];
5959        if (size(idp)>0)
5960        {
5961          leadc=leadcoef(S[i][2][j]);
5962          kill ext;
5963          def ext=extend(S[i][2][j],idp,idq);
5964          if (typeof(ext)=="poly")
5965          {
5966            S[i][2][j]=pnormalform(ext,idp,W);
5967            //"T_Polynomial after extend="; S[i][2][j];
5968          }
5969          else
5970          {
5971            if(size(ext)==1)
5972            {
5973              S[i][2][j]=ext[1];
5974            }
5975            else
5976            {
5977              kill SS; list SS;
5978              for(s=1;s<=size(ext);s++)
5979              {
5980                ext[s]=pnormalform(ext[s],idp,W);
5981              }
5982              for(s=1;s<=size(S[i][2]);s++)
5983              {
5984                if(s!=j){SS[s]=S[i][2][s];}
5985                else{SS[s]=ext;}
5986              }
5987              S[i][2]=SS;
5988            }
5989          }
5990          //"T_ poly or ideal after extend="; S[i][2][j];
5991        }
5992      }
5993    }
5994    if(comment==1){string("Time in extend = ",timer-start1," sec");}
5995  }
5996  list Si; list nS;
5997  if (repop==0)
5998  {
5999    for(i=1;i<=size(S);i++)
6000    {
6001      Si=list(S[i][1],S[i][2],S[i][3]);
6002      nS[size(nS)+1]=Si;
6003    }
6004    S=nS;
6005  }
6006  else
6007  {
6008    if (repop==1)
6009    {
6010      for(i=1;i<=size(S);i++)
6011      {
6012        Si=list(S[i][1],S[i][2],S[i][4]);
6013        nS[size(nS)+1]=Si;
6014      }
6015      S=nS;
6016    }
6017  }
6018  kill @P; kill @RP; kill @R;
6019  if (comment==1)
6020  {
6021    string("Time for grobcov = ", timer-start," sec");
6022    string("Number of segments of grobcov = ", size(S));
6023  }
6024  return(S);
6025}
6026example
6027{ "EXAMPLE:"; echo = 2;
6028  "Casas conjecture for degree 4";
6029  ring R=(0,a0,a1,a2,a3,a4),(x1,x2,x3),dp;
6030  ideal F=x1^4+(4*a3)*x1^3+(6*a2)*x1^2+(4*a1)*x1+(a0),
6031          x1^3+(3*a3)*x1^2+(3*a2)*x1+(a1),
6032          x2^4+(4*a3)*x2^3+(6*a2)*x2^2+(4*a1)*x2+(a0),
6033          x2^2+(2*a3)*x2+(a2),
6034          x3^4+(4*a3)*x3^3+(6*a2)*x3^2+(4*a1)*x3+(a0),
6035          x3+(a3);
6036  grobcov(F);
6037}
6038
6039
6040// input:
6041//    poly g in K[a],
6042//    list P=(p_1,..p_r) representing a minimal prime decomposition
6043// output
6044//    poly f such taht f notin p_i forall i and
6045//           g-f in p_i forall i such that g notin p_i
6046static proc nonzerodivisor(poly gr, list Pr)
6047{
6048  def RR=basering;
6049  setring(@P);
6050  def g=imap(RR,gr);
6051  def P=imap(RR,Pr);
6052  int i; int k;  list J; ideal F;
6053  def f=g;
6054  ideal Pi;
6055  for (i=1;i<=size(P);i++)
6056  {
6057    option(redSB);
6058    Pi=std(P[i]);
6059    //attrib(Pi,"isST",1);
6060    if (reduce(g,Pi,1)==0){J[size(J)+1]=i;}
6061  }
6062  for (i=1;i<=size(J);i++)
6063  {
6064    F=ideal(1);
6065    for (k=1;k<=size(P);k++)
6066    {
6067      if (k!=J[i])
6068      {
6069        F=idint(F,P[k]);
6070      }
6071    }
6072    f=f+F[1];
6073  }
6074  setring(RR);
6075  def fr=imap(@P,f);
6076  return(fr);
6077}
6078
6079// input:
6080//   int i:
6081//   list LPr: (p1,..,pr) of prime components of an ideal in K[a]
6082// output:
6083//   list (fr,fnr) of two polynomials that are equal on V(pi)
6084//       and fr=0 on V(P) \ V(pi), and fnr is nonzero on V(pj) for all j.
6085static proc deltai(int i, list LPr)
6086{
6087  def RR=basering;
6088  setring(@P);
6089  def LP=imap(RR,LPr);
6090  int j; poly p;
6091  def F=ideal(1);
6092  poly f;
6093  poly fn;
6094  ideal LPi;
6095  for (j=1;j<=size(LP);j++)
6096  {
6097    if (j!=i)
6098    {
6099      F=idint(F,LP[j]);
6100    }
6101  }
6102  p=0; j=1;
6103  while ((p==0) and (j<=size(F)))
6104  {
6105    LPi=LP[i];
6106    attrib(LPi,"isSB",1);
6107    p=reduce(F[j],LPi);
6108    j++;
6109  }
6110  f=F[j-1];
6111  fn=nonzerodivisor(f,LP);
6112  setring(RR);
6113  def fr=imap(@P,f);
6114  def fnr=imap(@P,fn);
6115  return(list(fr,fnr));
6116}
6117
6118// input: a list of pairs ((p1,P1),..,(pr,Pr)) where
6119//    ideal pi is a prime component
6120//    poly Pi is the polynomial in K[a][x] on V(pi)\ V(Mi)
6121//    (p1,..,pr) are the prime decomposition of the lpp-segment
6122//    list crep =(ideal ida,ideal idb): the Crep of the segment.
6123//    list Pci of the intersecctions of all pj except the ith one
6124// output:
6125//    poly P on an open and dense set of V(p_1 int ... p_r)
6126static proc combine(list L, ideal F)
6127{
6128  // ATTENTION REVISE AND USE Pci and F
6129  int i; poly f;
6130  f=0;
6131  for(i=1;i<=size(L);i++)
6132  {
6133    f=f+F[i]*L[i][2];
6134  }
6135  f=elimconstfac(f);
6136  return(f);
6137}
6138
6139// elimconstfac: eliminate the factors in the polynom f that are in K[a]
6140// input:
6141//   poly f:
6142//   list L: of components of the segment
6143// output:
6144//   poly f2  where the factors of f in K[a] that are non-null on any component
6145//   have been dropped from f
6146static proc elimconstfac(poly f)
6147{
6148  int cond; int i; int j; int t;
6149  if (f==0){return(f);}
6150  def RR=basering;
6151  setring(@R);
6152  poly ff=imap(RR,f);
6153  list l=factorize(ff,0);
6154  poly f1=1;
6155  for(i=2;i<=size(l[1]);i++)
6156  {
6157      f1=f1*(l[1][i])^(l[2][i]);
6158  }
6159  setring(RR);
6160  def f2=imap(@R,f1);
6161  return(f2);
6162}
6163
6164// input:
6165//   poly f:  a polynomial in K[a]
6166//   ideal P: an ideal in K[a]
6167//   called from ring @R
6168// output:
6169//   t:  with value 1 if f reduces modulo P, 0 if not.
6170static proc nullin(poly f,ideal P)
6171{
6172  int t;
6173  def RR=basering;
6174  setring(@P);
6175  poly f0=imap(RR,f);
6176  ideal P0=imap(RR,P);
6177  attrib(P0,"isSB",1);
6178  if (reduce(f0,P0,1)==0){t=1;}
6179  else{t=0;}
6180  setring(RR);
6181  return(t);
6182}
6183
6184static proc polyinparamsonly(poly f)
6185{
6186  int t;
6187  def RR=basering;
6188  setring @R;
6189  def f0=imap(RR,f);
6190  if (size(variables(f0))==0){t=1;}
6191  else{t=0;}
6192  setring(RR);
6193  return(t);
6194}
6195
6196// monoms
6197static proc monoms(poly f)
6198{
6199  list L;
6200  if (f!=0) { L[size(f)]=list();}
6201  poly lm; poly lc; poly lp; poly Q; poly mQ;
6202  def p=f;
6203  int i=1;
6204  while (p!=0)
6205  {
6206    lm=lead(p);
6207    p=p-lm;
6208    lc=leadcoef(lm);
6209    lp=leadmonom(lm);
6210    L[i]=list(lc,lp);
6211    i++;
6212  }
6213  return(L);
6214}
6215
6216// input:
6217//   poly f: a generic polynomial in the basis
6218//   ideal idp: such that ideal(S)=idp
6219//   ideal idq: such that S=V(idp)\V(idq)
6220////   NW the list of ((N1,W1),..,(Ns,Ws)) of red-rep of the grouped
6221////      segments in the lpp-segment  NO MORE USED
6222// output:
6223static proc extend(poly f, ideal idp, ideal idq)
6224{
6225  matrix CC; poly Q; list NewMonoms;
6226  int i;  int j;  poly fout; ideal idout;
6227  list L=monoms(f);
6228  int nummonoms=size(L)-1;
6229  Q=L[1][1];
6230  if (nummonoms==0){return(f);}
6231  for (i=2;i<=size(L);i++)
6232  {
6233    CC=matrix(extendcoef(L[i][1],Q,idp,idq));
6234    NewMonoms[i-1]=list(CC,L[i][2]);
6235  }
6236  if (nummonoms==1)
6237  {
6238    for(j=1;j<=ncols(NewMonoms[1][1]);j++)
6239    {
6240      fout=NewMonoms[1][1][2,j]*L[1][2]+NewMonoms[1][1][1,j]*NewMonoms[1][2];
6241      //fout=pnormalform(fout,idp,W);
6242      if(ncols(NewMonoms[1][1])>1){idout[j]=fout;}
6243    }
6244    if(ncols(NewMonoms[1][1])==1){return(fout);} else{return(idout);}
6245  }
6246  else
6247  {
6248    //int start=timer;
6249    list cfi;
6250    list coefs;
6251    for (i=1;i<=nummonoms;i++)
6252    {
6253      kill cfi; list cfi;
6254      for(j=1;j<=ncols(NewMonoms[i][1]);j++)
6255      {
6256        cfi[size(cfi)+1]=NewMonoms[i][1][2,j];
6257      }
6258      coefs[i]=cfi;
6259    }
6260    def indexpolys=findindexpolys(coefs);
6261    for(i=1;i<=size(indexpolys);i++)
6262    {
6263      fout=L[1][2];
6264      for(j=1;j<=nummonoms;j++)
6265      {
6266        fout=fout+(NewMonoms[j][1][1,indexpolys[i][j]])/(NewMonoms[j][1][2,indexpolys[i][j]])*NewMonoms[j][2];
6267      }
6268      fout=cleardenom(fout);
6269      if(size(indexpolys)>1){idout[i]=fout;}
6270    }
6271    if (size(indexpolys)==1){return(fout);} else{return(idout);}
6272  }
6273}
6274
6275// input:
6276//   list coefs=( (q11,..,q1r_1),..,(qs1,..,qsr_1) )
6277//               of denominators of the monoms
6278// output:
6279//   list ind=(v_1,..,v_t) of intvec
6280//        each intvec v=(i_1,..,is) corresponds to a polynomial in the sheaf
6281//        that will be built from it in extend procedure.
6282static proc findindexpolys(list coefs)
6283{
6284  int i; int j; intvec numdens;
6285  for(i=1;i<=size(coefs);i++)
6286  {
6287    numdens[i]=size(coefs[i]);
6288  }
6289  def RR=basering;
6290  setring(@P);
6291  def coefsp=imap(RR,coefs);
6292  ideal cof; list combpolys; intvec v; int te; list mp;
6293  for(i=1;i<=size(coefsp);i++)
6294  {
6295    cof=ideal(0);
6296    for(j=1;j<=size(coefsp[i]);j++)
6297    {
6298      cof[j]=factorize(coefsp[i][j],3);
6299    }
6300    coefsp[i]=cof;
6301  }
6302  for(j=1;j<=size(coefsp[1]);j++)
6303  {
6304    v[1]=j;
6305    te=1;
6306    for (i=2;i<=size(coefsp);i++)
6307    {
6308      mp=memberpos(coefsp[1][j],coefsp[i]);
6309      if(mp[1])
6310      {
6311        v[i]=mp[2];
6312      }
6313      else{v[i]=0;}
6314    }
6315    combpolys[j]=v;
6316  }
6317  combpolys=reform(combpolys,numdens);
6318  setring RR;
6319  return(combpolys);
6320}
6321
6322
6323// extendcoef: given Q,P in K[a] where P/Q specializes on an open and dense subset
6324//      of the whole V(p1 int...int pr), it returns a basis of the module
6325//      of all syzygies equivalent to P/Q,
6326static proc extendcoef(poly P, poly Q, ideal idp, ideal idq)
6327{
6328  def RR=basering;
6329  setring(@P);
6330  def PL=ringlist(@P);
6331  PL[3][1][1]="dp";
6332  def P1=ring(PL);
6333  setring(P1);
6334  ideal idp0=imap(RR,idp);
6335  option(redSB);
6336  qring q=std(idp0);
6337  poly P0=imap(RR,P);
6338  poly Q0=imap(RR,Q);
6339  ideal PQ=Q0,-P0;
6340  module C=syz(PQ);
6341  setring @P;
6342  def idp1=imap(RR,idp);
6343  def idq1=imap(RR,idq);
6344  def C1=matrix(imap(q,C));
6345  def redC=selectregularfun(C1,idp1,idq1);
6346  setring(RR);
6347  def CC=imap(@P,redC);
6348  return(CC);
6349}
6350
6351// input:
6352//   list L of the polynomials matrix CC
6353//      (we assume that one of them is non-null on V(N)\V(M))
6354//   ideal N, ideal M: ideals representing the locally closed set V(N)\V(M)
6355// assume to work in @P
6356static proc selectregularfun(matrix CC, ideal NN, ideal MM)
6357{
6358  int numcombused;
6359  def RR=basering;
6360  setring @P;
6361  def C=imap(RR,CC);
6362  def N=imap(RR,NN);
6363  def M=imap(RR,MM);
6364  if (ncols(C)==1){return(C);}
6365
6366  int i; int j; int k; list c; intvec ci; intvec c0; intvec c1;
6367  list T; list T0; list T1; list LL; ideal N1;ideal M1; int te=0;
6368  for(i=1;i<=ncols(C);i++)
6369  {
6370    if((C[1,i]!=0) and (C[2,i]!=0))
6371    {
6372      if(c0==intvec(0)){c0[1]=i;}
6373      else{c0[size(c0)+1]=i;}
6374    }
6375  }
6376  def C1=submat(C,1..2,c0);
6377  for (i=1;i<=ncols(C1);i++)
6378  {
6379    c=comb(ncols(C1),i);
6380    for(j=1;j<=size(c);j++)
6381    {
6382      ci=c[j];
6383      numcombused++;
6384      if(i==1){N1=N+C1[2,j]; M1=M;}
6385      if(i>1)
6386      {
6387        kill c0; intvec c0 ; kill c1; intvec c1;
6388        c1=ci[size(ci)];
6389        for(k=1;k<size(ci);k++){c0[k]=ci[k];}
6390        T0=searchinlist(c0,LL);
6391        T1=searchinlist(c1,LL);
6392        N1=T0[1]+T1[1];
6393        M1=intersect(T0[2],T1[2]);
6394      }
6395      T=list(ci,PtoCrep(Prep(N1,M1)));
6396      LL[size(LL)+1]=T;
6397      if(equalideals(T[2][1],ideal(1))==1){te=1; break;}
6398    }
6399    if(te==1){break;}
6400  }
6401  ci=T[1];
6402  def Cs=submat(C1,1..2,ci);
6403  setring RR;
6404  return(imap(@P,Cs));
6405}
6406
6407// input:
6408//   intvec c:
6409//   list L=( (c1,T1),..(ck,Tk) )
6410//      where the c's are assumed to be intvects
6411// output:
6412//   object T with index c
6413static proc searchinlist(intvec c,list L)
6414{
6415  int i; list T;
6416  for(i=1;i<=size(L);i++)
6417  {
6418    if (L[i][1]==c)
6419    {
6420      T=L[i][2];
6421      break;
6422    }
6423  }
6424  return(T);
6425}
6426
6427// Input: C0 the matrtix of (P1,..,Pr)
6428//                          (Q1,..,Qr) of the regular function of a coefficient (P,Q)
6429//        NW0 the list of ((N1,W1),..(Ns,Ws)) of red-rep of the grouped
6430//        segments in the lpp-segment
6431// Output: (B, T) where
6432//        B is the submatrix of the selected minimal representants for the
6433//        regular function
6434//        T the matrix of ones and zeroes whose colums are associated
6435//        to the colums of B, with 1 in the segments where the representant
6436//        is nonnull and 0 if it can be.
6437static proc redext(matrix C0, list NW0)
6438{
6439  def RR=basering;
6440  setring(@P);
6441  def C=imap(RR,C0);
6442  def NW=imap(RR,NW0);
6443  int nc=ncols(C);
6444  int nr=size(NW);
6445  intmat T[nr][nc];
6446  int i; int j; int k; int t;
6447  for (i=1;i<=nc;i++)
6448  {
6449    for (j=1;j<=nr;j++)
6450    {
6451      t=nonnull(C[i][2],NW[j][1],NW[j][2]); // (Q,N,W)
6452      T[j,i]=t;
6453    }
6454  }
6455  int h; int tt=0;
6456  intvec c; intvec r;
6457  list cc;  int l;
6458  for (j=1;j<=2;j++){r[j]=j;}
6459  i=1;
6460  while((i<=nc) and (tt==0))
6461  {
6462    cc=comb(nc,i);
6463    tt=0;
6464    l=1;
6465    while((tt==0) and (l<=size(cc)))
6466    {
6467      tt=1;
6468      c=cc[l];
6469      j=1;
6470      while ((j<=nr) and (tt==1))
6471      {
6472        h=0;
6473        k=1;
6474        while ((h==0) and (k<=i))
6475        {
6476          if(T[j,c[k]]==1){h=1;}
6477          k++;
6478        }
6479        if (h==0){tt=0;}
6480        j++;
6481      }
6482      l++;
6483    }
6484    i++;
6485  }
6486  if (tt==0){"extendcoef does not extend to the whole S";}
6487  intvec rr;
6488  for (i=1;i<=nr;i++){rr[i]=i;}
6489  def B=submat(C,r,c);
6490  def TT=submat(T,rr,c);
6491  setring(RR);
6492  return(list(imap(@P,B),imap(@P,TT)));
6493}
6494
6495// comb: the list of combinations of elements (1,..n) of order p
6496static proc comb(int n, int p)
6497{
6498  list L; list L0;
6499  intvec c; intvec d;
6500  int i; int j; int last;
6501  if ((n<0) or (n<p))
6502  {
6503    return(L);
6504  }
6505  if (p==1)
6506  {
6507    for (i=1;i<=n;i++)
6508    {
6509      c=i;
6510      L[size(L)+1]=c;
6511    }
6512    return(L);
6513  }
6514  else
6515  {
6516    L0=comb(n,p-1);
6517    for (i=1;i<=size(L0);i++)
6518    {
6519      c=L0[i]; d=c;
6520      last=c[size(c)];
6521      for (j=last+1;j<=n;j++)
6522      {
6523        d[size(c)+1]=j;
6524        L[size(L)+1]=d;
6525      }
6526    }
6527    return(L);
6528  }
6529}
6530
6531// selectminsheaves
6532// Input: L=((v_11,..,v_1k_1),..,(v_s1,..,v_sk_s))
6533//    where:
6534//    The s lists correspond to the s coefficients of the polynomial f
6535//    (v_i1,..,v_ik_i) correspond to the k_i intvec v_ij of the
6536//    spezializations of the jth rekpresentant (Q,P) of the ith coefficient
6537//    v_ij is an intvec of size equal to the number of little segments
6538//    forming the lpp-segment of 0,1, where 1 represents that it specializes
6539//    to non-zedro an the whole little segment and 0 if not.
6540// Output: S=(w_1,..,w_j)
6541//    where the w_l=(n_l1,..,n_ls) are intvec of length size(L), where
6542//    n_lt fixes which element of (v_t1,..,v_tk_t) is to be
6543//    choosen to form the tth (Q,P) for the lth element of the sheaf
6544//    representing the I-regular function.
6545// The selection is done to obtian the minimal number of elements
6546//    of the sheaf that specializes to non-null everywhere.
6547static proc selectminsheaves(list L)
6548{
6549  list C=allsheaves(L);
6550  return(smsheaves(C[1],C[2]));
6551}
6552
6553// Input:
6554//   list C of all the combrep
6555//   list L of the intvec that correesponds to each element of C
6556// Output:
6557//   list LL of the subsets of C that cover all the subsegments
6558//   (the union of the corresponding L(C) has all 1).
6559static proc smsheaves(list C, list L)
6560{
6561  int i; int i0; intvec W;
6562  int nor; int norn;
6563  intvec p;
6564  int sp=size(L[1]); int j0=1;
6565  for (i=1;i<=sp;i++){p[i]=1;}
6566  while (p!=0)
6567  {
6568    i0=0; nor=0;
6569    for (i=1; i<=size(L); i++)
6570    {
6571      norn=numones(L[i],pos(p));
6572      if (nor<norn){nor=norn; i0=i;}
6573    }
6574    W[j0]=i0;
6575    j0++;
6576    p=actualize(p,L[i0]);
6577  }
6578  list LL;
6579  for (i=1;i<=size(W);i++)
6580  {
6581    LL[size(LL)+1]=C[W[i]];
6582  }
6583  return(LL);
6584}
6585
6586// allsheaves
6587// Input: L=((v_11,..,v_1k_1),..,(v_s1,..,v_sk_s))
6588//    where:
6589//    The s lists correspond to the s coefficients of the polynomial f
6590//    (v_i1,..,v_ik_i) correspond to the k_i intvec v_ij of the
6591//    spezializations of the jth rekpresentant (Q,P) of the ith coefficient
6592//    v_ij is an intvec of size equal to the number of little segments
6593//    forming the lpp-segment of 0,1, where 1 represents that it specializes
6594//    to non-zero on the whole little segment and 1 if not.
6595// Output:
6596//    (list LL, list LLS)  where
6597//    LL is the list of all combrep
6598//    LLS is the list of intvec of the corresponding elements of LL
6599static proc allsheaves(list L)
6600{
6601  intvec V; list LL; intvec W; int r; intvec U;
6602  int i; int j; int k;
6603  int s=size(L[1][1]); // s = number of little segments of the lpp-segment
6604  list LLS;
6605  for (i=1;i<=size(L);i++)
6606  {
6607    V[i]=size(L[i]);
6608  }
6609  LL=combrep(V);
6610  for (i=1;i<=size(LL);i++)
6611  {
6612    W=LL[i];   // size(W)= number of coefficients of the polynomial
6613    kill U; intvec U;
6614    for (j=1;j<=s;j++)
6615    {
6616      k=1; r=1; U[j]=1;
6617      while((r==1) and (k<=size(W)))
6618      {
6619        if(L[k][W[k]][j]==0){r=0; U[j]=0;}
6620        k++;
6621      }
6622    }
6623    LLS[i]=U;
6624  }
6625  return(list(LL,LLS));
6626}
6627
6628// numones
6629// Input:
6630//   intvec v of (0,1) in each position
6631//   intvec pos: the positions to test
6632// Output:
6633//   int nor: the nuber of 1 of v in the positions given by pos.
6634static proc numones(intvec v, intvec pos)
6635{
6636  int i; int n;
6637  for (i=1;i<=size(pos);i++)
6638  {
6639    if (v[pos[i]]==1){n++;}
6640  }
6641  return(n);
6642}
6643
6644// Input:  intvec p of zeros and ones
6645// Output: intvec W of the positions where p has ones.
6646static proc pos(intvec p)
6647{
6648  int i;
6649  intvec W; int j=1;
6650  for (i=1; i<=size(p); i++)
6651  {
6652    if (p[i]==1){W[j]=i; j++;}
6653  }
6654  return(W);
6655}
6656
6657// actualize: actualizes zeroes of p
6658// Input:
6659//   intvec p: of zeroes and ones
6660//   intvec c: of zeroes and ones (of the same length)
6661// Output;
6662//   intvec pp: of zeroes and ones, where a 0 stays in pp[i] if either
6663//   already p[i]==0 or c[i]==1.
6664static proc actualize(intvec p, intvec c)
6665{
6666  int i; intvec pp=p;
6667  for (i=1;i<=size(p);i++)
6668  {
6669    if ((pp[i]==1) and (c[i]==1)){pp[i]=0;}
6670  }
6671  return(pp);
6672}
6673
6674// combrep
6675// Input: V=(n_1,..,n_i)
6676// Output: L=(v_1,..,v_p) where p=prod_j=1^i (n_j)
6677//    is the list of all intvec v_j=(v_j1,..,v_ji) where 1<=v_jk<=n_i
6678static proc combrep(intvec V)
6679{
6680  list L; list LL;
6681  int i; int j; int k;  intvec W;
6682  if (size(V)==1)
6683  {
6684    for (i=1;i<=V[1];i++)
6685    {
6686      L[i]=intvec(i);
6687    }
6688    return(L);
6689  }
6690  for (i=1;i<size(V);i++)
6691  {
6692    W[i]=V[i];
6693  }
6694  LL=combrep(W);
6695  for (i=1;i<=size(LL);i++)
6696  {
6697    W=LL[i];
6698    for (j=1;j<=V[size(V)];j++)
6699    {
6700      W[size(V)]=j;
6701      L[size(L)+1]=W;
6702    }
6703  }
6704  return(L);
6705}
6706
6707static proc reducemodN(poly f,ideal N)
6708{
6709  def RR=basering;
6710  setring(@RPt);
6711  def fa=imap(RR,f);
6712  def Na=imap(RR,N);
6713  attrib(Na,"isSB",1);
6714  // //option(redSB);
6715  // Na=std(Na);
6716  fa=reduce(fa,Na);
6717  setring(RR);
6718  def f1=imap(@RPt,fa);
6719  return(f1);
6720}
6721
6722// computes the intersection of the ideals in S in @P
6723static proc intersp(list S)
6724{
6725  def RR=basering;
6726  setring(@P);
6727  def SP=imap(RR,S);
6728  option(returnSB);
6729  def NP=intersect(SP[1..size(SP)]);
6730  setring(RR);
6731  return(imap(@P,NP));
6732}
6733
6734static proc radicalmember(poly f,ideal ida)
6735{
6736  int te;
6737  def RR=basering;
6738  setring(@P);
6739  poly fp=imap(RR,f);
6740  ideal idap=imap(RR,ida);
6741  poly @t;
6742  ring H=0,@t,dp;
6743  def PH=@P+H;
6744  setring(PH);
6745  def fH=imap(@P,fp);
6746  ideal idaH=imap(@P,idap);
6747  idaH[ncols(idaH)+1]=1-@t*fH;
6748  option(redSB);
6749  ideal G=std(idaH);
6750  //"G="; G;
6751  if (G==1){te=1;} else {te=0;}
6752  setring(RR);
6753  return(te);
6754}
6755
6756// returns 1 if the poly f is nonnull on V(N)\V(M), 0 otherwise.
6757static proc NonNull(poly f, ideal N, ideal M)
6758{
6759  int te=1; int i;
6760  def RR=basering;
6761  setring(@P);
6762  poly fp=imap(RR,f);
6763  ideal Np=imap(RR,N);
6764  ideal Mp=imap(RR,M);
6765  ideal H;
6766  ideal Nf=Np+fp;
6767  for (i=1;i<=ncols(Mp);i++)
6768  {
6769    te=radicalmember(Mp[i],Nf);
6770    if (te==0) break;
6771  }
6772  setring RR;
6773  return(te);
6774}
6775
6776// input:
6777//    matrix CC: CC=(p_a1 .. p_ar_a)
6778//                  (q_a1 .. q_ar_a)
6779//            the matrix of elements of a coefficient in oo[a].
6780//    (ideal ida, ideal idb): the canonical representation of the segment S.
6781// output:
6782//    list caout
6783//            the minimum set of elements of CC needed such that at least one
6784//            of the q's is non-null on S, as well as the C-rep of of the
6785//            points where the q's are null on S.
6786//            The elements of caout are of the form (p,q,prep);
6787static proc selectextendcoef(matrix CC, ideal ida, ideal idb)
6788{
6789  def RR=basering;
6790  setring(@P);
6791  def ca=imap(RR,CC);
6792  def N0=imap(RR,ida);
6793  ideal N;
6794  def M=imap(RR,idb);
6795  int r=ncols(ca);
6796  int i; int te=1; list com; int j; int k; intvec c; list prep;
6797  list cs; list caout;
6798  i=1;
6799  while ((i<=r) and (te==1))
6800  {
6801    com=comb(r,i);
6802    j=1;
6803    while((j<=size(com)) and (te==1))
6804    {
6805      N=N0;
6806      c=com[j];
6807      for (k=1;k<=i;k++)
6808      {
6809        N=N+ca[2,c[k]];
6810      }
6811      prep=Prep(N,M);
6812      if (i==1)
6813      {
6814        cs[j]=list(ca[1,j],ca[2,j],prep);
6815      }
6816      if ((size(prep)==1) and (equalideals(prep[1][1],ideal(1))))
6817      {
6818        te=0;
6819        for(k=1;k<=size(c);k++)
6820        {
6821          caout[k]=cs[c[k]];
6822        }
6823      }
6824      j++;
6825    }
6826    i++;
6827  }
6828  if (te==1){"error: extendcoef does not extend to the whole S";}
6829  setring(RR);
6830  return(imap(@P,caout));
6831}
6832
6833// input:
6834//   ideal N1: in some basering (depends only on the parameters)
6835//   ideal N2: in some basering (depends only on the parameters)
6836// output:
6837//   ideal Np=N1+N2; computed in P
6838static proc plusP(ideal N1,ideal N2)
6839{
6840  def RR=basering;
6841  setring(@P);
6842  def N1p=imap(RR,N1);
6843  def N2p=imap(RR,N2);
6844  def Np=N1p+N2p;
6845  setring RR;
6846  return(imap(@P,Np));
6847}
6848
6849// input:
6850//   list combpolys: (v1,..,vs)
6851//      where vi are intvec.
6852//   output outcomb: (w1,..,wt)
6853//      whre wi are intvec.
6854//      All the vi without zeroes are in outcomb, and those with zeroes are
6855//         combined to form new intvec with the rest
6856static proc reform(list combpolys, intvec numdens)
6857{
6858  list combp0; list combp1; int i; int j; int k; int l; list rest; intvec notfree;
6859  list free; intvec free1; int te; intvec v;  intvec w;
6860  int nummonoms=size(combpolys[1]);
6861  for(i=1;i<=size(combpolys);i++)
6862  {
6863    if(memberpos(0,combpolys[i])[1]==1)
6864    {
6865      combp0[size(combp0)+1]=combpolys[i];
6866    }
6867    else {combp1[size(combp1)+1]=combpolys[i];}
6868  }
6869  for(i=1;i<=nummonoms;i++)
6870  {
6871    kill notfree; intvec notfree;
6872    for(j=1;j<=size(combpolys);j++)
6873    {
6874      if(combpolys[j][i]<>0)
6875      {
6876        if(notfree[1]==0){notfree[1]=combpolys[j][i];}
6877        else{notfree[size(notfree)+1]=combpolys[j][i];}
6878      }
6879    }
6880    kill free1; intvec free1;
6881    for(j=1;j<=numdens[i];j++)
6882    {
6883      if(memberpos(j,notfree)[1]==0)
6884      {
6885        if(free1[1]==0){free1[1]=j;}
6886        else{free1[size(free1)+1]=j;}
6887      }
6888      free[i]=free1;
6889    }
6890  }
6891  list amplcombp; list aux;
6892  for(i=1;i<=size(combp0);i++)
6893  {
6894    v=combp0[i];
6895    kill amplcombp; list amplcombp;
6896    amplcombp[1]=intvec(v[1]);
6897    for(j=2;j<=size(v);j++)
6898    {
6899      if(v[j]!=0)
6900      {
6901        for(k=1;k<=size(amplcombp);k++)
6902        {
6903          w=amplcombp[k];
6904          w[size(w)+1]=v[j];
6905          amplcombp[k]=w;
6906        }
6907      }
6908      else
6909      {
6910        kill aux; list aux;
6911        for(k=1;k<=size(amplcombp);k++)
6912        {
6913          for(l=1;l<=size(free[j]);l++)
6914          {
6915            w=amplcombp[k];
6916            w[size(w)+1]=free[j][l];
6917            aux[size(aux)+1]=w;
6918          }
6919        }
6920        amplcombp=aux;
6921      }
6922    }
6923    for(j=1;j<=size(amplcombp);j++)
6924    {
6925      combp1[size(combp1)+1]=amplcombp[j];
6926    }
6927  }
6928  return(combp1);
6929}
6930
6931static proc nonnullCrep(poly f0,ideal ida0,ideal idb0)
6932{
6933  int i;
6934  def RR=basering;
6935  setring(@P);
6936  def f=imap(RR,f0);
6937  def ida=imap(RR,ida0);
6938  def idb=imap(RR,idb0);
6939  def idaf=ida+f;
6940  int te=1;
6941  for(i=1;i<=size(idb);i++)
6942  {
6943    if(radicalmember(idb[i],idaf)==0)
6944    {
6945      te=0; break;
6946    }
6947  }
6948  setring(RR);
6949  return(te);
6950}
6951
6952// input:  L: list of ideals (works in @P)
6953// output: F0: ideal of polys. F0[i] is a poly in the intersection of
6954//             all ideals in L except in the ith one, where it is not.
6955//             L=(p1,..,ps);  F0=(f1,..,fs);
6956//             F0[i] \in intersect_{j#i} p_i
6957static proc precombint(list L)
6958{
6959  int i; int j; int tes;
6960  def RR=basering;
6961  setring(@P);
6962  list L0; list L1; list L2; list L3; ideal F;
6963  L0=imap(RR,L);
6964  L1[1]=L0[1]; L2[1]=L0[size(L0)];
6965  for (i=2;i<=size(L0)-1;i++)
6966  {
6967    L1[i]=intersect(L1[i-1],L0[i]);
6968    L2[i]=intersect(L2[i-1],L0[size(L0)-i+1]);
6969  }
6970  L3[1]=L2[size(L2)];
6971  for (i=2;i<=size(L0)-1;i++)
6972  {
6973    L3[i]=intersect(L1[i-1],L2[size(L0)-i]);
6974  }
6975  L3[size(L0)]=L1[size(L1)];
6976  for (i=1;i<=size(L3);i++)
6977  {
6978    option(redSB); L3[i]=std(L3[i]);
6979  }
6980  for (i=1;i<=size(L3);i++)
6981  {
6982    tes=1; j=0;
6983    while((tes==1) and (j<size(L3[i])))
6984    {
6985      j++;
6986      option(redSB);
6987      L0[i]=std(L0[i]);
6988      if(reduce(L3[i][j],L0[i])!=0){tes=0; F[i]=L3[i][j];}
6989    }
6990    if (tes==1){"ERROR a polynomial in all p_j except p_i was not found";}
6991  }
6992  setring(RR);
6993  def F0=imap(@P,F);
6994  return(F0);
6995}
6996
6997// precombinediscussion
6998// not used, can be deleted
6999// input:  list L: the LCU segment with bases for each pi component
7000// output: intvec vv:  vv[1]=(1 if the generic polynomial of the vv[2]
7001//                     component already specializes well,
7002//                     0 if combine is to be used)
7003//                     vv[2]=selind, the index for which the generic basis
7004//                     already specializes well if combine is not to be used (vv[1]=1).
7005static proc precombinediscussion(L,crep)
7006{
7007  int tes=1; int selind; int i1; int j1; poly p; poly lcp; intvec vv;
7008  if (size(L)==1){vv=1,1; return(vv);}
7009  for (i1=1;i1<=size(L);i1++)
7010  {
7011    tes=1;
7012    p=L[i1][2];
7013    lcp=leadcoef(p);
7014
7015
7016    if(nonnullCrep(lcp,crep[1],crep[2])==1)
7017    {
7018      for(j1=1;j1<=size(L);j1++)
7019      {
7020        if(i1!=j1)
7021        {
7022          if(specswellCrep(p,L[j1][2],L[j1][1])==0){tes=0; break;}
7023        }
7024      }
7025    }
7026    else{tes=0;}
7027    if(tes==1){selind=i1; break;}
7028  }
7029  vv=tes,selind;
7030  return(vv);
7031}
7032
7033// only if N=0 and W=1
7034proc gencase1(ideal F, list #)
7035"USAGE:   gencase1(F); This routine determines the generic segment when
7036          the generic case has basis 1, and returns the empty list if not.
7037          It is useful, for example in automatic discovery of geometric
7038          theorems, to determine the prime varieties over which solutions exist.
7039          It can work, even if the complete grobcov does not finish.
7040          It serves to obtain a partial result that can be sometimes very useful.
7041          It is also used internally in the canonical computation grobcov,
7042          but can be called by the user. Only the basering Q[a][x] needs
7043          to be defined and the ideal given in this ring.
7044          Options: It allows an option list("compbas",0-1),
7045          If the routine is called with option
7046          ("compbas",0), then the given ideal must be the reduced
7047          Groebner basis of the ideal in the ring Q[x,a].
7048          If the routine is called by the user this option not to be used,
7049          and the algorithm will compute internally the reduced Groebner
7050          basis of the ideal in the ring Q[x,a].
7051RETURN:   The list of the generic case, when its basis is 1, or
7052          the empty list if not.
7053          The output is of the form
7054          (lpp=1,basis=1,(null ideal=0,(p1,..ps)),N)
7055          where (0,(p1,..,ps)) is the P-representation of the generic segment
7056          (the pi's are the prime components) and N is its intersection
7057NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
7058          x=variables, and should be defined previously. The ideal must
7059          be defined on R.
7060KEYWORDS: generic segment, automatic discovery of geometric theorems,
7061EXAMPLE:  gencase1; shows an example"
7062{
7063  int compbas=1; list L=#;
7064     // compbas==1 the gbasis wrt vars+param must be computed now
7065     // compbas==0 the gbasis wrt vars+param is already computed
7066  def RR=basering; list empty; int i;
7067  setglobalrings();
7068  for(i=1;i<=size(L) div 2;i++)
7069  {
7070    if(L[2*i-1]=="compbas"){compbas=L[2*i];}
7071  }
7072  if (compbas==1)
7073  {
7074    setring(@RP);
7075    def FP=imap(R,F);
7076    option(redSB);
7077    def G=std(FP);
7078    setring(RR);
7079    def F1=imap(@RP,G);
7080  }
7081  else {def F1=F;}
7082  ideal Zero;
7083  for(i=1;i<=size(F1);i++)
7084  {
7085    if (leadmonom(F1[i])==1)
7086    {
7087      Zero[size(Zero)+1]=F1[i];
7088    }
7089  }
7090  if (size(Zero)>0)
7091  {
7092    setring(@P);
7093    def ZeroP=imap(RR,Zero);
7094    //def N=radical(ZeroP);
7095    def holes=minGTZ(ZeroP);
7096    for(i=1;i<=size(holes);i++)
7097    {
7098      option(redSB);
7099      holes[i]=std(holes[i]);
7100    }
7101    def N=holes[1];
7102    for(i=2;i<=size(holes);i++)
7103    {
7104      N=intersect(N,holes[i]);
7105    }
7106    option(redSB);
7107    N=std(N);
7108    setring(RR);
7109    def hole=imap(@P,holes);
7110    def Nn=imap(@P,N);
7111    kill @P; kill @RP; kill @R;
7112    return(ideal(1),ideal(1),list(ideal(0),hole),Nn);
7113  }
7114  else
7115  {
7116    kill @P; kill @RP; kill @R;
7117    setring(RR);
7118    return(empty);
7119  }
7120}
7121example
7122{ "EXAMPLE:"; echo = 2;
7123  "Generic segment for the extended Steiner-Lehmus theorem";
7124  ring R=(0,x,y),(a,b,m,n,p,r),lp;
7125  ideal S=p^2-(x^2+y^2),
7126          -a*(y)+b*(x+p),
7127          -a*y+b*(x-1)+y,
7128          (r-1)^2-((x-1)^2+y^2),
7129          -m*(y)+n*(x+r-2) +y,
7130          -m*y+n*x,
7131          (a^2+b^2)-((m-1)^2+n^2);
7132  short=0;
7133  gencase1(S);
7134}
7135
7136// minAssGTZ eliminating denominators
7137static proc minGTZ(ideal N);
7138{
7139  int i; int j;
7140  def L=minAssGTZ(N);
7141  for(i=1;i<=size(L);i++)
7142  {
7143    for(j=1;j<=size(L[i]);j++)
7144    {
7145      L[i][j]=cleardenom(L[i][j]);
7146    }
7147  }
7148  return(L);
7149}
7150
7151proc multigrobcov(ideal F, list #)
7152"USAGE:   multigrobcov(F); This routine is to be used instead of grobcov
7153          when grobcov does not finish, and the generic case is expected
7154          to have basis 1. It can be useful for automating discovery of
7155          geometric theorems.
7156          The ideal F must be defined on a parametric ring Q[a][x].
7157          If the generic basis is not 1, then it returns the empty list,
7158          but if the generic basis is one then it computes the
7159          grobcov over each irreducible component of the complement of
7160          the generic segment and returns the generic segment and the
7161          different grobcov on each segment. From the result, the global
7162          grobcov can be deduced eliminating convenablement the inter-
7163          sections of the different grobcov computed over the components.
7164          Options: A list of options of the form
7165          ("comment",0-1,"can",0-1 can,"cgs",0-1,"ext",0-1), can be given.
7166          One can give none till 4 of these options by giving the
7167          name of the option and the value. Options "null" and "nonnull" are
7168          avoided.
7169          When option ("comment",1) is set, the routine provides information
7170          about the development of the computation. The default option
7171          is ("comment",0).
7172          When option ("can",0) is given, then the computation is
7173          done homogenizing the given basis but not computing the
7174          whole homogenized ideal. Thus in this case the result is not
7175          completely canonical but it is also useful. This option
7176          facilitates the computation. The default option is ("can",1).
7177          When option ("cgs",0) is set, then instead of using cgsdr
7178          for computing the initial reduced disjoint CGS, then
7179          cgsdrold is used. This can be tested when ("cgs",1) (the default
7180          option) fails. When option ("ext",0) is set, only the generic
7181          representation of the bases are computed instead of the
7182          full representation (the default option is ("ext",1)).
7183RETURN:   The list whose first element is the generic case, and the
7184          remaining elements are the grobcov over the different irreducible
7185          components in the complementary of the generic segment.
7186          the empty list if the generic case does not have basis 1.
7187NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
7188          x=variables, and should be defined previously. The ideal must
7189          be defined on R.
7190KEYWORDS: grobcov, generic segment, automatic discovery of geometric theorems,
7191EXAMPLE:  multigrobcov; shows an example."
7192{
7193  int i; int comment=1; list L=#; ideal N; list gc; list GC; list GCA;
7194  int start=timer; int ni; int nw;
7195  for(i=1;i<=size(L) div 2;i++)
7196  {
7197    if (L[2*i-1]=="comment"){comment=L[2*i];}
7198    else
7199    {
7200      if(L[2*i-1]=="null"){"multigrobcov does not allow null restriction"; ni=i;}
7201      else
7202      {
7203        if(L[2*i-1]=="nonnull"){"multigrobcov does not allow nonnull restriction"; nw=i;}
7204      }
7205    }
7206  }
7207  if (ni>0)
7208  {
7209    L=delete(L,2*ni-1); L=delete(L,2*ni-1);
7210    if(nw>0)
7211    {
7212      if(nw<ni)
7213      {
7214        L=delete(L,2*nw-1); L=delete(L,2*nw-1);
7215      }
7216      else
7217      {
7218        L=delete(L,2*nw-3); L=delete(L,2*nw-3);
7219      }
7220    }
7221  }
7222  else
7223  {
7224    if (nw>0){L=delete(L,2*nw-1);L=delete(L,2*nw-1);}
7225  }
7226  gc=gencase1(F);
7227  if(size(gc)==0)
7228  {
7229    string("The generic case is not 1, thus multigrobcov is not useful");
7230    return(gc);
7231  }
7232  else
7233  {
7234    if(comment==1){"Generic case ="; gc; " ";}
7235    def SS2=gc[3][2];
7236    GCA=list(list(list(gc[1],gc[2],list(gc[3]))));
7237    if(comment==1){"Components to study="; SS2;}
7238    for (i=1;i<=size(SS2);i++)
7239    {
7240      N=SS2[i];
7241      if(comment==1){" "; "Begin grobcov on the variety N ="; N;}
7242      L[size(L)+1]="null"; L[size(L)+1]=N;
7243      //"T_L=";L;
7244      GC=grobcov(F,L);
7245      GCA[size(GCA)+1]=GC;
7246    }
7247    if(comment==1){string("Time for multigrobcov = ",timer-start);}
7248    return(GCA);
7249  }
7250}
7251example
7252{
7253  "Generalization of the Steiner-Lehmus theorem";
7254  ring R=(0,x,y),(a,b,m,n,p,r),lp;
7255  ideal S=p^2-(x^2+y^2),
7256          -a*(y)+b*(x+p),
7257          -a*y+b*(x-1)+y,
7258          (r-1)^2-((x-1)^2+y^2),
7259          -m*(y)+n*(x+r-2) +y,
7260          -m*y+n*x,
7261          (a^2+b^2)-((m-1)^2+n^2);
7262  short=0;
7263  multigrobcov(S,list("can",0,"cgs",0,"comment",1));
7264}
7265
7266proc cgsdrold(ideal F, list #)
7267"USAGE:   cgsdrold(F); To compute a disjoint, reduced CGS.
7268          From the old library redcgs.lib.
7269          cgsdrold is the starting point of the fundamental routine
7270          grobcovold of the library redcgs.lib.
7271          Use instead cgsdr. cgsdrold is only recommended for comparison
7272          with cgsdr or for didactic purposes to plot the tree (buildtree)
7273          using the routine buildtreetoMaple.
7274          F: ideal in Q[a][x] (parameters and variables) to be discussed.
7275
7276          Options: To modify the default options, pairs of arguments
7277          -option name, value- of valid options must be added to the call.
7278
7279          Options:
7280            "null",ideal N: The default is "null",ideal(0).
7281            "nonnull",ideal W: The default "nonnull",ideal(1).
7282                When options "null" and/or "nonnull" are given, then
7283                the parameter space is restricted to V(N) \ V(h), where
7284                h is the product of the polynomials w in W.
7285            "old",0-1: The default option is "old",1 that gives an output
7286                analogous to the one obtained by cgsdr. Setting "old",0
7287                provides an output representing a tree (buildtree), that
7288                can be plotted using the routine buildtreetoMaple.
7289            "comment",0-1: The default is "comment",0. Setting "comments",1
7290                will provide information about the development of the
7291                computation.
7292          One can give none till 4 of these options.
7293RETURN:   With the default option "old",1, it returns a list T describing
7294          a reduced and disjoint comprehensive Groebner system (CGS),
7295          whose segments correspond to constant leading power products (lpp)
7296          of the reduced Groebner basis. The returned list is of the form:
7297          (
7298            (lpp, (basis,segment),...,(basis,segment)),
7299            ..,,
7300            (lpp, (basis,segment),...,(basis,segment))
7301          )
7302          The bases are the reduced Groebner bases (after normalization)
7303          for each point of the corresponding segment.
7304          Each segment is given by a reduced representation (Ni,Wi), with
7305          Ni radical and V(Ni)=Zariski closure of the segment Si=V(Ni)\V(hi),
7306          where hi is the product of the polynomials w in Wi.
7307          Setting option "old",0 the output represents the tree and
7308          can then be transformed to a plot structure using the routine
7309          buildtreetoMaple.
7310          Its structure in this case is:
7311          The first element of the list is the root, and contains
7312            [1] label: intvec(-1)
7313            [2] number of children : int
7314            [3] the ideal F
7315            [4], [5], [6] the red-representation of the segment
7316                (null, non-null conditions, prime components of the null
7317                conditions) given (as option).
7318                ideal (0), ideal (1), list(ideal(0)) is assumed if
7319                no optional conditions are given.
7320            [7] the set of lpp of ideal F
7321            [8] condition that was taken to reach the vertex
7322                (poly 1, for the root).
7323          The remaining elements of the list represent vertices of the tree:
7324          with the same structure:
7325            [1] label: intvec (1,0,0,1,...) gives its position in the tree:
7326                first branch condition is taken non-null, second null,...
7327            [2] number of children (0 if it is a terminal vertex)
7328            [3] the specialized ideal with the previous assumed conditions
7329                to reach the vertex
7330            [4],[5],[6] the red-representation of the segment corresponding
7331                to the previous assumed conditions to reach the vertex
7332            [7] the set of lpp of the specialized ideal at this stage
7333            [8] condition that was taken to reach the vertex from the
7334                father's vertex (that was taken non-null if the last
7335                integer in the label is 1, and null if it is 0)
7336          The terminal vertices form a disjoint partition of the parameter
7337          space whose bases specialize to the reduced Groebner basis of the
7338          specialized ideal on each point of the segment and preserve
7339          the lpp. They form a disjoint reduced CGS, and is the only
7340          vertices grouped and ordered by lpp that is returned with the
7341          default option "old",1.
7342
7343NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
7344          x=variables, and should be defined previously, and the ideal
7345          defined on R.
7346KEYWORDS: CGS, cgsdr, buildtree, buildtreetoMaple, disjoint, reduced,
7347          comprehensive Groebner system
7348EXAMPLE:  cgsdrold; shows an example"
7349{
7350  int i; list L=#; int oldop=1;
7351  for(i=1;i<=size(L) div 2;i++)
7352  {
7353    if(L[2*i-1]=="old"){oldop=L[2*i];}
7354  }
7355  def bt=buildtree(F, #);
7356  if (oldop==0){return(bt);}
7357  else
7358  {
7359    setglobalrings();
7360    def gs=groupsegments(finalcases(bt));
7361    int j;
7362    for (i=1;i<=size(gs);i++)
7363    {
7364      for (j=1;j<=size(gs[i][2]);j++)
7365      {
7366        gs[i][2][j]=delete(gs[i][2][j],1);
7367        gs[i][2][j]=delete(gs[i][2][j],4);
7368        if(equalideals(gs[i][2][j][3],ideal(0))){gs[i][2][j][3]=ideal(1);}
7369      }
7370    }
7371    kill @P; kill @R; kill @RP;
7372    return(gs);
7373  }
7374}
7375example
7376{ "EXAMPLE:"; echo = 2;
7377  ring R=(0,a1,a2,a3,a4),(x1,x2,x3,x4),dp;
7378  ideal F=x4-a4+a2,
7379          x1+x2+x3+x4-a1-a3-a4,
7380          x1*x3*x4-a1*a3*a4,
7381          x1*x3+x1*x4+x2*x3+x3*x4-a1*a4-a1*a3-a3*a4;
7382  cgsdrold(F);
7383  cgsdrold(F,"old",0);
7384}
7385
7386proc grobcovold(ideal F,list #)
7387"USAGE:   grobcovold(F); This is the fundamental routine of the
7388          old library redcgs.lib. It is somewhat heuristic and does
7389          not certify the obtention of the canonical Groebner cover of
7390          a parametric ideal, as does grobcov, but usually it does or
7391          provides a warning if not. It allows different options, recalling
7392          all the different approaches of the old library redcgs.lib.
7393          Use grobcov instead. The use of grobcovold is only recommended
7394          to compare results or study alternatives.
7395
7396          The ideal F must be defined on a parametric ring Q[a][x].
7397          Options: To modify the default options, pair of arguments
7398          -option name, value- of valid options must be added to the call.
7399
7400          Options:
7401            "null",ideal N: The default is "null",ideal(0).
7402            "nonnull",ideal W: The default "nonnull",ideal(1).
7403                When options "null" and/or "nonnull" are given, then
7404                the parameter space is restricted to V(N) \ V(h), where
7405                h is the product of the polynomials w in W.
7406            "can",0-2: The default is "can",1. With the default option
7407                the homogenized ideal is computed before obtaining the
7408                Groebner cover, so that the result is the canonical
7409                Groebner cover. Setting "can",0 only homogenizes the basis
7410                so the result is not exactly canonical, but the computation
7411                is more efficient. Setting "can",2 no homogenization of
7412                the ideal is carried out, and the segments with same lpp
7413                are added so much as possible when a common basis is obtained.
7414                The result, in this case is not canonical nor the segments
7415                are always locally closed. Nevertheless it can have
7416                less segments as the canonical result.
7417            "out",0-1: The default is "out",0. With the default option the
7418                output is analogous to that of grobcov. If option "can",2
7419                is also set, then this representation can be somewhat
7420                confusing, because the segments are not always given in
7421                P-representation, as they are not always locally closed.
7422                With option "out",1 a representation in tree form is given
7423                providing a canonical representation of the segments, even if
7424                they are not locally closed. This representation can be transformed
7425                by the routine cantreetoMaple into a file that can be read
7426                in Maple and plotted with the plotcantree Maple routine of
7427                the old dpgb library, showing the tree.
7428            "comment",0-1: The default is "comment",0. Setting "comments",1
7429                will provide information about the development of the
7430                computation.
7431          One can give none till 5 of these options.
7432RETURN:   With the default option ("out",0), the list
7433          (
7434           (lpp_1,basis_1,P-representation_1)
7435           ...
7436           (lpp_s,basis_s,P-represntation_s)
7437          )
7438          With option "out",1, a list T representing a rooted tree.
7439          Each element of the list T has the two first entries with the
7440          following content:
7441           [1]: The label (intvec) representing the position in the rooted
7442                tree:  0 for the root (and this is a special element)
7443                       i for the root of the segment i
7444                       (i,...) for the children of the segment i
7445           [2]: the number of children (int) of the vertex.
7446          There are three kind of vertices:
7447           (1) the root (first element labelled 0),
7448           (2) the vertices labelled with a single integer i,
7449           (3) the rest of vertices labelled with more indices.
7450          Description of the root. Vertex type (1)
7451           There is a special vertex (the first one) whose content is
7452           the following:
7453             [3] lpp of the given ideal
7454             [4] the given ideal
7455             [5] the R-representation  of the (optional) given null and
7456                 non-null conditions.
7457             [6] CRCGS, RCGS, MRCGS depending on the "can" option (1,0,2).
7458           Description of vertices type (2). These are the vertices that
7459           initiate a segment, and are labelled with a single integer.
7460             [3] lpp (ideal) of the reduced basis. If they are repeated lpp's this
7461                 will correspond to a sheaf.
7462             [4] the reduced basis (ideal) of the segment.
7463           Description of vertices type (3). These vertices have as first
7464           label i and descend form vertex i in the position of the label
7465           (i,...). They contain moreover a unique prime ideal in the parameters
7466           and form ascending chains of ideals.
7467          How is to be read the mrcgs tree? The vertices with an even number of
7468          integers in the label are to be considered as additive and those
7469          with an odd number of integers in the label are to be considered as
7470          substraction. As an example consider the following vertices:
7471          v1=((i),2,lpp,B),
7472          v2=((i,1),2,P_(i,1)),
7473          v3=((i,1,1),2,P_(i,1,1)),
7474          v4=((i,1,1,1),1,P_(i,1,1,1)),
7475          v5=((i,1,1,1,1),0,P_(i,1,1,1,1)),
7476          v6=((i,1,1,2),1,P_(i,1,1,2)),
7477          v7=((i,1,1,2,1),0,P_(i,1,1,2,1)),
7478          v8=((i,1,2),0,P_(i,1,2)),
7479          v9=((i,2),1,P_(i,2)),
7480          v10=((i,2,1),0,P_(i,2,1)),
7481          They represent the segment:
7482          (V(i,1)\(((V(i,1,1) \ ((V(i,1,1,1) \ V(i,1,1,1,1)) u (V(i,1,1,2) \ V(i,1,1,2,1)))))
7483          u V(i,1,2))) u (V(i,2) \ V(i,2,1))
7484          and can also be represented by
7485          (V(i,1) \ (V(i,1,1) u V(i,1,2))) u
7486          (V(i,1,1,1) \ V(i,1,1,1)) u
7487          (V(i,1,1,2) \ V(i,1,1,2,1)) u
7488          (V(i,2) \ V(i,2,1))
7489          where V(i,j,..) = V(P_(i,j,..))
7490
7491          The lpp are constant over a segment and correspond to the
7492          set of lpp of the reduced Groebner basis for each point
7493          of the segment.
7494
7495          Basis: to each element of lpp corresponds an I-regular function given          Groebner basis, and it is given in full representation (by
7496          in full representation. The regular function is
7497          the corresponding element of the reduced Groebner basis for
7498          each point of the segment with the given lpp.
7499          For each point in the segment, the polynomial or the set of
7500          polynomials representing it, if they do not specialize to 0,
7501          then after normalization, specialize to the corresponding
7502          element of the reduced Groebner basis.
7503
7504          The P-representation of a segment is of the form
7505          ((p_1,(p_11,..,p_1k1)),..,(p_r,(p_r1,..,p_rkr))
7506          representing the segment U_i (V(p_i) \ U_j (V(p_ij))), where the
7507          p's are prime ideals.
7508
7509NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
7510          x=variables, and should be defined previously. The ideal must
7511          be defined on R.
7512KEYWORDS: Groebner cover, grobcov, parametric ideal, canonical, discussion of
7513          parametric ideal.
7514EXAMPLE:  grobcovold; shows an example"
7515{
7516  int i;
7517  list LL=#;
7518  list T; list NT; list NTe;
7519  // default options
7520  int comment=0; int canop=1; int outop=0;
7521  int start=timer;
7522  ideal W=ideal(1);
7523  ideal N=ideal(0);
7524  canop=1; // canop=0 for homogenizing the basis but not the ideal (not canonical)
7525           //         (old rcgs)
7526           // canop=1 for homogenizing the ideal
7527           //         (old crcgs)
7528           // canop=2 for not homogenizing and try to minimize the segments
7529           //         (old mrcgs)
7530  outop=0; // outop=0 for an output analogous to grobcov (if canop<>2)
7531           // outop=1 for an output as in the old library redcgs.lib
7532           //         in form of tree that can be transformed into Maple.
7533  for(i=1;i<=size(LL) div 2;i++)
7534  {
7535    if(LL[2*i-1]=="can"){canop=LL[2*i];}
7536    else
7537    {
7538      if(LL[2*i-1]=="out"){outop=LL[2*i];}
7539      else
7540      {
7541        if (LL[2*i-1]=="comment"){comment=LL[2*i];}
7542      }
7543    }
7544  }
7545  if (comment>=1){string("can = ",canop," out = ", outop," comment = ",comment);}
7546  if (canop==0){T=rcgs(F,LL);}
7547  else
7548  {
7549    if (canop==1){T=crcgs(F,LL);}
7550    else
7551    {
7552      if (canop==2){T=mrcgs(F,LL);}
7553    }
7554  }
7555  if (comment>=1){string("Time in grobcovold = ",timer-start," sec");}
7556  if (outop==0)
7557  {
7558    // transforming the output to the modern form
7559    i=2; list Cap; int indCap; list Cua; ideal idp; list idq;
7560    int tes;
7561    while(i<=size(T))
7562    {
7563      kill Cap; list Cap;
7564      if(size(T[i][1])==1)
7565      {
7566        Cap=list(T[i][3],T[i][4]);
7567        indCap=T[i][1][1];
7568        i++;
7569      }
7570      kill Cua; list Cua;
7571      while(T[i][1][1]==indCap)
7572      {
7573        if(size(T[i][1]) mod 2 ==0)
7574        {
7575          if(size(idq)!=0){Cua[size(Cua)+1]=list(idp,idq);}
7576          kill idq; list idq;
7577          idp=T[i][3];
7578        }
7579        else
7580        {
7581          idq[size(idq)+1]=T[i][3];
7582        }
7583        i++;
7584        if(i>size(T)){break;}
7585      }
7586      Cua[size(Cua)+1]=list(idp,idq);
7587      Cap[3]=Cua;
7588      NT[size(NT)+1]=Cap;
7589      kill idp; ideal idp; kill idq; list idq;
7590    }
7591    if (comment==2){"rcgs="; T;}
7592    return(NT);
7593  }
7594  else
7595  {
7596    return(T);
7597  }
7598}
7599example
7600{
7601  "EXAMPLE:"; echo = 2;
7602  "Simple robot: A. Montes,";
7603  "New algorithm for discussing Groebner bases with parameters,";
7604  "JSC, 33: 183-208 (2002).";
7605  ring R=(0,r,z,l),(s1,c1,s2,c2), dp;
7606  ideal S10=c1^2+s1^2-1,
7607            c2^2+s2^2-1,
7608            r-c1-l*c1*c2+l*s1*s2,
7609            z-s1-l*c1*s2-l*s1*c2;
7610  grobcovold(S10,"comment",1);
7611  grobcovold(S10,"can",2,"comment",1);
7612}
Note: See TracBrowser for help on using the repository browser.