Changeset 1e1ec4 in git for Singular/LIB/grobcov.lib


Ignore:
Timestamp:
Jan 4, 2013, 5:54:18 PM (11 years ago)
Author:
Oleksandr Motsak <motsak@…>
Branches:
(u'spielwiese', 'fe61d9c35bf7c61f2b6cbf1b56e25e2f08d536cc')
Children:
42ea852aa2e1e683808b1ac3305dda96677af761
Parents:
8f296a6216092a84f1ebb509dbcda5fe428004f7
git-author:
Oleksandr Motsak <motsak@mathematik.uni-kl.de>2013-01-04 17:54:18+01:00
git-committer:
Oleksandr Motsak <motsak@mathematik.uni-kl.de>2013-01-15 20:41:56+01:00
Message:
Updated LIBs according to master

add: new LIBs from master
fix: updated LIBs due to minpoly/(de)numerator changes
fix: -> $Id$
fix: Fixing wrong rebase of SW on master (LIBs)
File:
1 edited

Legend:

Unmodified
Added
Removed

  • Singular/LIB/grobcov.lib

    r8f296a r1e1ec4  
    44info="
    55LIBRARY:  grobcov.lib   Groebner Cover for parametric ideals.
    6 PURPOSE:  Comprehensive Groebner Systems, Groebner Cover, Canonical Forms.
    7           The library contains Montes's algorithms to compute the
     6PURPOSE:  Comprehensive Groebner Systems, Groebner Cover, Canonical Forms,
     7          Parametric Polynomial Systems.
     8          The library contains Montes-Wibmer's algorithms to compute the
    89          canonical Groebner cover of a parametric ideal as described in
    910          the paper:
    1011
    1112          Montes A., Wibmer M.,
    12           Groebner Bases for Polynomial Systems with parameters.
     13          \"Groebner Bases for Polynomial Systems with parameters\".
    1314          Journal of Symbolic Computation 45 (2010) 1391-1425.
    1415
    1516          The central routine is grobcov. Given a parametric
    16           ideal, grobcov outputs its canonical Groebner cover, consisting
     17          ideal, grobcov outputs its Canonical Groebner Cover, consisting
    1718          of a set of pairs of (basis, segment). The basis (after
    1819          normalization) is the reduced Groebner basis for each point
    … …  
    2324          whole parameter space. The output is canonical, it only
    2425          depends on the given parametric ideal and the monomial order.
    25           This is much more than a simple comprehensive Groebner system.
     26          This is much more than a simple Comprehensive Groebner System.
    2627          The algorithm grobcov allows options to solve partially the
    2728          problem when the whole automatic algorithm does not finish
    … …  
    2930
    3031          grobcov uses a first algorithm cgsdr that outputs a disjoint
    31           reduced comprehensive Groebner system with constant lpp.
     32          reduced Comprehensive Groebner System with constant lpp.
     33          For this purpose, in this library, the implemented algorithm is
     34          Kapur-Sun-Wang algorithm, because it is the most efficient
     35          algorithm known for this purpose.
     36
     37          D. Kapur, Y. Sun, and D.K. Wang.
     38          \"A New Algorithm for Computing Comprehensive Groebner Systems\".
     39          Proceedings of ISSAC'2010, ACM Press, (2010), 29-36.
     40
    3241          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.
     42          Comprehensive Groebner System (CGS) is required.
    4943
    5044AUTHORS:  Antonio Montes , Hans Schoenemann.
    … …  
    5751@*         basering Q[a][x]; (a=parameters, x=variables)
    5852@*         After defining the ring, the main routines
    59 @*         grobcov, cgsdr, gencase1, multigrobcov
     53@*         grobcov, cgsdr,
    6054@*         generate the global rings
    6155@*         @R   (Q[a][x]),
    … …  
    6660@*         create before the above rings by calling setglobalrings();
    6761@*         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.
     62@*         The call to the basic routines grobcov, cgsdr will
     63@*         kill these rings.
    7064
    7165PROCEDURES:
    7266
    73 grobcov(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 
    79 cgsdr(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 
    88 gencase1(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 
    94 multigrobcov(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 
    106 setglobalrings();    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 
    119 pdivi(f,F);          Performs a pseudodivision of a parametric polynomial
    120                      by a parametric ideal.
    121 
    122 pnormalform(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 
    126 Also included from the old library redcgs.lib the following routines
    127 
    128 cgsdrold(F);         Similar to cgsdr using the algorithm buildtree
    129                      of the old library.
    130 grobcovold(F);       Similar to grobcov with the algorithms of the old
    131                      library.
    132 buildtreetoMaple(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.
    136 cantreetoMaple(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.
     67grobcov(F);        Is the basic routine giving the canonical
     68                   Groebner cover of the parametric ideal F.
     69                   This routine accepts many options, that
     70                   allow to obtain results even when the canonical
     71                   computation does not finish in reasonable time.
     72
     73cgsdr(F);          Is the procedure for obtaining a first disjoint,
     74                   reduced Comprehensive Groebner System that
     75                   is used in grobcov, but that can be used
     76                   independently if only the CGS is required.
     77                   It is a more efficient routine than buildtree
     78                   (the own routine that is no more used). It uses
     79                   now KSW algorithm.
     80
     81setglobalrings();  Generates the global rings @R, @P and @PR that are
     82                   respectively the rings Q[a][x], Q[a], Q[x,a].
     83                   It is called inside each of the fundamental routines
     84                   of the library: grobcov, cgsdr and killed before
     85                   the output.
     86                   If the user want to use some other internal routine,
     87                   then setglobalrings() is to be called before, as
     88                   the rings @R, @P and @RP are needed in most of them.
     89                   globally, and more internal routines can be used, but
     90                   these rings are killed by the call to any of the
     91                   basic routines.
     92
     93pdivi(f,F);     Performs a pseudodivision of a parametric polynomial
     94                   by a parametric ideal.
     95
     96pnormalf(f,E,N);   Reduces a parametric polynomial f over V(E) \ V(N)
     97                   E is the null ideal and N the non-null ideal
     98                   over the parameters.
     99
     100extend(GC); When the grobcov of an ideal has been computed
     101                   with the default option ('ext',0) and the explicit
     102                   option ('rep',2) (which is not the default), then
     103                   one can call extend (GC) (and options) to obtain the
     104                   full representation of the bases. With the default
     105                   option ('ext',0) only the generic representation of
     106                   the bases are computed, and one can obtain the full
     107                   representation using extend.
     108
     109locus2d:      Special routine for determining the locus of points
     110                   of a two dimensional object. Given an ideal J with
     111                   two parameters (a,b) and so many variables as
     112                   needed, representing the system determining
     113                   the locus of points (a,b) who verify certain
     114                   geometrical properties, computing the grobcov of
     115                   J and applying to it locus2d, determines the locus.
     116
     117locus2dto:   Transforms the output of locus2d to a string that
     118                   can be reed from different computational systems.
    140119
    141120SEE ALSO: compregb_lib
    … …  
    149128// Library grobcov.lib
    150129// (Groebner cover):
     130// Release 1: (public)
     131// Initial data: 21-1-2008
     132// Final data: 3-7-2008
     133// Release 2: (private)
    151134// 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
     135// Final data: 25-10-2011
     136// Release 3: (this release, public)
     137// Initial data: 1-7-2012
     138// Final data: 4-9-2012
    159139// basering Q[a][x];
    160140
    … …  
    167147          defined as global variables.
    168148NOTE:     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.
     149          library grobcov, cgsdr, extend, pdivi, pnormalf, locus2d, locus2dto,
     150          and killed before the output.
    171151          The user does not need to call it, except when it is interested
    172152          in using some internal routine of the library that
    … …  
    177157EXAMPLE:  setglobalrings; shows an example"
    178158{
    179   if (defined(@P)==1)
     159  if (defined(@P))
    180160  {
    181161    kill @P; kill @R; kill @RP;
    … …  
    197177  exportto(Top,@RP);     // global ring K[x,a] with product order
    198178  setring(RR);
    199 }
     179};
    200180example
    201181{ "EXAMPLE:"; echo = 2;
    … …  
    205185  @P;
    206186  @RP;
     187ringlist(R);
     188ringlist(@P);
     189ringlist(@RP);
    207190}
    208191
    … …  
    216199//    ideal Jc (the new form of ideal J without denominators and
    217200//       normalized to content 1)
    218 static proc cld(ideal J)
     201proc cld(ideal J)
    219202{
    220203  if (size(J)==0){return(ideal(0));}
    … …  
    223206  def Ja=imap(RR,J);
    224207  ideal Jb;
    225   if (size(Ja)==0){return(ideal(0));}
     208  if (size(Ja)==0){setring(RR); return(ideal(0));}
    226209  int i;
    227210  def j=0;
    … …  
    230213  def Jc=imap(@RP,Jb);
    231214  return(Jc);
    232 }
    233 
    234 static proc memberpos(f,J)
     215};
     216
     217proc memberpos(f,J)
    235218//"USAGE:  memberpos(f,J);
    236219//         (f,J) expected (polynomial,ideal)
    … …  
    354337//  list L=(7,4,5,1,1,4,9);
    355338//  memberpos(1,L);
    356 //  >
    357339//}
    358340
    359 
    360 static proc subset(J,K)
     341proc subset(J,K)
    361342//"USAGE:   subset(J,K);
    362343//          (J,K)  expected (ideal,ideal)
    … …  
    385366
    386367// elimintfromideal: elimine the constant numbers from an ideal
    387 //     (designed for W, nonnull conditions)
     368//        (designed for W, nonnull conditions)
    388369// input: ideal J
    389 // output:ideal K with the elements of J that are non constants, in the ring @P
    390 static proc elimintfromideal(ideal J)
     370// output:ideal K with the elements of J that are non constants, in the
     371//        ring @P
     372proc elimintfromideal(ideal J)
    391373{
    392374  int i;
    … …  
    401383// input: two coeficients (or terms), that are considered as a quotient
    402384// output: the two coeficients reduced without common factors
    403 static proc simpqcoeffs(poly n,poly m)
     385proc simpqcoeffs(poly n,poly m)
    404386{
    405387  def nc=content(n);
    … …  
    410392}
    411393
    412 // pdivi : pseudodivision of a poly f by an ideal F in a parametric ideal
    413 //         Q[a][x]
     394// pdivi : pseudodivision of a poly f by a parametric ideal F in Q[a][x].
    414395// input:
    415 //   poly f0 (in the parametric ring @R)
    416 //   ideal F0 (in the parametric ring @R)
     396//   poly  f (in the parametric ring @R)
     397//   ideal F (in the parametric ring @R)
    417398// output:
    418399//   list (poly r, ideal q, poly mu)
    … …  
    423404RETURN:   A list (poly r, ideal q, poly m). r is the remainder of the
    424405          pseudodivision, q is the set of quotients, and m is the
    425           factor by which f is to be multiplied.
     406          coefficient factor by which f is to be multiplied.
    426407NOTE:     pseudodivision of a poly f by an ideal F in @R. Returns a
    427408          list (r,q,m) such that m*f=r+sum(q.G), and no lpp of a divisor
    … …  
    430411EXAMPLE:  pdivi; shows an example"
    431412{
     413  int te=0;
     414  if (defined(@P)==1){te=1;}
     415  else{setglobalrings();}
     416  def R=basering;
    432417  int i;
    433418  int j;
    … …  
    436421  def p=f;
    437422  ideal q;
    438   for (i=1; i<=size(F); i++){q[i]=0;}
     423  for (i=1; i<=size(F); i++){q[i]=0;};
    439424  ideal lpf;
    440425  ideal lcf;
    … …  
    478463  }
    479464  list res=r,q,mu;
     465  if(te==0){kill @P; kill @R; kill @RP;}
    480466  return(res);
    481467}
    … …  
    497483// @R
    498484// input:
    499 //   poly f  (given in the ring @R)
     485//   poly f (given in the ring @R)
    500486//   poly g (given in the ring @R)
    501487// output:
    502488//   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)
    504 static proc pspol(poly f,poly g)
     489//                if red then S reduces by Buchberger 1st criterion
     490//                (not used)
     491proc pspol(poly f,poly g)
    505492{
    506493  def lcf=leadcoef(f);
    … …  
    523510//         Operates in the ring @P, but can be called from ring @R,
    524511//         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
     512// input:  ideal J
     513// output: ideal Jc: Returns all the free-square factors of the elements
    527514//         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.
    531 static proc facvar(ideal J)
     515//         even 0 is ignored. It can be called from ideal @R.
     516proc facvar(ideal J)
    532517//"USAGE:   facvar(J);
    533518//          J: an ideal in the parameters
    … …  
    546531  setring(@P);
    547532  def Ja=imap(RR,J);
    548   if(size(Ja)==0){return(ideal(0));}
     533  if(size(Ja)==0){setring(RR); return(ideal(0));}
    549534  Ja=elimintfromideal(Ja); // also in ideal @P
    550535  ideal Jb;
    … …  
    569554//}
    570555
    571 // Wred: eliminate the factors in the polynom f that are in W
    572 //       in ring @RP
     556// Ered: eliminates the factors in the polynom f that are non-null.
     557//       In ring @R
    573558// input:
    574559//   poly f:
    575 //   ideal W  of non-null conditions (already supposed that it is facvar)
     560//   ideal E  of null-conditions
     561//   ideal N  of non-null conditions
     562//        (E,N) represents V(E)\V(N),
     563//        Ered eliminates the non-null factors of f in V(E)\V(N)
    576564// output:
    577 //   poly f2  where the non-null conditions in W have been dropped from f
    578 static proc Wred(poly f, ideal W)
    579 {
    580   if (f==0){return(f);}
     565//   poly f2  where the non-null conditions have been dropped from f
     566proc Ered(poly f,ideal E, ideal N)
     567{
    581568  def RR=basering;
    582   setring(@RP);
    583   def ff=imap(RR,f);
    584   def RPW=imap(RR,W);
    585   def l=factorize(ff,2);
     569  setring(@R);
     570  poly ff=imap(RR,f);
     571  ideal EE=imap(RR,E);
     572  ideal NN=imap(RR,N);
     573  if((ff==0) or (equalideals(NN,ideal(1)))){setring(RR); return(f);}
     574  def v=variables(ff);
    586575  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();
     576  poly X=1;
     577  for(i=1;i<=size(v);i++){X=X*v[i];}
     578  matrix M=coef(ff,X);
     579  setring(@P);
     580  def RPE=imap(@R,EE);
     581  def RPN=imap(@R,NN);
     582  matrix Mp=imap(@R,M);
     583  poly g=Mp[2,1];
     584  if (size(Mp)!=2)
     585  {
     586    for(i=2;i<=size(Mp) div 2;i++)
     587    {
     588      g=gcd(g,Mp[2,i]);
     589    }
     590  }
     591  if (g==1){setring(RR); return(f);}
     592  else
     593  {
     594    def wg=factorize(g,2);
     595    if (wg[1][1]==1){setring(RR); return(f);}
     596    else
     597    {
     598      poly simp=1;
     599      int te;
     600      for(i=1;i<=size(wg[1]);i++)
     601      {
     602        te=inconsistent(RPE+wg[1][i],RPN);
     603        if(te)
     604        {
     605          simp=simp*(wg[1][i])^(wg[2][i]);
     606        }
     607      }
     608    }
     609    if (simp==1){setring(RR); return(f);}
     610    else
     611    {
     612      setring(RR);
     613      def simp0=imap(@P,simp);
     614      def f2=f/simp0;
     615      return(f2);
     616    }
     617  }
     618}
     619
     620// pnormalf: reduces a polynomial f wrt a V(E)\V(N)
     621//           dividing by E and eliminating factors in N.
     622//           called in the ring @R,
     623//           operates in the ring @RP.
    602624// input:
    603625//         poly  f
     626//         ideal E  (depends only on the parameters)
    604627//         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
    610 proc 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
     628//                  (E,N) represents V(E)\V(N)
     629//         optional:
     630// output: poly f2 reduced wrt to V(E)\V(N)
     631proc pnormalf(poly f, ideal E, ideal N)
     632"USAGE:   pnormalf(f,E,N);
     633          f: the polynomial to be reduced modulo V(E)\V(N)
    613634          of a segment in the parameters.
    614           N: the null conditions ideal
    615           W: the non-null conditions (set of irreducible polynomials)
     635          E: the null conditions ideal
     636          N: the non-null conditions
    616637RETURN:   a reduced polynomial g of f, whose coefficients are reduced
    617           modulo N and having no factor in W.
    618 NOTE:     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).
     638          modulo E and having no factor in N.
     639NOTE: Should be called from ring Q[a][x].
     640          Ideals E and N must be given by polynomials
     641          in the parameters.
    624642KEYWORDS: division, pdivi, reduce
    625 EXAMPLE:  pnormalform; shows an example"
     643EXAMPLE:  pnormalf; shows an example"
    626644{
    627645    def RR=basering;
    628     setglobalrings();
     646    int te=0;
     647    if (defined(@P)){te=1;}
     648    else{setglobalrings();}
    629649    setring(@RP);
    630650    def fa=imap(RR,f);
     651    def Ea=imap(RR,E);
    631652    def Na=imap(RR,N);
    632     def Wa=imap(RR,W);
    633653    option(redSB);
    634     Na=std(Na);
    635     def r=cld(reduce(fa,Na));
    636     def f1=Wred(r[1],Wa);
     654    Ea=std(Ea);
     655    def r=cld(reduce(fa,Ea));
     656    poly f1=r[1];
     657    f1=Ered(r[1],Ea,Na);
    637658    setring(RR);
    638659    def f2=imap(@RP,f1);
     660    if(te==0){kill @R; kill @RP; kill @P;}
    639661    return(f2)
    640 }
     662};
    641663example
    642664{ "EXAMPLE:"; echo = 2;
    643665  ring R=(0,a,b,c),(x,y),dp;
    644   setglobalrings();
    645666  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]);
     667  ideal E=(c-1);
     668  ideal N=a-b;
     669  pnormalf(f,E,N);
    650670}
    651671
    … …  
    655675// input: two ideals in the ring @P
    656676// output the intersection of both (is not a GB)
    657 static proc idint(ideal I, ideal J)
     677proc idint(ideal I, ideal J)
    658678{
    659679  def RR=basering;
    … …  
    672692}
    673693
    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))
    693 proc 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 
    817694// lesspol: compare two polynomials by its leading power products
    818695// input:  two polynomials f,g in the ring @R
    819696// output: 0 if f<g,  1 if f>=g
    820 static proc lesspol(poly f, poly g)
     697proc lesspol(poly f, poly g)
    821698{
    822699  if (leadmonom(f)<leadmonom(g)){return(1);}
    … …  
    830707    }
    831708  }
    832 }
     709};
    833710
    834711// delfromideal: deletes the i-th polynomial from the ideal F
    835 static proc delfromideal(ideal F, int i)
     712proc delfromideal(ideal F, int i)
    836713{
    837714  int j;
    … …  
    839716  if (size(F)<i){ERROR("delfromideal was called incorrect arguments");}
    840717  if (size(F)<=1){return(ideal(0));}
    841   if (i==0){return(F);}
     718  if (i==0){return(F)};
    842719  for (j=1;j<=size(F);j++)
    843720  {
    … …  
    850727// input: ideals I,J
    851728// output: the ideal J without the polynomials in I
    852 static proc delidfromid(ideal I, ideal J)
     729proc delidfromid(ideal I, ideal J)
    853730{
    854731  int i; list r;
    … …  
    866743
    867744// sortideal: sorts the polynomials in an ideal by lm in ascending order
    868 static proc sortideal(ideal Fi)
     745proc sortideal(ideal Fi)
    869746{
    870747  def RR=basering;
    … …  
    894771// mingb: given a basis (gb reducing) it
    895772// order the polynomials is ascending order and
    896 // eliminate the polynomials whose lpp is divisible by some
     773// eliminates the polynomials whose lpp are divisible by some
    897774// smaller one
    898 static proc mingb(ideal F)
     775proc mingb(ideal F)
    899776{
    900777  int t; int i; int j;
    … …  
    917794}
    918795
    919 // redgb: given a minimal basis (gb reducing) it
     796// redgbn: given a minimal basis (gb reducing) it
     797// reduces each polynomial wrt to V(E) \ V(N)
     798proc redgbn(ideal F, ideal E, ideal N)
     799{
     800  int te=0;
     801  if (defined(@P)==1){te=1;}
     802  ideal G=F;
     803  ideal H;
     804  int i;
     805  if (size(G)==0){return(ideal(0));}
     806  for (i=1;i<=size(G);i++)
     807  {
     808    H=delfromideal(G,i);
     809    G[i]=pnormalf(pdivi(G[i],H)[1],E,N);
     810    G[i]=primepartZ(G[i]);
     811  }
     812  if(te==1){setglobalrings();}
     813  return(G);
     814};
     815
     816// eliminates repeated elements form an ideal
     817proc elimrepeated(ideal F)
     818{
     819  int i;
     820  ideal FF;
     821  FF[1]=F[1];
     822  for (i=2;i<=ncols(F);i++)
     823  {
     824    if (not(memberpos(F[i],FF)[1]))
     825    {
     826      FF[size(FF)+1]=F[i];
     827    }
     828  }
     829  return(FF);
     830}
     831
     832// equalideals
     833// input: 2 ideals F and G;
     834// output: 1 if they are identical (the same polynomials in the same order)
     835//         0 else
     836proc equalideals(ideal F, ideal G)
     837{
     838  int i=1; int t=1;
     839  if (size(F)!=size(G)){return(0);}
     840  while ((i<=size(F)) and (t))
     841  {
     842    if (F[i]!=G[i]){t=0;}
     843    i++;
     844  }
     845  return(t);
     846}
     847
     848// delintvec
     849// input: intvec V
     850//        int i
     851// output:
     852//        intvec W (equal to V but the coordinate i is deleted
     853proc delintvec(intvec V, int i)
     854{
     855  int j;
     856  intvec W;
     857  for (j=1;j<i;j++){W[j]=V[j];}
     858  for (j=i+1;j<=size(V);j++){W[j-1]=V[j];}
     859  return(W);
     860}
     861
     862//**************Begin homogenizing************************
     863
     864// ishomog:
     865// Purpose: test if a polynomial is homogeneous in the variables or not
     866// input:  poly f
     867// output  1 if f is homogeneous, 0 if not
     868proc ishomog(f)
     869{
     870  int i; poly r; int d; int dr;
     871  if (f==0){return(1);}
     872  d=deg(f); dr=d; r=f;
     873  while ((d==dr) and (r!=0))
     874  {
     875    r=r-lead(r);
     876    dr=deg(r);
     877  }
     878  if (r==0){return(1);}
     879  else{return(0);}
     880}
     881
     882// postredgb: given a minimal basis (gb reducing) it
    920883// reduces each polynomial wrt to the others
    921 static proc redgb(ideal F, ideal N, ideal W)
    922 {
     884proc postredgb(ideal F)
     885{
     886  int te=0;
     887  if(defined(@P)==1){te=1;}
    923888  ideal G;
    924889  ideal H;
    … …  
    928893  {
    929894    H=delfromideal(F,i);
    930     G[i]=pnormalform(pdivi(F[i],H)[1],N,W);
    931   }
     895    G[i]=pdivi(F[i],H)[1];
     896  }
     897  if(te==1){setglobalrings();}
    932898  return(G);
    933899}
    934900
    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
    949 static 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
    974 static 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
    1011 static 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.
    1071 static 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
    1195 static 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
    1209 static 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
    1234 static 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)
    1267 static 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];
    1298 static 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
    1454 static 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).
    1597 static 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 //  )
    1658 static 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 // ...
    1708 static 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"
    1745 proc 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.
    1752 RETURN:   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.
    1755 KEYWORDS: cgsdrold, buildtree, Maple
    1756 EXAMPLE:  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 }
    1816 example
    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
    1832 static 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
    1860 static 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
    1886 static 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
    1915 static 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
    1944 static 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
    1977 static 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
    2006 static 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)
    2028 static 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.
    2055 static 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).
    2077 static 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
    2097 static 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).
    2122 static 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
    2355 static 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
    2439 static 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.
    2477 static 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.
    2506 static 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
    2549 static 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
    2582 static 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
    2599 static 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.
    2616 static 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)) )
    2658 static 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
    2800 static 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
    2817 static 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).
    2836 static 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),...)
    2903 static 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)
    2973 static 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 //         )
    3035 static 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
    3058 static 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
    3084 static 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
    3103 static 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.
    3128 static 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
    3196 static 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
    3212 static 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.
    3235 static 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.
    3280 static 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)
    3306 static 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
    3336 static 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.
    3345 static 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.
    3390 static 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
    3414 static 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.
    3441 static 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
    3601 static 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
    3667 proc 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.
    3673 RETURN:   writes the list provided by grobcovold to a file
    3674           containing the table representing it in Maple.
    3675 NOTE:     It can be called from the output of grobcovold with option ("out",1)
    3676 KEYWORDS: grobcovold, Maple
    3677 EXAMPLE:  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 }
    3745 example
    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
    3761 static 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
    3776 static 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
    3803 static 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 
    3817 static 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 
    3986 static 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
    4004 static 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 
    4018 static 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 
    4153901//purpose ideal intersection called in @R and computed in @P
    4154 static proc idintR(ideal N, ideal M)
     902proc idintR(ideal N, ideal M)
    4155903{
    4156904  def RR=basering;
    … …  
    4163911}
    4164912
    4165 //purpose reduced groebner basis called in @R and computed in @P
    4166 static proc gbR(ideal N)
     913//purpose reduced Groebner basis called in @R and computed in @P
     914proc gbR(ideal N)
    4167915{
    4168916  def RR=basering;
    … …  
    4175923}
    4176924
    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.
    4179 static 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 
    4260925//**************End homogenizing************************
    4261 
    4262 //**************End of redcgs************************
    4263926
    4264927//**************Begin of Groebner Cover*****************
    … …  
    4269932//        poly f:
    4270933// Output: Na = N:<f>
    4271 static proc incquotient(ideal N, poly f)
     934proc incquotient(ideal N, poly f)
    4272935{
    4273936  poly g; int i;
    … …  
    4318981}
    4319982
    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 
    4335 static 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, 1);
    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).
    4382 static 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).
    4437 static 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
    4499 static proc elimfromlist(list l, int i)
     983// eliminates the ith element from a list
     984proc elimfromlist(list l, int i)
    4500985{
    4501986  list L; int j;
    … …  
    4507992}
    4508993
    4509 static proc idbefid(ideal a, ideal b)
     994proc idbefid(ideal a, ideal b)
    4510995{
    4511996  poly fa; poly fb; poly la; poly lb;
    … …  
    45301015    }
    45311016  }
    4532   if(na<nb){return(1);} else{if(na>nb){return(2);} else{return(0);}}
    4533 }
    4534 
    4535 static proc sortlistideals(list L)
     1017  if(na<nb){return(1);}
     1018  else
     1019  {
     1020    if(na>nb){return(2);}
     1021    else{return(0);}
     1022  }
     1023}
     1024
     1025proc sortlistideals(list L)
    45361026{
    45371027  int i; int j; int n;
    … …  
    45571047
    45581048// returns 1 if the two lists of ideals are equal and 0 if not
    4559 static proc equallistideals(list L, list M)
     1049proc equallistideals(list L, list M)
    45601050{
    45611051  int t; int i;
    … …  
    45671057    {
    45681058      i=1;
    4569       while ((t==1) and (i<=size(L)))
     1059      while ((t) and (i<=size(L)))
    45701060      {
    45711061        if (equalideals(L[i],M[i])==0){t=0;}
    … …  
    45741064    }
    45751065    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).
    4588 static 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))
    4641 static 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));
    46631066  }
    46641067}
    … …  
    46731076//    the Prep of V(N)\V(M)
    46741077// Assumed to work in the ring @P of the parameters
    4675 static proc Prep(ideal N, ideal M)
     1078proc Prep(ideal N, ideal M)
    46761079{
    46771080  if (N[1]==1)
    46781081  {
    4679     //L0=list(list(ideal(1),list(ideal(1))));
    46801082    return(list(list(ideal(1),list(ideal(1)))));
    46811083  }
    … …  
    47201122// output:
    47211123//    list (ideal ida, ideal idb)
    4722 //    the C-represen taion of V(N)\V(M) = V(ida)\V(idb)
     1124//    the C-representaion of V(N)\V(M) = V(ida)\V(idb)
    47231125// Assumed to work in the ring @P of the parameters
    4724 static proc PtoCrep(list L)
     1126proc PtoCrep(list L)
    47251127{
    47261128  def RR=basering;
    … …  
    47451147}
    47461148
    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
    4757 static 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.
    4806 static 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.
    4877 static 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
     1149// input: F a parametric ideal in Q[a][x]
     1150// output: a rComprehensive Groebner System disjoint and reduced.
     1151//      It uses Kapur-Sun-Wang algorithm, and with the options
     1152//      can compute the homogenization before  (('can',0) or ( 'can',1))
     1153//      and dehomogenize the result.
    49281154proc cgsdr(ideal F, list #)
    4929 "USAGE:   cgsdr(F); To compute a disjoint, reduced CGS.
     1155"USAGE: cgsdr(F); To compute a disjoint, reduced CGS.
    49301156          cgsdr is the starting point of the fundamental routine grobcov.
     1157          Inside grobcov it is used only with options 'can' set to 0,1 and
     1158          not with options ('can',2).
    49311159          It is to be used if only a disjoint reduced CGS is required.
    49321160          F: ideal in Q[a][x] (parameters and variables) to be discussed.
    … …  
    49361164
    49371165          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
     1166            "can",0-1-2: The default value is "can",2. In this case no
     1167                homogenization is done. With option ("can",0) the given
     1168                basis is homogenized, and with option ("can",1) the
     1169                whole given ideal is homogenized before computing the
     1170                cgs and dehomogenized after.
     1171                with option ("can",0) the homogenized basis is used
     1172                with option ("can",1) the homogenized ideal is used
     1173                with option ("can",2) the given basis is used
     1174            "null",ideal E: The default is ('null',ideal(0)).
     1175            "nonnull",ideal N: The default (nonnull,ideal(1)).
     1176                When options 'null' and/or 'nonnull' are given, then
     1177                the parameter space is restricted to V(E)\V(N).
     1178            "comment",0-1: The default is ('comment',0). Setting ('comment',1)
    49441179                will provide information about the development of the
    49451180                computation.
    4946           One can give none till 3 of these options.
    4947 RETURN:   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.
     1181            "out",0-1: 1 (default) the output segments are given as
     1182                as difference of varieties.
     1183                0: the output segments are given in P-representation
     1184                and the segments grouped by lpp
     1185                With options ("can",0) and ("can",1) the option ("out",1)
     1186                is set to ("out,0) because it is not compatible.
     1187          One can give none or whatever of these options.
     1188          With the default options ("can",2,"out",1), only the
     1189          Kapur-Sun-Wang algorithm is computed. This is very effectif
     1190          but is only the starting point for the grobcov computation.
     1191          When grobcov is computed, the call to cgsdr inside uses
     1192          specific options that are more expensive ("can",0-1,"out",0).
     1193RETURN:   Returns a list T describing a reduced and disjoint
     1194          Comprehensive Groebner System (CGS),
     1195          With option ("out",0)
     1196           the segments are grouped by
     1197           leading power products (lpp) of the reduced Groebner
     1198           basis and given in P-representation.
     1199           The returned list is of the form:
     1200           (
     1201             (lpp, (num,basis,segment),...,(num,basis,segment),lpp),
     1202             ..,,
     1203             (lpp, (num,basis,segment),...,(num,basis,segment),lpp)
     1204           )
     1205           The bases are the reduced Groebner bases (after normalization)
     1206           for each point of the corresponding segment.
     1207
     1208           The third element of each lpp segment is the lpp of the
     1209           used ideal in the CGS as a string:
     1210            with option ("can",0) the homogenized basis is used
     1211            with option ("can",1) the homogenized ideal is used
     1212            with option ("can",2) the given basis is used
     1213
     1214          With option ("out",1) (default)
     1215           only KSW is applied and segments are given as
     1216           difference of varieties and are not grouped
     1217           The returned list is of the form:
     1218           (
     1219             (E,N,B),..(E,N,B)
     1220           )
     1221           E is the null variety
     1222           N is the nonnull variety
     1223           segment = V(E)\V(N)
     1224           B is the reduced Groebner basis
     1225
    49611226NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
    49621227          x=variables, and should be defined previously, and the ideal
    49631228          defined on R.
    4964 KEYWORDS: CGS, disjoint, reduced, comprehensive Groebner system
     1229KEYWORDS: CGS, disjoint, reduced, Comprehensive Groebner System
    49651230EXAMPLE:  cgsdr; shows an example"
    49661231{
    4967   list @T;
    4968   exportto(Top,@T);
     1232  def RR=basering;
    49691233  setglobalrings();
    4970   int i;
     1234  // INITIALIZING OPTIONS
     1235  int i; int j;
     1236  int can=2;
     1237  int out=1;
     1238  poly f;
    49711239  ideal B;
    4972   poly f;
    4973   def N=ideal(0);
    4974   def W=ideal(1);
     1240  def E=ideal(0);
     1241  def N=ideal(1);
    49751242  int comment=0;
     1243  int start=timer;
    49761244  list L=#;
    49771245  for(i=1;i<=size(L) div 2;i++)
    49781246  {
    4979     if(L[2*i-1]=="null"){N=L[2*i];}
     1247    if(L[2*i-1]=="null"){E=L[2*i];}
    49801248    else
    49811249    {
    4982       if(L[2*i-1]=="nonnull"){W=L[2*i];}
     1250      if(L[2*i-1]=="nonnull"){N=L[2*i];}
    49831251      else
    49841252      {
    49851253        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));
     1254        else
     1255        {
     1256          if(L[2*i-1]=="can"){can=L[2*i];}
     1257          else
     1258          {
     1259            if(L[2*i-1]=="out"){out=L[2*i];}
     1260          }
     1261        }
     1262      }
     1263    }
     1264  }
     1265  //if(can==2){out=1;}
     1266  B=F;
     1267  if ((printlevel) and (comment==0)){comment=printlevel;}
     1268  if((can<2) and (out>0)){"Option out,1 is not compatible with can,0,1"; out=0;}
     1269  // DEFINING OPTIONS
     1270  list LL;
     1271  LL[1]="can";     LL[2]=can;
     1272  LL[3]="comment"; LL[4]=comment;
     1273  LL[5]="out";     LL[6]=out;
     1274  LL[7]="null";    LL[8]=E;
     1275  LL[9]="nonnull"; LL[10]=N;
     1276  if(comment>=1)
     1277  {
     1278    "Begin cgsdr with options: "+string(LL);
     1279  }
     1280  int ish;
     1281  for (i=1;i<=size(B);i++){ish=ishomog(B[i]); if(ish==0){break;};}
     1282  if (ish)
     1283  {
     1284     if(comment>0){"The given system is homogneous";}
     1285    can=0;
     1286  }
     1287  // ACTING DEPENDING ON OPTIONS
     1288  if(can==2)
     1289  {
     1290    // WITHOUT HOMOHGENIZING
     1291    if(comment>0){"Option of cgsdr: do not homogenize";}
     1292    def GS=KSW(B,LL);
     1293    setglobalrings();
     1294  }
     1295  else
     1296  {
     1297    if(can==1)
     1298    {
     1299      // COMPUTING THE HOMOGOENIZED IDEAL
     1300      if(comment>0){"Homogenizing the whole ideal: option can=1"; }
     1301      list RRL=ringlist(RR);
     1302      RRL[3][1][1]="dp";
     1303      def Pa=ring(RRL[1]);
     1304      list Lx;
     1305      Lx[1]=0;
     1306      Lx[2]=RRL[2]+RRL[1][2];
     1307      Lx[3]=RRL[1][3];
     1308      Lx[4]=RRL[1][4];
     1309      RRL[1]=0;
     1310      def D=ring(RRL);
     1311      def RP=D+Pa;
     1312      setring(RP);
     1313      def B1=imap(RR,B);
     1314      option(redSB);
     1315      B1=std(B1);
     1316      setring(RR);
     1317      def B2=imap(RP,B1);
     1318    }
     1319    else
     1320    { // (can=0)
     1321      if(comment>0){"Homogenizing the basis: option can=0";}
     1322      def B2=B;
     1323    }
     1324    // COMPUTING HOMOGENIZED CGS
     1325    poly @t;
     1326    ring H=0,@t,dp;
     1327    def RH=RR+H;
     1328    setring(RH);
     1329    setglobalrings();
     1330    def BH=imap(RR,B2);
     1331    def LH=imap(RR,LL);
     1332    for (i=1;i<=size(BH);i++)
     1333    {
     1334      BH[i]=homog(BH[i],@t);
     1335    }
     1336    if (comment>=1){"Homogenized system = "; BH;}
     1337    def GSH=KSW(BH,LH);
     1338    setglobalrings();
     1339    // DEHOMOGENIZING THE RESULT
     1340    if(out==0)
     1341    {
     1342      for (i=1;i<=size(GSH);i++)
     1343      {
     1344        GSH[i][1]=subst(GSH[i][1],@t,1);
     1345        for(j=1;j<=size(GSH[i][2]);j++)
     1346        {
     1347          GSH[i][2][j][2]=subst(GSH[i][2][j][2],@t,1);
     1348        }
     1349      }
     1350    }
     1351    else
     1352    {
     1353      for (i=1;i<=size(GSH);i++)
     1354      {
     1355        GSH[i][3]=subst(GSH[i][3],@t,1);
     1356        GSH[i][7]=subst(GSH[i][7],@t,1);
     1357      }
     1358    }
     1359    setring(RR);
     1360    def GS=imap(RH,GSH);
     1361    setglobalrings();
     1362    if(out==0)
     1363    {
     1364      for (i=1;i<=size(GS);i++)
     1365      {
     1366        GS[i][1]=postredgb(mingb(GS[i][1]));
     1367        for(j=1;j<=size(GS[i][2]);j++)
     1368        {
     1369          GS[i][2][j][2]=postredgb(mingb(GS[i][2][j][2]));
     1370        }
     1371      }
     1372    }
     1373    else
     1374    {
     1375      for (i=1;i<=size(GS);i++)
     1376      {
     1377        if(GS[i][2]==1)
     1378        {
     1379          GS[i][3]=postredgb(mingb(GS[i][3]));
     1380          GS[i][7]=postredgb(mingb(GS[i][7]));
     1381        }
     1382      }
     1383    }
     1384  }
     1385  if(defined(@P)){kill @P; kill @R; kill @RP;}
     1386  return(GS);
    50081387}
    50091388example
    … …  
    50201399}
    50211400
    5022 //reccgsdr
    5023 // 20/09/2010
    5024 static 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
     1401// input:  internal routine called by cgsdr at the end to group the
     1402//         lpp segments and improve the output
    50711403// output: grouped segments by lpp obtained in cgsdr
    5072 static proc grsegments(list T)
     1404proc grsegments(list T)
    50731405{
    50741406  int i;
    … …  
    50981430    }
    50991431  }
    5100   //"L in groupsegments="; L;
    51011432  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 //  )
    5134 static 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);
    51571433}
    51581434
    … …  
    51601436// input: ideal p, ideal q
    51611437// output: 1 if p contains q,  0 otherwise
    5162 static proc idcontains(ideal p, ideal q)
     1438proc idcontains(ideal p, ideal q)
    51631439{
    51641440  int t; int i;
    51651441  t=1; i=1;
    51661442  def RR=basering;
    5167   setring @P;
     1443  setring(@P);
    51681444  def P=imap(RR,p);
    51691445  def Q=imap(RR,q);
    51701446  attrib(P,"isSB",1);
    51711447  poly r;
    5172   while ((t==1) and (i<=size(Q)))
     1448  while ((t) and (i<=size(Q)))
    51731449  {
    51741450    r=reduce(Q[i],P);
    … …  
    51761452    i++;
    51771453  }
    5178   setring RR;
     1454  setring(RR);
    51791455  return(t);
    51801456}
    … …  
    51851461// input: L (list of ideals)
    51861462// output: the list of integers corresponding to the minimal ideals in L
    5187 static proc selectminideals(list L)
    5188 {
    5189   if (size(L)==0){return(L);}
     1463proc selectminideals(list L)
     1464{
     1465  if (size(L)==0){return(L)};
    51901466  def RR=basering;
    5191   setring @P;
     1467  setring(@P);
    51921468  def Lp=imap(RR,L);
    51931469  int i; int j; int t; intvec notsel;
    … …  
    51951471  for (i=1;i<=size(Lp);i++)
    51961472  {
    5197     if(memberpos(i,notsel)[1]==1)
     1473    if(memberpos(i,notsel)[1])
    51981474    {
    51991475      i++;
    … …  
    52021478    t=1;
    52031479    j=1;
    5204     while ((t==1) and (j<=size(Lp)))
     1480    while ((t) and (j<=size(Lp)))
    52051481    {
    52061482      if (i==j){j++;}
    … …  
    52081484      {
    52091485
    5210         if (idcontains(Lp[i],Lp[j])==1)
     1486        if (idcontains(Lp[i],Lp[j]))
    52111487        {
    52121488          notsel[size(notsel)+1]=i;
    … …  
    52161492      j++;
    52171493    }
    5218     if (t==1){P[size(P)+1]=i;}
     1494    if (t){P[size(P)+1]=i;}
    52191495  }
    52201496  setring(RR);
    … …  
    52311507// output: P-representation of the union
    52321508//       ((P_j,(P_j1,...,P_jk_j | j=1..t)))
    5233 static proc LCUnion(list LL)
     1509proc LCUnion(list LL)
    52341510{
    52351511  def RR=basering;
    … …  
    52841560//   C=((q_1,(q_11,..,q_1l_1)),..,(q_k,(q_k1,..,q_kl_k)))
    52851561//        the list of segments to be added to the holes
    5286 static proc addpart(list H, list C)
     1562proc addpart(list H, list C)
    52871563{
    52881564  list Q; int i; int j; int k; int l; int t; int t1;
    … …  
    52961572      q=Q[i];
    52971573      t=1; j=1;
    5298       while ((t==1) and (j<=size(C)))
    5299       {
    5300         if (equalideals(q,C[j][1])==1)
     1574      while ((t) and (j<=size(C)))
     1575      {
     1576        if (equalideals(q,C[j][1]))
    53011577        {
    53021578          t=0;
    … …  
    53071583            //list addq;
    53081584            l=1;
    5309             while((t1==1) and (l<=size(Q)))
     1585            while((t1) and (l<=size(Q)))
    53101586            {
    53111587              if ((l!=i) and (memberpos(l,notQ)[1]==0))
    53121588              {
    5313                 if (idcontains(C[j][2][k],Q[l])==1)
     1589                if (idcontains(C[j][2][k],Q[l]))
    53141590                {
    53151591                  t1=0;
    … …  
    53181594              l++;
    53191595            }
    5320             if (t1==1)
     1596            if (t1)
    53211597            {
    53221598              addq[size(addq)+1]=C[j][2][k];
    … …  
    53561632// that part.
    53571633// Works on @P ring.
    5358 static proc addpartfine(list H, list C0)
     1634proc addpartfine(list H, list C0)
    53591635{
    53601636  int i; int j; int k; int te; intvec notQ; int l; list sel; int used;
    … …  
    53801656      {
    53811657        te=idcontains(Q[i],C[j][1]);
    5382         if(te==1)
     1658        if(te)
    53831659        {
    53841660          for(k=1;k<=size(C[j][2]);k++)
    53851661          {
    5386             if(idcontains(Q[i],C[j][2][k])==1)
     1662            if(idcontains(Q[i],C[j][2][k]))
    53871663            {
    53881664              te=0; break;
    53891665            }
    53901666          }
    5391           if (te==1)
     1667          if (te)
    53921668          {
    53931669            used++;
    … …  
    54381714  }
    54391715  setring(RR);
    5440   //if(used>0){string("addpartfine was ", used, " times used");}
     1716  //if(used>0){"addpartfine was ", used, " times used";}
    54411717  return(imap(@P,Q1));
    54421718}
    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 //}
    54911719
    54921720// specswellCrep
    … …  
    54981726//   1 if g1 spezializes well to g2 on the whole (ida2,idb2) segment
    54991727//   0 if not
    5500 static proc specswellCrep(poly g1, poly g2, ideal ida2)
     1728proc specswellCrep(poly g1, poly g2, ideal ida2)
    55011729{
    55021730  poly S;
    … …  
    55141742}
    55151743
    5516 
    55171744// gcover
    55181745// 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
    55201746//    list #: optional
    55211747// 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)) )
     1748//   S=((lpp, generic basis, Prep, Crep),..,(lpp, generic basis, Prep, Crep))
     1749//      where a Prep is ( (p1,(p11,..,p1k_1)),..,(pj,(pj1,..,p1k_j)) )
    55241750//            a Crep is ( ida, idb )
    5525 static proc gcover(ideal F,list GenCase, list #)
     1751proc gcover(ideal F,list #)
    55261752{
    55271753  int i; int j; int k; ideal lpp; list GPi2; list pairspP; ideal B; int ti;
    55281754  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];
     1755  list prep; list crep; list LCU; poly p; poly lcp; ideal FF;
     1756  list lpi;
     1757  string lpph;
     1758  list L=#;
     1759  int canop=1;
     1760  int extop=1;
     1761  int repop=0;
     1762  ideal E=ideal(0);;
     1763  ideal N=ideal(1);;
     1764  int comment;
     1765  for(i=1;i<=size(L) div 2;i++)
     1766  {
     1767    if(L[2*i-1]=="can"){canop=L[2*i];}
     1768    else
     1769    {
     1770      if(L[2*i-1]=="ext"){extop=L[2*i];}
     1771      else
     1772      {
     1773        if(L[2*i-1]=="rep"){repop=L[2*i];}
     1774        else
     1775        {
     1776          if(L[2*i-1]=="null"){E=L[2*i];}
     1777          else
     1778          {
     1779            if(L[2*i-1]=="nonnull"){N=L[2*i];}
     1780            else
     1781            {
     1782              if (L[2*i-1]=="comment"){comment=L[2*i];}
     1783            }
     1784          }
     1785        }
     1786      }
     1787    }
     1788  }
    55341789  list GS; list GP;
    55351790  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   }
     1791  GS=cgsdr(F,L); // "null",NW[1],"nonnull",NW[2],"cgs",CGS,"comment",comment);
     1792  setglobalrings();
     1793  int start=timer;
     1794  GP=GS;
     1795  ideal lppr;
    56111796  list LL;
    56121797  list S;
    56131798  poly sp;
    56141799  ideal BB;
    5615   start1=timer;
    56161800  for (i=1;i<=size(GP);i++)
    56171801  {
    … …  
    56201804    lpp=GP[i][1];
    56211805    GPi2=GP[i][2];
     1806    lpph=GP[i][3];
    56221807    kill pairspP; list pairspP;
    56231808    for(j=1;j<=size(GPi2);j++)
    … …  
    56301815    {
    56311816      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       }
     1817      B=GPi2[LCU[k][1][1]][2]; // ATENTION last 1 has been changed to [2]
    56401818      LCU[k][1]=B;
    56411819    }
    5642     // Deciding if combine is needed
     1820    //"Deciding if combine is needed";
    56431821    kill BB;
    56441822    ideal BB;
    56451823    tes=1; m=1;
    5646     while((tes==1) and (m<=size(LCU[1][1])))
     1824    while((tes) and (m<=size(LCU[1][1])))
    56471825    {
    56481826      j=1;
    5649       while((tes==1) and (j<=size(LCU)))
     1827      while((tes) and (j<=size(LCU)))
    56501828      {
    56511829        k=1;
    5652         while((tes==1) and (k<=size(LCU)))
     1830        while((tes) and (k<=size(LCU)))
    56531831        {
    56541832          if(j!=k)
    56551833          {
    5656             sp=pnormalform(pspol(LCU[j][1][m],LCU[k][1][m]),LCU[k][2],NW[2]);
     1834            sp=pnormalf(pspol(LCU[j][1][m],LCU[k][1][m]),LCU[k][2],N);
    56571835            if(sp!=0){tes=0;}
    56581836          }
    56591837          k++;
    5660         }
    5661         if(tes==1)
     1838        }        //setglobalrings();
     1839        if(tes)
    56621840        {
    56631841          BB[m]=LCU[j][1][m];
    … …  
    56671845      if(tes==0){break;}
    56681846      m++;
    5669     }
     1847    }    //"T_BB="; BB;
    56701848    crep=PtoCrep(prep);
    56711849    if(tes==0)
    … …  
    56981876    for(j=1;j<=size(B);j++)
    56991877    {
    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;
     1878      B[j]=pnormalf(B[j],crep[1],N);
     1879    }
     1880    S[i]=list(lpp,B,prep,crep,lpph);
     1881    if(comment>=1)
     1882    {
     1883      lpi[size(lpi)+1]=string("[",i,"]");
     1884      lpi[size(lpi)+1]=S[i][1];
     1885    }
     1886  }
     1887  if(comment>=1)
     1888  {
     1889    "Time in LCUnion + combine = ",timer-start;
     1890    if(comment>=2){"lpp=",lpi};
     1891  }
     1892  if(defined(@P)==1){kill @P; kill @RP; kill @R;}
    57091893  return(S);
    57101894}
    … …  
    57141898//    ideal F: a parametric ideal in Q[a][x], where a are the parameters
    57151899//             and x the variables
    5716 //    list #: (options) list("null",N,"nonnull",W,"can",Method,"cgs",CGS), where
     1900//    list #: (options) list("null",N,"nonnull",W,"can",0-1,ext",0-1, "rep",0-1-2)
     1901//            where
    57171902//            N is the null conditions ideal (if desired)
    57181903//            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
     1904//            The value of "can"is 1 by default and can be set to 0 if we do not
    57201905//            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.
     1906//            The value of "ext" is 0 by default and so the generic representation
     1907//             of the bases is given. It can be set to 1, and then the full
     1908//             representation of the bases is given.
     1909//            The value of "rep" is 0 by default, and then the segments
     1910//            are given in canonical P-representation. It can be set to 1
     1911//            and then they are given in canonical C-representation.
     1912//            If it is set to 2, then both representations are given.
    57231913// output:
    57241914//    list S: ((lpp,basis,(idp_1,(idp_11,..,idp_1s_1))), ..
    … …  
    57311921          (see (*) Montes A., Wibmer M., Groebner Bases for Polynomial
    57321922          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.
     1923          The Groebner cover of a parametric ideal consist of a set of
     1924          pairs(S_i,B_i), where the S_i are disjoint locally closed
     1925          segments of the parameter space, and the B_i are the reduced
     1926          Groebner bases of the ideal on every point of S_i.
    57371927
    57381928          The ideal F must be defined on a parametric ring Q[a][x].
    … …  
    57411931
    57421932          Options:
    5743             "null",ideal N: The default is "null",ideal(0).
    5744             "nonnull",ideal W: The default "nonnull",ideal(1).
     1933            "null",ideal E: The default is ("null",ideal(0)).
     1934            "nonnull",ideal N: The default ("nonnull",ideal(1)).
    57451935                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
     1936                the parameter space is restricted to V(E)\V(N).
     1937            "can",0-1: The default is ("can",1). With the default option
    57491938                the homogenized ideal is computed before obtaining the
    57501939                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
     1940                Groebner cover. Setting ("can",0) only homogenizes the
     1941                basis so the result is not exactly canonical, but the
     1942                computation is shorter.
     1943            "ext",0-1: The default is ("ext",0). With the default
     1944                ("ext",0), only the generic representation is computed
     1945                (single polynomials, but not specializing to non-zero at
     1946                each point of the segment. With option ("ext",1) the
    57551947                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.
     1948                shaves) and sometimes a simpler result is obtained.
     1949            "rep",0-1-2: The default is ("rep",0) and then the segments
     1950                are given in canonical P-representation. Option ("rep",1)
     1951                represents the segments in canonical C-representation,
     1952                and option ("rep",2) gives both representations.
     1953            "comment",0-3: The default is ("comment",0). Setting
     1954                "comment" higher will provide information about the
     1955                development of the computation.
     1956          One can give none or whatever of these options.
    57691957RETURN:   The list
    57701958          (
    5771            (lpp_1,basis_1,P-representation_1),
     1959           (lpp_1,basis_1,segment_1,lpph_1),
    57721960           ...
    5773            (lpp_s,basis_s,P-represntation_s)
     1961           (lpp_s,basis_s,segment_s,lpph_s)
    57741962          )
    57751963
    … …  
    57771965          set of lpp of the reduced Groebner basis for each point
    57781966          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.
     1967          The lpph corresponds to the lpp of the homogenized ideal
     1968          and is different for each segment. It is given as a string.
     1969
     1970          Basis: to each element of lpp corresponds an I-regular function given
     1971          in full representation (by option ("ext",1)) or in
     1972          generic representation (default option ("ext",0)). The
     1973          I-regular function is the corresponding element of the reduced
     1974          Groebner basis for each point of the segment with the given lpp.
    57851975          For each point in the segment, the polynomial or the set of
    57861976          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.
     1977          then after normalization, specializes to the corresponding
     1978          element of the reduced Groebner basis. In the full representation
     1979          at least one of the polynomials representing the I-regular
     1980          function specializes to non-zero.
     1981
     1982          With the default option ("rep",0) the representation of the
     1983          segment is the P-representation.
     1984          With option ("rep",1) the representation of the segment is
     1985          the C-representation.
     1986          With option ("rep",2) both representations of the segment are
     1987          given.
    57891988
    57901989          The P-representation of a segment is of the form
    57911990          ((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 
    5795 NOTE:     The basering R, must be of the form Q[a][x], a=parameters,
     1991          representing the segment U_i (V(p_i) \ U_j (V(p_ij))),
     1992          where the p's are prime ideals.
     1993
     1994          The C-representation of a segment is of the form
     1995          (E,N) representing V(E)\V(N), and the ideals E and N are
     1996          radical and N contains E.
     1997
     1998NOTE: The basering R, must be of the form Q[a][x], a=parameters,
    57961999          x=variables, and should be defined previously. The ideal must
    57972000          be defined on R.
    57982001KEYWORDS: Groebner cover, parametric ideal, canonical, discussion of
    5799           parametric ideal, multigrobcov, gencase1.
     2002          parametric ideal.
    58002003EXAMPLE:  grobcov; shows an example"
    58012004{
    58022005  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=#;
     2006  ideal idp; ideal idq; int s; ideal ext; list SS;
     2007  ideal E; ideal N; int canop;  int extop; int repop;
     2008  int comment=0; int m;
     2009  def RR=basering;
     2010  setglobalrings();
     2011  list L0=#;
     2012  int out=0;
     2013  L0[size(L0)+1]="res"; L0[size(L0)+1]=ideal(1);
    58072014  // default options
    58082015  int start=timer;
    5809   def RR=basering;
    5810   list NW0;
    5811   W=ideal(1);
    5812   N=ideal(0);
     2016  E=ideal(0);
     2017  N=ideal(1);
    58132018  canop=1; // canop=0 for homogenizing the basis but not the ideal (not canonical)
    58142019           // canop=1 for working with the homogenized ideal
    … …  
    58162021           // repop=1 for representing the segments in Crep
    58172022           // 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];}
     2023  extop=0; // extop=0 if only generic representation of the bases are to be computed
     2024           // extop=1 if the full representation of the bases are to be computed
     2025  for(i=1;i<=size(L0) div 2;i++)
     2026  {
     2027    if(L0[2*i-1]=="can"){canop=L0[2*i];}
    58252028    else
    58262029    {
    5827       if(L[2*i-1]=="ext"){extop=L[2*i];}
     2030      if(L0[2*i-1]=="ext"){extop=L0[2*i];}
    58282031      else
    58292032      {
    5830         if(L[2*i-1]=="rep"){repop=L[2*i];}
     2033        if(L0[2*i-1]=="rep"){repop=L0[2*i];}
    58312034        else
    58322035        {
    5833           if(L[2*i-1]=="null"){N=L[2*i];}
     2036          if(L0[2*i-1]=="null"){E=L0[2*i];}
    58342037          else
    58352038          {
    5836             if(L[2*i-1]=="nonnull"){W=L[2*i];}
     2039            if(L0[2*i-1]=="nonnull"){N=L0[2*i];}
    58372040            else
    58382041            {
    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               }
     2042              if (L0[2*i-1]=="comment"){comment=L0[2*i];}
    58442043            }
    58452044          }
    … …  
    58482047    }
    58492048  }
    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();
     2049  if(not((canop==0) or (canop==1)))
     2050  {
     2051    "Option can = ",canop," is not supported. It is changed to can = 1";
     2052    canop=1;
     2053  }
     2054  for(i=1;i<=size(L0) div 2;i++)
     2055  {
     2056    if(L0[2*i-1]=="can"){L0[2*i]=canop;}
     2057  }
     2058  if ((printlevel) and (comment==0)){comment=printlevel;}
     2059  list LL;
     2060  LL[1]="can";     LL[2]=canop;
     2061  LL[3]="comment"; LL[4]=comment;
     2062  LL[5]="out";     LL[6]=0;
     2063  LL[7]="null";    LL[8]=E;
     2064  LL[9]="nonnull"; LL[10]=N;
     2065  LL[11]="ext";    LL[12]=extop;
     2066  LL[13]="rep";    LL[14]=repop;
     2067  if (comment>=1)
     2068  {
     2069    "Begin grobcov with options: ",string(LL);
     2070  }
     2071  kill S;
     2072  def S=gcover(F,LL);
     2073  // NOW extend
     2074  if(extop)
     2075  {
     2076    S=extend(S,LL);
    58592077  }
    58602078  else
    58612079  {
    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)
     2080    // NOW representation of the segments by option repop
     2081    list Si; list nS;
     2082    if(repop==0)
     2083    {
     2084      for(i=1;i<=size(S);i++)
     2085      {
     2086        Si=list(S[i][1],S[i][2],S[i][3],S[i][5]);
     2087        nS[size(nS)+1]=Si;
     2088      }
     2089      kill S;
     2090      def S=nS;
     2091    }
     2092    else
     2093    {
     2094      if(repop==1)
     2095      {
     2096        for(i=1;i<=size(S);i++)
    58912097        {
    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;
     2098          Si=list(S[i][1],S[i][2],S[i][4],S[i][5]);
     2099          nS[size(nS)+1]=Si;
    58992100        }
    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)
     2101        kill S;
     2102        def S=nS;
     2103      }
     2104      else
     2105      {
     2106        for(i=1;i<=size(S);i++)
    59602107        {
    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];
     2108          Si=list(S[i][1],S[i][2],S[i][3],S[i][4],S[i][5]);
     2109          nS[size(nS)+1]=Si;
    59912110        }
    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   }
     2111        kill S;
     2112        def S=nS;
     2113      }
     2114    }
     2115  }
     2116  if (comment>=1)
     2117  {
     2118    "Time in grobcov = ", timer-start;
     2119    "Number of segments of grobcov = ", size(S);
     2120  }
     2121  if(defined(@P)==1){kill @R; kill @P; kill @RP;}
    60242122  return(S);
    60252123}
    … …  
    60372135}
    60382136
    6039 
     2137// input. GC the grobcov of an ideal in generic representation of the
     2138//        bases computed with option option ("rep",2).
     2139// output The grobcov in full representation.
     2140// option ("comment",1) shows the time.
     2141proc extend(list GC, list #);
     2142"USAGE:   extend(GC); When the grobcov of an ideal has been computed
     2143          with the default option ("ext",0) and the explicit option
     2144          ("rep",2) (which is not the default), then one can call
     2145          extend (GC) (and options) to obtain the full representation
     2146          of the bases. With the default option ("ext",0) only the
     2147          generic representation of the bases are computed, and one can
     2148          obtain the full representation using extend.
     2149            "rep",0-1-2: The default is ("rep",0) and then the segments
     2150                are given in canonical P-representation. Option ("rep",1)
     2151                represents the segments in canonical C-representation,
     2152                and option ("rep",2) gives both representations.
     2153            "comment",0-1: The default is ("comment",0). Setting
     2154                "comment" higher will provide information about the
     2155                time used in the computation.
     2156          One can give none or whatever of these options.
     2157RETURN:   The list
     2158          (
     2159           (lpp_1,basis_1,segment_1,lpph_1),
     2160           ...
     2161           (lpp_s,basis_s,segment_s,lpph_s)
     2162          )
     2163
     2164          The lpp are constant over a segment and correspond to the
     2165          set of lpp of the reduced Groebner basis for each point
     2166          of the segment.
     2167          The lpph corresponds to the lpp of the homogenized ideal
     2168          and is different for each segment. It is given as a string.
     2169
     2170          Basis: to each element of lpp corresponds an I-regular function given
     2171          in full representation. The
     2172          I-regular function is the corresponding element of the reduced
     2173          Groebner basis for each point of the segment with the given lpp.
     2174          For each point in the segment, the polynomial or the set of
     2175          polynomials representing it, if they do not specialize to 0,
     2176          then after normalization, specializes to the corresponding
     2177          element of the reduced Groebner basis. In the full representation
     2178          at least one of the polynomials representing the I-regular
     2179          function specializes to non-zero.
     2180
     2181          With the default option ("rep",0) the segments are given
     2182          in P-representation.
     2183          With option ("rep",1) the segments are given
     2184          in C-representation.
     2185          With option ("rep",2) both representations of the segments are
     2186          given.
     2187
     2188          The P-representation of a segment is of the form
     2189          ((p_1,(p_11,..,p_1k1)),..,(p_r,(p_r1,..,p_rkr))
     2190          representing the segment U_i (V(p_i) \ U_j (V(p_ij))),
     2191          where the p's are prime ideals.
     2192
     2193          The C-representation of a segment is of the form
     2194          (E,N) representing V(E)\V(N), and the ideals E and N are
     2195          radical and N contains E.
     2196
     2197NOTE: The basering R, must be of the form Q[a][x], a=parameters,
     2198          x=variables, and should be defined previously. The ideal must
     2199          be defined on R.
     2200KEYWORDS: Groebner cover, parametric ideal, canonical, discussion of
     2201          parametric ideal, full representation.
     2202EXAMPLE:  extend; shows an example"
     2203{
     2204  list L=#;
     2205  list S=GC;
     2206  ideal idp;
     2207  ideal idq;
     2208  int i; int j; int m; int s;
     2209  m=0; i=1;
     2210  while((i<=size(S)) and (m==0))
     2211  {
     2212    if(typeof(S[i][2])=="list"){m=1;}
     2213    i++;
     2214  }
     2215  if(m==1){"Warning! grobcov has already extended bases"; return(S);}
     2216  if(size(GC[1])!=5){"Warning! extend make sense only when grobcov has been called with options 'rep',2,'ext',0"; " "; return();}
     2217  int repop=0;
     2218  int start3=timer;
     2219  int comment;
     2220  for(i=1;i<=size(L) div 2;i++)
     2221  {
     2222    if(L[2*i-1]=="comment"){comment=L[2*i];}
     2223    else
     2224    {
     2225      if(L[2*i-1]=="rep"){repop=L[2*i];}
     2226    }
     2227  }
     2228  poly leadc;
     2229  poly ext;
     2230  int te=0;
     2231  list SS;
     2232  def R=basering;
     2233  if (defined(@R)){te=1;}
     2234  else{setglobalrings();}
     2235  // Now extend
     2236  for (i=1;i<=size(S);i++)
     2237  {
     2238    m=size(S[i][2]);
     2239     for (j=1;j<=m;j++)
     2240    {
     2241      idp=S[i][4][1];
     2242      idq=S[i][4][2];
     2243      if (size(idp)>0)
     2244      {
     2245        leadc=leadcoef(S[i][2][j]);
     2246        kill ext;
     2247        def ext=extend0(S[i][2][j],idp,idq);
     2248        if (typeof(ext)=="poly")
     2249        {
     2250          S[i][2][j]=pnormalf(ext,idp,idq);
     2251        }
     2252        else
     2253        {
     2254          if(size(ext)==1)
     2255          {
     2256            S[i][2][j]=ext[1];
     2257          }
     2258          else
     2259          {
     2260            kill SS; list SS;
     2261            for(s=1;s<=size(ext);s++)
     2262            {
     2263              ext[s]=pnormalf(ext[s],idp,idq);
     2264            }
     2265            for(s=1;s<=size(S[i][2]);s++)
     2266            {
     2267              if(s!=j){SS[s]=S[i][2][s];}
     2268              else{SS[s]=ext;}
     2269            }
     2270            S[i][2]=SS;
     2271          }
     2272        }
     2273      }
     2274    }
     2275  }
     2276  // NOW representation of the segments by option repop
     2277  list Si; list nS;
     2278  if (repop==0)
     2279  {
     2280    for(i=1;i<=size(S);i++)
     2281    {
     2282      Si=list(S[i][1],S[i][2],S[i][3],S[i][5]);
     2283      nS[size(nS)+1]=Si;
     2284    }
     2285    S=nS;
     2286  }
     2287  else
     2288  {
     2289    if (repop==1)
     2290    {
     2291      for(i=1;i<=size(S);i++)
     2292      {
     2293        Si=list(S[i][1],S[i][2],S[i][4],S[i][5]);
     2294        nS[size(nS)+1]=Si;
     2295      }
     2296      S=nS;
     2297    }
     2298    else
     2299    {
     2300      for(i=1;i<=size(S);i++)
     2301      {
     2302        Si=list(S[i][1],S[i][2],S[i][3],S[i][4],S[i][5]);
     2303        nS[size(nS)+1]=Si;
     2304      }
     2305
     2306    }
     2307  }
     2308  if(comment>=1){"Time in extend = ",timer-start3;}
     2309  if(te==0){kill @R; kill @RP; kill @P;}
     2310  return(S);
     2311}
     2312example
     2313{
     2314  ring R=(0,a0,b0,c0,a1,b1,c1,a2,b2,c2),(x), dp;
     2315  short=0;
     2316  ideal S=a0*x^2+b0*x+c0,
     2317          a1*x^2+b1*x+c1,
     2318          a2*x^2+b2*x+c2;
     2319  "System S="; S;
     2320
     2321  def GCS=grobcov(S,"rep",2,"comment",1);
     2322  "grobcov(S,'rep',2,'comment',1)="; GCS;
     2323  def FGC=extend(GCS,"rep",0,"comment",1);
     2324  "Full representation="; FGC;
     2325}
     2326
     2327
     2328// nonzerodivisor
    60402329// input:
    60412330//    poly g in K[a],
    60422331//    list P=(p_1,..p_r) representing a minimal prime decomposition
    60432332// 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
    6046 static proc nonzerodivisor(poly gr, list Pr)
     2333//    poly f such that f notin p_i for all i and
     2334//           g-f in p_i for all i such that g notin p_i
     2335proc nonzerodivisor(poly gr, list Pr)
    60472336{
    60482337  def RR=basering;
    … …  
    60772366}
    60782367
     2368// deltai
    60792369// input:
    60802370//   int i:
    … …  
    60832373//   list (fr,fnr) of two polynomials that are equal on V(pi)
    60842374//       and fr=0 on V(P) \ V(pi), and fnr is nonzero on V(pj) for all j.
    6085 static proc deltai(int i, list LPr)
     2375proc deltai(int i, list LPr)
    60862376{
    60872377  def RR=basering;
    … …  
    61162406}
    61172407
     2408// combine
    61182409// input: a list of pairs ((p1,P1),..,(pr,Pr)) where
    61192410//    ideal pi is a prime component
    6120 //    poly Pi is the polynomial in K[a][x] on V(pi)\ V(Mi)
     2411//    poly Pi is the polynomial in Q[a][x] on V(pi)\ V(Mi)
    61212412//    (p1,..,pr) are the prime decomposition of the lpp-segment
    61222413//    list crep =(ideal ida,ideal idb): the Crep of the segment.
    … …  
    61242415// output:
    61252416//    poly P on an open and dense set of V(p_1 int ... p_r)
    6126 static proc combine(list L, ideal F)
     2417proc combine(list L, ideal F)
    61272418{
    61282419  // ATTENTION REVISE AND USE Pci and F
    … …  
    61332424    f=f+F[i]*L[i][2];
    61342425  }
    6135   f=elimconstfac(f);
     2426//   f=elimconstfac(f);
     2427  f=primepartZ(f);
    61362428  return(f);
    61372429}
    … …  
    61442436//   poly f2  where the factors of f in K[a] that are non-null on any component
    61452437//   have been dropped from f
    6146 static proc elimconstfac(poly f)
     2438proc elimconstfac(poly f)
    61472439{
    61482440  int cond; int i; int j; int t;
    … …  
    61502442  def RR=basering;
    61512443  setring(@R);
    6152   poly ff=imap(RR,f);
    6153   list l=factorize(ff,0);
     2444  def ff=imap(RR,f);
     2445  def l=factorize(ff,0);
    61542446  poly f1=1;
    61552447  for(i=2;i<=size(l[1]);i++)
    … …  
    61602452  def f2=imap(@R,f1);
    61612453  return(f2);
    6162 }
    6163 
     2454};
     2455
     2456// nullin
    61642457// input:
    6165 //   poly f:  a polynomial in K[a]
    6166 //   ideal P: an ideal in K[a]
     2458//   poly f:  a polynomial in Q[a]
     2459//   ideal P: an ideal in Q[a]
    61672460//   called from ring @R
    61682461// output:
    61692462//   t:  with value 1 if f reduces modulo P, 0 if not.
    6170 static proc nullin(poly f,ideal P)
     2463proc nullin(poly f,ideal P)
    61712464{
    61722465  int t;
    61732466  def RR=basering;
    61742467  setring(@P);
    6175   poly f0=imap(RR,f);
    6176   ideal P0=imap(RR,P);
     2468  def f0=imap(RR,f);
     2469  def P0=imap(RR,P);
    61772470  attrib(P0,"isSB",1);
    61782471  if (reduce(f0,P0,1)==0){t=1;}
    … …  
    61822475}
    61832476
    6184 static 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 
    61962477// monoms
    6197 static proc monoms(poly f)
     2478proc monoms(poly f)
    61982479{
    61992480  list L;
    6200   if (f!=0) { L[size(f)]=list();}
    62012481  poly lm; poly lc; poly lp; poly Q; poly mQ;
    62022482  def p=f;
    … …  
    62082488    lc=leadcoef(lm);
    62092489    lp=leadmonom(lm);
    6210     L[i]=list(lc,lp);
     2490    L[size(L)+1]=list(lc,lp);
    62112491    i++;
    62122492  }
    … …  
    62142494}
    62152495
     2496// extend0
    62162497// input:
    62172498//   poly f: a generic polynomial in the basis
    … …  
    62212502////      segments in the lpp-segment  NO MORE USED
    62222503// output:
    6223 static proc extend(poly f, ideal idp, ideal idq)
     2504proc extend0(poly f, ideal idp, ideal idq)
    62242505{
    62252506  matrix CC; poly Q; list NewMonoms;
    … …  
    62392520    {
    62402521      fout=NewMonoms[1][1][2,j]*L[1][2]+NewMonoms[1][1][1,j]*NewMonoms[1][2];
    6241       //fout=pnormalform(fout,idp,W);
     2522      //fout=pnormalf(fout,idp,W);
    62422523      if(ncols(NewMonoms[1][1])>1){idout[j]=fout;}
    62432524    }
    … …  
    62462527  else
    62472528  {
    6248     //int start=timer;
    62492529    list cfi;
    62502530    list coefs;
    … …  
    62732553}
    62742554
     2555// findindexpolys
    62752556// input:
    62762557//   list coefs=( (q11,..,q1r_1),..,(qs1,..,qsr_1) )
    … …  
    62802561//        each intvec v=(i_1,..,is) corresponds to a polynomial in the sheaf
    62812562//        that will be built from it in extend procedure.
    6282 static proc findindexpolys(list coefs)
     2563proc findindexpolys(list coefs)
    62832564{
    62842565  int i; int j; intvec numdens;
    … …  
    63162597  }
    63172598  combpolys=reform(combpolys,numdens);
    6318   setring RR;
     2599  setring(RR);
    63192600  return(combpolys);
    63202601}
    6321 
    63222602
    63232603// extendcoef: given Q,P in K[a] where P/Q specializes on an open and dense subset
    63242604//      of the whole V(p1 int...int pr), it returns a basis of the module
    63252605//      of all syzygies equivalent to P/Q,
    6326 static proc extendcoef(poly P, poly Q, ideal idp, ideal idq)
     2606proc extendcoef(poly P, poly Q, ideal idp, ideal idq)
    63272607{
    63282608  def RR=basering;
    … …  
    63392619  ideal PQ=Q0,-P0;
    63402620  module C=syz(PQ);
    6341   setring @P;
     2621  setring(@P);
    63422622  def idp1=imap(RR,idp);
    63432623  def idq1=imap(RR,idq);
    … …  
    63492629}
    63502630
     2631// selectregularfun
    63512632// input:
    63522633//   list L of the polynomials matrix CC
    … …  
    63542635//   ideal N, ideal M: ideals representing the locally closed set V(N)\V(M)
    63552636// assume to work in @P
    6356 static proc selectregularfun(matrix CC, ideal NN, ideal MM)
     2637proc selectregularfun(matrix CC, ideal NN, ideal MM)
    63572638{
    63582639  int numcombused;
    63592640  def RR=basering;
    6360   setring @P;
     2641  setring(@P);
    63612642  def C=imap(RR,CC);
    63622643  def N=imap(RR,NN);
    … …  
    63952676      T=list(ci,PtoCrep(Prep(N1,M1)));
    63962677      LL[size(LL)+1]=T;
    6397       if(equalideals(T[2][1],ideal(1))==1){te=1; break;}
    6398     }
    6399     if(te==1){break;}
     2678      if(equalideals(T[2][1],ideal(1))){te=1; break;}
     2679    }
     2680    if(te){break;}
    64002681  }
    64012682  ci=T[1];
    64022683  def Cs=submat(C1,1..2,ci);
    6403   setring RR;
     2684  setring(RR);
    64042685  return(imap(@P,Cs));
    64052686}
    64062687
     2688// searchinlist
    64072689// input:
    64082690//   intvec c:
    … …  
    64112693// output:
    64122694//   object T with index c
    6413 static proc searchinlist(intvec c,list L)
     2695proc searchinlist(intvec c,list L)
    64142696{
    64152697  int i; list T;
    … …  
    64252707}
    64262708
    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.
    6437 static 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 
    64952709// comb: the list of combinations of elements (1,..n) of order p
    6496 static proc comb(int n, int p)
     2710proc comb(int n, int p)
    64972711{
    64982712  list L; list L0;
    … …  
    65452759// The selection is done to obtian the minimal number of elements
    65462760//    of the sheaf that specializes to non-null everywhere.
    6547 static proc selectminsheaves(list L)
     2761proc selectminsheaves(list L)
    65482762{
    65492763  list C=allsheaves(L);
    … …  
    65512765}
    65522766
     2767// smsheaves
    65532768// Input:
    65542769//   list C of all the combrep
    … …  
    65572772//   list LL of the subsets of C that cover all the subsegments
    65582773//   (the union of the corresponding L(C) has all 1).
    6559 static proc smsheaves(list C, list L)
     2774proc smsheaves(list C, list L)
    65602775{
    65612776  int i; int i0; intvec W;
    … …  
    65972812//    LL is the list of all combrep
    65982813//    LLS is the list of intvec of the corresponding elements of LL
    6599 static proc allsheaves(list L)
     2814proc allsheaves(list L)
    66002815{
    66012816  intvec V; list LL; intvec W; int r; intvec U;
    … …  
    66322847// Output:
    66332848//   int nor: the nuber of 1 of v in the positions given by pos.
    6634 static proc numones(intvec v, intvec pos)
     2849proc numones(intvec v, intvec pos)
    66352850{
    66362851  int i; int n;
    … …  
    66422857}
    66432858
     2859// pos
    66442860// Input:  intvec p of zeros and ones
    66452861// Output: intvec W of the positions where p has ones.
    6646 static proc pos(intvec p)
     2862proc pos(intvec p)
    66472863{
    66482864  int i;
    … …  
    66622878//   intvec pp: of zeroes and ones, where a 0 stays in pp[i] if either
    66632879//   already p[i]==0 or c[i]==1.
    6664 static proc actualize(intvec p, intvec c)
     2880proc actualize(intvec p, intvec c)
    66652881{
    66662882  int i; intvec pp=p;
    … …  
    66762892// Output: L=(v_1,..,v_p) where p=prod_j=1^i (n_j)
    66772893//    is the list of all intvec v_j=(v_j1,..,v_ji) where 1<=v_jk<=n_i
    6678 static proc combrep(intvec V)
     2894proc combrep(intvec V)
    66792895{
    66802896  list L; list LL;
    … …  
    67052921}
    67062922
    6707 static proc reducemodN(poly f,ideal N)
     2923proc reducemodN(poly f,ideal E)
    67082924{
    67092925  def RR=basering;
    67102926  setring(@RPt);
    67112927  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);
     2928  def Ea=imap(RR,E);
     2929  attrib(Ea,"isSB",1);
     2930  // option(redSB);
     2931  // Ea=std(Ea);
     2932  fa=reduce(fa,Ea);
    67172933  setring(RR);
    67182934  def f1=imap(@RPt,fa);
    … …  
    67202936}
    67212937
    6722 // computes the intersection of the ideals in S in @P
    6723 static proc intersp(list S)
     2938// intersp: computes the intersection of the ideals in S in @P
     2939proc intersp(list S)
    67242940{
    67252941  def RR=basering;
    … …  
    67322948}
    67332949
    6734 static proc radicalmember(poly f,ideal ida)
     2950// radicalmember
     2951proc radicalmember(poly f,ideal ida)
    67352952{
    67362953  int te;
    67372954  def RR=basering;
    67382955  setring(@P);
    6739   poly fp=imap(RR,f);
    6740   ideal idap=imap(RR,ida);
     2956  def fp=imap(RR,f);
     2957  def idap=imap(RR,ida);
    67412958  poly @t;
    67422959  ring H=0,@t,dp;
    … …  
    67442961  setring(PH);
    67452962  def fH=imap(@P,fp);
    6746   ideal idaH=imap(@P,idap);
    6747   idaH[ncols(idaH)+1]=1-@t*fH;
     2963  def idaH=imap(@P,idap);
     2964  idaH[size(idaH)+1]=1-@t*fH;
    67482965  option(redSB);
    6749   ideal G=std(idaH);
    6750   //"G="; G;
     2966  def G=std(idaH);
    67512967  if (G==1){te=1;} else {te=0;}
    67522968  setring(RR);
    … …  
    67542970}
    67552971
    6756 // returns 1 if the poly f is nonnull on V(N)\V(M), 0 otherwise.
    6757 static proc NonNull(poly f, ideal N, ideal M)
     2972// NonNull: returns 1 if the poly f is nonnull on V(E)\V(N), 0 otherwise.
     2973proc NonNull(poly f, ideal E, ideal N)
    67582974{
    67592975  int te=1; int i;
    67602976  def RR=basering;
    67612977  setring(@P);
    6762   poly fp=imap(RR,f);
    6763   ideal Np=imap(RR,N);
    6764   ideal Mp=imap(RR,M);
     2978  def fp=imap(RR,f);
     2979  def Ep=imap(RR,E);
     2980  def Np=imap(RR,N);
    67652981  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;
     2982  ideal Ef=Ep+fp;
     2983  for (i=1;i<=size(Np);i++)
     2984  {
     2985    te=radicalmember(Np[i],Ef);
     2986    if (te==0){break;}
     2987  }
     2988  setring(RR);
    67732989  return(te);
    67742990}
    67752991
     2992// selectextendcoef
    67762993// input:
    67772994//    matrix CC: CC=(p_a1 .. p_ar_a)
    … …  
    67853002//            points where the q's are null on S.
    67863003//            The elements of caout are of the form (p,q,prep);
    6787 static proc selectextendcoef(matrix CC, ideal ida, ideal idb)
     3004proc selectextendcoef(matrix CC, ideal ida, ideal idb)
    67883005{
    67893006  def RR=basering;
    67903007  setring(@P);
    67913008  def ca=imap(RR,CC);
    6792   def N0=imap(RR,ida);
    6793   ideal N;
    6794   def M=imap(RR,idb);
     3009  def E0=imap(RR,ida);
     3010  ideal E;
     3011  def N=imap(RR,idb);
    67953012  int r=ncols(ca);
    67963013  int i; int te=1; list com; int j; int k; intvec c; list prep;
    67973014  list cs; list caout;
    67983015  i=1;
    6799   while ((i<=r) and (te==1))
     3016  while ((i<=r) and (te))
    68003017  {
    68013018    com=comb(r,i);
    68023019    j=1;
    6803     while((j<=size(com)) and (te==1))
    6804     {
    6805       N=N0;
     3020    while((j<=size(com)) and (te))
     3021    {
     3022      E=E0;
    68063023      c=com[j];
    68073024      for (k=1;k<=i;k++)
    68083025      {
    6809         N=N+ca[2,c[k]];
    6810       }
    6811       prep=Prep(N,M);
     3026        E=E+ca[2,c[k]];
     3027      }
     3028      prep=Prep(E,N);
    68123029      if (i==1)
    68133030      {
    … …  
    68263043    i++;
    68273044  }
    6828   if (te==1){"error: extendcoef does not extend to the whole S";}
     3045  if (te){"error: extendcoef does not extend to the whole S";}
    68293046  setring(RR);
    68303047  return(imap(@P,caout));
    … …  
    68323049
    68333050// input:
    6834 //   ideal N1: in some basering (depends only on the parameters)
    6835 //   ideal N2: in some basering (depends only on the parameters)
     3051//   ideal E1: in some basering (depends only on the parameters)
     3052//   ideal E2: in some basering (depends only on the parameters)
    68363053// output:
    6837 //   ideal Np=N1+N2; computed in P
    6838 static proc plusP(ideal N1,ideal N2)
     3054//   ideal Ep=E1+E2; computed in P
     3055proc plusP(ideal E1,ideal E2)
    68393056{
    68403057  def RR=basering;
    68413058  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 
     3059  def E1p=imap(RR,E1);
     3060  def E2p=imap(RR,E2);
     3061  def Ep=E1p+E2p;
     3062  setring(RR);
     3063  return(imap(@P,Ep));
     3064}
     3065
     3066// reform
    68493067// input:
    68503068//   list combpolys: (v1,..,vs)
    … …  
    68543072//      All the vi without zeroes are in outcomb, and those with zeroes are
    68553073//         combined to form new intvec with the rest
    6856 static proc reform(list combpolys, intvec numdens)
     3074proc reform(list combpolys, intvec numdens)
    68573075{
    68583076  list combp0; list combp1; int i; int j; int k; int l; list rest; intvec notfree;
    … …  
    68613079  for(i=1;i<=size(combpolys);i++)
    68623080  {
    6863     if(memberpos(0,combpolys[i])[1]==1)
     3081    if(memberpos(0,combpolys[i])[1])
    68643082    {
    68653083      combp0[size(combp0)+1]=combpolys[i];
    … …  
    69293147}
    69303148
    6931 static proc nonnullCrep(poly f0,ideal ida0,ideal idb0)
     3149// nonnullCrep
     3150proc nonnullCrep(poly f0,ideal ida0,ideal idb0)
    69323151{
    69333152  int i;
    … …  
    69503169}
    69513170
     3171// precombint
    69523172// input:  L: list of ideals (works in @P)
    69533173// output: F0: ideal of polys. F0[i] is a poly in the intersection of
    … …  
    69553175//             L=(p1,..,ps);  F0=(f1,..,fs);
    69563176//             F0[i] \in intersect_{j#i} p_i
    6957 static proc precombint(list L)
     3177proc precombint(list L)
    69583178{
    69593179  int i; int j; int tes;
    … …  
    69813201  {
    69823202    tes=1; j=0;
    6983     while((tes==1) and (j<size(L3[i])))
     3203    while((tes) and (j<size(L3[i])))
    69843204    {
    69853205      j++;
    … …  
    69883208      if(reduce(L3[i][j],L0[i])!=0){tes=0; F[i]=L3[i][j];}
    69893209    }
    6990     if (tes==1){"ERROR a polynomial in all p_j except p_i was not found";}
     3210    if (tes){"ERROR a polynomial in all p_j except p_i was not found";}
    69913211  }
    69923212  setring(RR);
    … …  
    70033223//                     vv[2]=selind, the index for which the generic basis
    70043224//                     already specializes well if combine is not to be used (vv[1]=1).
    7005 static proc precombinediscussion(L,crep)
     3225proc precombinediscussion(L,crep)
    70063226{
    70073227  int tes=1; int selind; int i1; int j1; poly p; poly lcp; intvec vv;
    … …  
    70143234
    70153235
    7016     if(nonnullCrep(lcp,crep[1],crep[2])==1)
     3236    if(nonnullCrep(lcp,crep[1],crep[2]))
    70173237    {
    70183238      for(j1=1;j1<=size(L);j1++)
    … …  
    70253245    }
    70263246    else{tes=0;}
    7027     if(tes==1){selind=i1; break;}
     3247    if(tes){selind=i1; break;}
    70283248  }
    70293249  vv=tes,selind;
    … …  
    70313251}
    70323252
    7033 // only if N=0 and W=1
    7034 proc 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].
    7051 RETURN:   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
    7057 NOTE:     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.
    7060 KEYWORDS: generic segment, automatic discovery of geometric theorems,
    7061 EXAMPLE:  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 }
    7121 example
    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 
    71363253// minAssGTZ eliminating denominators
    7137 static proc minGTZ(ideal N);
     3254proc minGTZ(ideal N);
    71383255{
    71393256  int i; int j;
    … …  
    71493266}
    71503267
    7151 proc 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)).
    7183 RETURN:   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.
    7187 NOTE:     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.
    7190 KEYWORDS: grobcov, generic segment, automatic discovery of geometric theorems,
    7191 EXAMPLE:  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;}
     3268//********************* Begin KapurSunWang *************************
     3269
     3270// inconsistent
     3271// Input:
     3272//   ideal E: of null conditions
     3273//   ideal N: of non-null conditions representing V(E)\V(N)
     3274// Output:
     3275//   1 if V(E) \V(N) = empty
     3276//   0 if not
     3277proc inconsistent(ideal E, ideal N)
     3278{
     3279  int j;
     3280  int te=1;
     3281  def R=basering;
     3282  setring(@P);
     3283  def EP=imap(R,E);
     3284  def NP=imap(R,N);
     3285  poly @t;
     3286  ring H=0,@t,dp;
     3287  def RH=@P+H;
     3288  setring(RH);
     3289  def EH=imap(@P,EP);
     3290  def NH=imap(@P,NP);
     3291  ideal G;
     3292  j=1;
     3293  while((te==1) and j<=size(NH))
     3294  {
     3295    G=EH+(1-@t*NH[j]);
     3296    option(redSB);
     3297    G=std(G);
     3298    if (G[1]!=1){te=0;}
     3299    j++;
     3300  }
     3301  setring(R);
     3302  return(te);
     3303}
     3304
     3305// MDBasis: Minimal Dickson Basis
     3306proc MDBasis(ideal G)
     3307{
     3308  int i; int j; int te=1;
     3309  G=sortideal(G);
     3310  ideal MD=G[1];
     3311  poly lm;
     3312  for (i=2;i<=size(G);i++)
     3313  {
     3314    te=1;
     3315    lm=leadmonom(G[i]);
     3316    j=1;
     3317    while ((te==1) and (j<=size(MD)))
     3318    {
     3319      if (lm/leadmonom(MD[j])!=0){te=0;}
     3320      j++;
     3321    }
     3322    if (te==1)
     3323    {
     3324      MD[size(MD)+1]=(G[i]);
     3325    }
     3326  }
     3327  return(MD);
     3328}
     3329
     3330// primepartZ
     3331proc primepartZ(poly f);
     3332{
     3333  def R=basering;
     3334  def cp=content(f);
     3335  def fp=f/cp;
     3336  return(fp);
     3337}
     3338
     3339// LCMLC
     3340proc LCMLC(ideal H)
     3341{
     3342  int i;
     3343  def R=basering;
     3344  setring(@RP);
     3345  def HH=imap(R,H);
     3346  poly h=1;
     3347  for (i=1;i<=size(HH);i++)
     3348  {
     3349    h=lcm(h,HH[i]);
     3350  }
     3351  setring(R);
     3352  def hh=imap(@RP,h);
     3353  return(hh);
     3354}
     3355
     3356// KSW: Kapur-Sun-Wang algorithm for computing a CGS
     3357// Input:
     3358//   F:   parametric ideal to be discussed
     3359//   Options:
     3360//     "out",0 Transforms the description of the segments into
     3361//     canonical P-representation form.
     3362//     "out",1 Original KSW routine describing the segments as
     3363//     difference of varieties
     3364//   The ideal must be defined on C[parameters][variables]
     3365// Output:
     3366//   With option "out",0 :
     3367//     ((lpp,
     3368//       (1,B,((p_1,(p_11,..,p_1k_1)),..,(p_s,(p_s1,..,p_sk_s)))),
     3369//       string(lpp)
     3370//      )
     3371//      ,..,
     3372//      (lpp,
     3373//       (k,B,((p_1,(p_11,..,p_1k_1)),..,(p_s,(p_s1,..,p_sk_s)))),
     3374//       string(lpp))
     3375//      )
     3376//     )
     3377//   With option "out",1 ((default, original KSW) (shorter to be computed,
     3378//                    but without canonical description of the segments.
     3379//     ((B,E,N),..,(B,E,N))
     3380proc KSW(ideal F, list #)
     3381{
     3382  setglobalrings();
     3383  int start=timer;
     3384  ideal E=ideal(0);
     3385  ideal N=ideal(1);
     3386  int comment=0;
     3387  int out=1;
     3388  int i;
     3389  def L=#;
     3390  if (size(L)>0)
     3391  {
     3392    for (i=1;i<=size(L)/2;i++)
     3393    {
     3394      if (L[2*i-1]=="null"){E=L[2*i];}
    72013395      else
    72023396      {
    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   }
     3397        if (L[2*i-1]=="nonnull"){N=L[2*i];}
     3398        else
     3399        {
     3400          if (L[2*i-1]=="comment"){comment=L[2*i];}
     3401          else
     3402          {
     3403            if (L[2*i-1]=="out"){out=L[2*i];}
     3404          }
     3405        }
     3406      }
     3407    }
     3408  }
     3409  if (comment>0){"Begin KSW with null = ",string(E)," nonnull = ",string(N);}
     3410  def CG=KSW0(F,E,N,comment);
     3411  if (comment>0)
     3412  {
     3413    "Number of segments in KSW (total) = ",size(CG);
     3414    "Time in KSW = ",timer-start;
     3415  }
     3416  if(out==0)
     3417  {
     3418    CG=KSWtocgsdr(CG);
     3419    CG=groupKSWsegments(CG);
     3420    if (comment>0)
     3421    {
     3422      "Number of lpp segments = ",size(CG);
     3423      "Time in KSW + group + Prep = ",timer-start;
     3424    }
     3425  }
     3426  if(defined(@P)){kill @P; kill @R; kill @RP;}
     3427  return(CG);
     3428}
     3429
     3430// sqf
     3431// This is for releases of Singular before 3-5-1
     3432// proc sqf(poly f)
     3433// {
     3434//  def RR=basering;
     3435//  setring(@P);
     3436//  def ff=imap(RR,f);
     3437//  def G=sqrfree(ff);
     3438//  poly fff=1;
     3439//  int i;
     3440//  for (i=1;i<=size(G);i++)
     3441//  {
     3442//    fff=fff*G[i];
     3443//  }
     3444//  setring(RR);
     3445//   def ffff=imap(@P,fff);
     3446//   return(ffff);
     3447// }
     3448
     3449// sqf
     3450proc sqf(poly f)
     3451{
     3452  def RR=basering;
     3453  setring(@P);
     3454  def ff=imap(RR,f);
     3455  poly fff=sqrfree(ff,3);
     3456  setring(RR);
     3457  def ffff=imap(@P,fff);
     3458  return(ffff);
     3459}
     3460
     3461
     3462
     3463// KSW0: Kapur-Sun-Wang algorithm for computing a CGS, called by KSW
     3464// Input:
     3465//   F:   parametric ideal to be discussed
     3466//   Options:
     3467//   The ideal must be defined on C[parameters][variables]
     3468// Output:
     3469proc KSW0(ideal F, ideal E, ideal N, int comment)
     3470{
     3471  def R=basering;
     3472  int i; int j; list emp;
     3473  list CGS;
     3474  ideal N0;
     3475  for (i=1;i<=size(N);i++)
     3476  {
     3477    N0[i]=sqf(N[i]);
     3478  }
     3479  ideal E0;
     3480  for (i=1;i<=size(E);i++)
     3481  {
     3482    E0[i]=sqf(leadcoef(E[i]));
     3483  }
     3484  setring(@P);
     3485  ideal E1=imap(R,E0);
     3486  E1=std(E1);
     3487  ideal N1=imap(R,N0);
     3488  N1=std(N1);
     3489  setring(R);
     3490  E0=imap(@P,E1);
     3491  N0=imap(@P,N1);
     3492//   E0=elimrepeated(E0);
     3493//   N0=elimrepeated(N0);
     3494  if (inconsistent(E0,N0)==1)
     3495  {
     3496    return(emp);
     3497  }
     3498  setring(@RP);
     3499  def FRP=imap(R,F);
     3500  def ERP=imap(R,E);
     3501  FRP=FRP+ERP;
     3502  option(redSB);
     3503  def GRP=std(FRP);
     3504  setring(R);
     3505  def G=imap(@RP,GRP);
     3506  if (memberpos(1,G)[1]==1)
     3507  {
     3508    if(comment>1){"Basis 1 is found"; E; N;}
     3509    return(E0,N0,ideal(1));
     3510  }
     3511  ideal Gr; ideal Gm; ideal GM;
     3512  for (i=1;i<=size(G);i++)
     3513  {
     3514    if (variables(G[i])[1]==0){Gr[size(Gr)+1]=G[i];}
     3515    else{Gm[size(Gm)+1]=G[i];}
     3516  }
     3517  ideal Gr0;
     3518  for (i=1;i<=size(Gr);i++)
     3519  {
     3520    Gr0[i]=sqf(Gr[i]);
     3521  }
     3522
     3523
     3524  Gr=elimrepeated(Gr0);
     3525  ideal GrN;
     3526  for (i=1;i<=size(Gr);i++)
     3527   {
     3528    for (j=1;j<=size(N0);j++)
     3529    {
     3530      GrN[size(GrN)+1]=sqf(Gr[i]*N0[j]);
     3531    }
     3532  }
     3533  if (inconsistent(E,GrN)){;}
    72223534  else
    72233535  {
    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   }
     3536    if(comment>1){"Basis 1 is found in a branch with arguments"; E; GrN;}
     3537    CGS[size(CGS)+1]=list(E,GrN,ideal(1));
     3538  }
     3539  if (inconsistent(Gr,N0)){return(CGS);}
     3540  GM=Gm;
     3541  Gm=MDBasis(Gm);
     3542  ideal H;
     3543  for (i=1;i<=size(Gm);i++)
     3544  {
     3545    H[i]=sqf(leadcoef(Gm[i]));
     3546  }
     3547  H=facvar(H);
     3548  poly h=sqf(LCMLC(H));
     3549  if(comment>1){"H = "; H; "h = "; h;}
     3550  ideal Nh=N0;
     3551  if(size(N0)==0){Nh=h;}
    72323552  else
    72333553  {
    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 }
    7251 example
    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 
    7266 proc 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.
    7293 RETURN:   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 
    7343 NOTE:     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.
    7346 KEYWORDS: CGS, cgsdr, buildtree, buildtreetoMaple, disjoint, reduced,
    7347           comprehensive Groebner system
    7348 EXAMPLE:  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);}
     3554    for (i=1;i<=size(N0);i++)
     3555    {
     3556      Nh[i]=sqf(N0[i]*h);
     3557    }
     3558  }
     3559  if (inconsistent(Gr,Nh)){;}
    73573560  else
    73583561  {
    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 }
    7375 example
    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 
    7386 proc 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.
    7432 RETURN:   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 
    7509 NOTE:     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.
    7512 KEYWORDS: Groebner cover, grobcov, parametric ideal, canonical, discussion of
    7513           parametric ideal.
    7514 EXAMPLE:  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)
     3562    CGS[size(CGS)+1]=list(Gr,Nh,Gm);
     3563  }
     3564  poly hc=1;
     3565  list KS;
     3566  ideal GrHi;
     3567  for (i=1;i<=size(H);i++)
     3568  {
     3569    kill GrHi;
     3570    ideal GrHi;
     3571    Nh=N0;
     3572    if (i>1){hc=sqf(hc*H[i-1]);}
     3573    for (j=1;j<=size(N0);j++){Nh[j]=sqf(N0[j]*hc);}
     3574    if (equalideals(Gr,ideal(0))==1){GrHi=H[i];}
     3575    else {GrHi=Gr,H[i];}
     3576//     else {for (j=1;j<=size(Gr);j++){GrHi[size(GrHi)+1]=Gr[j]*H[i];}}
     3577    if(comment>1){"Call to KSW with arguments "; GM; GrHi;  Nh;}
     3578    KS=KSW0(GM,GrHi,Nh,comment);
     3579    for (j=1;j<=size(KS);j++)
     3580    {
     3581      CGS[size(CGS)+1]=KS[j];
     3582    }
     3583    if(comment>1){"CGS after KSW = "; CGS;}
     3584  }
     3585  return(CGS);
     3586}
     3587
     3588// KSWtocgsdr
     3589proc KSWtocgsdr(list L)
     3590{
     3591  int i; list CG; ideal B; ideal lpp; int j; list NKrep;
     3592  for(i=1;i<=size(L);i++)
     3593  {
     3594    B=redgbn(L[i][3],L[i][1],L[i][2]);
     3595    lpp=ideal(0);
     3596    for(j=1;j<=size(B);j++)
     3597    {
     3598      lpp[j]=leadmonom(B[j]);
     3599    }
     3600    NKrep=KtoPrep(L[i][1],L[i][2]);
     3601    CG[i]=list(lpp,B,NKrep);
     3602  }
     3603  return(CG);
     3604}
     3605
     3606// KtoPrep
     3607// Computes the P-representaion of a K-representation (N,W) of a set
     3608// input:
     3609//    ideal E (null conditions)
     3610//    ideal N (non-null conditions ideal)
     3611// output:
     3612//    the ((p_1,(p_11,..,p_1k_1)),..,(p_r,(p_r1,..,p_rk_r)));
     3613//    the Prep of V(N) \ V(W)
     3614proc KtoPrep(ideal N, ideal W)
     3615{
     3616  int i; int j;
     3617  if (N[1]==1)
     3618  {
     3619    L0[1]=list(ideal(1),list(ideal(1)));
     3620    return(L0);
     3621  }
     3622  def RR=basering;
     3623  setring(@P);
     3624  ideal B; int te; poly f;
     3625  ideal Np=imap(RR,N);
     3626  ideal Wp=imap(RR,W);
     3627  list L;
     3628  list L0; list T0;
     3629  L0=minGTZ(Np);
     3630  for(j=1;j<=size(L0);j++)
     3631  {
     3632    option(redSB);
     3633    L0[j]=std(L0[j]);
     3634  }
     3635  for(i=1;i<=size(L0);i++)
     3636  {
     3637    if(inconsistent(L0[i],Wp)==0)
     3638    {
     3639      B=L0[i]+Wp;
     3640      T0=minGTZ(B);
     3641      option(redSB);
     3642      for(j=1;j<=size(T0);j++)
     3643      {
     3644        T0[j]=std(T0[j]);
     3645      }
     3646      L[size(L)+1]=list(L0[i],T0);
     3647    }
     3648  }
     3649  setring(RR);
     3650  def LL=imap(@P,L);
     3651  return(LL);
     3652}
     3653
     3654// groupKSWsegments
     3655// input:  the list of vertices of KSW
     3656// output: the same terminal vertices grouped by lpp
     3657proc groupKSWsegments(list T)
     3658{
     3659  int i; int j;
     3660  list L;
     3661  list lpp; list lppor;
     3662  list kk;
     3663  lpp[1]=T[1][1]; j=1;
     3664  lppor[1]=intvec(1);
     3665  for(i=2;i<=size(T);i++)
     3666  {
     3667    kk=memberpos(T[i][1],lpp);
     3668    if(kk[1]==0){j++; lpp[j]=T[i][1]; lppor[j]=intvec(i);}
     3669    else{lppor[kk[2]][size(lppor[kk[2]])+1]=i;}
     3670  }
     3671  list ll;
     3672  for (j=1;j<=size(lpp);j++)
     3673  {
     3674    kill ll; list ll;
     3675    for(i=1;i<=size(lppor[j]);i++)
     3676    {
     3677      ll[size(ll)+1]=list(i,T[lppor[j][i]][2],T[lppor[j][i]][3]);
     3678    }
     3679    L[j]=list(lpp[j],ll,string(lpp[j]));
     3680  }
     3681  return(L);
     3682}
     3683
     3684//********************* End KapurSunWang *************************
     3685;
     3686//********************* Begin locus2d ****************************
     3687
     3688// selfindimsols
     3689// auxilliary routine called by locus2d
     3690// input:  L the list of the Grobner Cover
     3691// output: S the list of the union of segments where only a finite number
     3692//         of solutions exists.
     3693//         Supposed to be the set of points of the parameter space with
     3694//         non degenerate solutions, for example in
     3695//         automatic discovering of geometric theorems
     3696proc selfindimsols(list L)
     3697{
     3698  int te=0;
     3699  if (defined(@R)){te=1;}
     3700  if(te==0){setglobalrings();}
     3701  int i; int j;
     3702  ideal v=variables(L[1][2]);
     3703  ideal vv;
     3704  for(i=2;i<=size(L);i++)
     3705  {
     3706    vv=variables(L[i][2]);
     3707    for(j=1;j<=size(vv);j++)
     3708    {
     3709      if(memberpos(vv[j],v)[1]==0)
     3710      {
     3711        v[size(v)+1]=vv[j];
     3712      }
     3713    }
     3714  }
     3715  v=elimintfromideal(v);
     3716  int nvartot=size(v);
     3717  ideal lpp;
     3718  int isovarlpp;
     3719  ideal empty;
     3720  list LL;
     3721  ideal B;
     3722  list SL;
     3723  for (i=1;i<=size(L);i++)
     3724  {
     3725    lpp=L[i][1];
     3726    isovarlpp=0;
     3727    for (j=1;j<=size(lpp);j++)
     3728    {
     3729      if (size(variables(lpp[j]))==1)
     3730      {
     3731        isovarlpp=isovarlpp+1;
     3732      }
     3733    }
     3734    if (isovarlpp==nvartot)
     3735    {
     3736      for(j=1;j<=size(L[i][3]);j++)
     3737      {
     3738        B=L[i][2],L[i][3][j][1];
     3739        if(size(L[i][3][j][1])==1)
    75743740        {
    7575           if(size(idq)!=0){Cua[size(Cua)+1]=list(idp,idq);}
    7576           kill idq; list idq;
    7577           idp=T[i][3];
     3741          if(indepparameters(B))
     3742          {
     3743            SL=L[i][3][j];
     3744            SL[3]="Special";
     3745            LL[size(LL)+1]=SL;
     3746          }
     3747          else
     3748          {
     3749            LL[size(LL)+1]=L[i][3][j];
     3750          }
    75783751        }
    75793752        else
    75803753        {
    7581           idq[size(idq)+1]=T[i][3];
     3754          LL[size(LL)+1]=L[i][3][j];
    75823755        }
    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   }
     3756      }
     3757    }
     3758  }
     3759  if(te==0){kill @R; kill @P; kill @RP};
     3760  return(LL);
     3761}
     3762
     3763// locus2d: Special routine for determining the locus of points
     3764// of a two dimensional object. Given an ideal J with two
     3765// parameters (a,b) and so many variables as needed, representing
     3766// the system determining the locus of points (a,b) who verify
     3767// certain geometrical properties, computing the grobcov of
     3768// J and applying to it locus2d, determines the locus.
     3769// input:
     3770//    list GC, the output of grobcov
     3771// output:
     3772//    list, the locus of points of the parameter-space
     3773//          for which the number of solutions in the variables
     3774//          is finite.
     3775//          If some component corresponds to a fixed single
     3776//          solution in the variables but to a curve of the
     3777//          parameter-sapace, then "Special" stands as
     3778//          the third element of the component
     3779//    ((p1,(p11,..p1s_1)),..,(pk,(pk1,..pks_k))
     3780//    Possibly some component can be  (p1,(p11,..p1s_1),"Special")
     3781//    These components of the locus correspond to locus curves
     3782//    determined by a single or a finite number of points of
     3783//    the geometrical construction.
     3784proc locus2d(list GC)
     3785"USAGE:   locus2d(G);
     3786          The argument must be the grobcov of a two dimensional
     3787          locus parametrical system with two parameters (a,b)
     3788          and so many variables as needed, representing the locus
     3789          points (a,b) who verify certain geometrical properties.
     3790          Possibly some component can be  (p1,(p11,..p1s_1),'Special')
     3791          These components of the locus correspond to locus curves
     3792          determined by a single or a finite number of points of
     3793          the geometrical construction.
     3794RETURN:   The two dimensional locus.
     3795NOTE:     It can only be called after computing the grobcov of the
     3796          parametrical ideal in generic representation ('ext',0),
     3797          which is the default.
     3798          The basering R, must be of the form Q[a,b][x,y,..].
     3799KEYWORDS: geometrical locus, locus, loci.
     3800EXAMPLE:  locus2d; shows an example"
     3801{
     3802  def R=basering;
     3803  setglobalrings();
     3804  def LL=selfindimsols(GC);
     3805  setring(@P);
     3806  def L=imap(R,LL);
     3807  int i; int j; int k; int n;
     3808  list LL;
     3809  intvec Lprals;
     3810  intvec Ldep;
     3811  list empty;
     3812  poly f;
     3813  list Ladd;
     3814  intvec Lp;
     3815  ideal N;
     3816  intvec si;
     3817  intvec sj;
     3818  intvec elimin;
     3819  for(i=1;i<=size(L);i++)
     3820  {
     3821    if(size(L[i][1])==1)
     3822    {
     3823      if(Lprals==intvec(0)){Lprals=i;}
     3824      else{Lprals=Lprals,i;}
     3825    }
     3826    else
     3827    {
     3828      if(Ldep==intvec(0)){Ldep=i;}
     3829      else{Ldep=Ldep,i;}
     3830    }
     3831  }
     3832  for(i=1;i<=size(Lprals);i++)
     3833  {
     3834    Lp=Lprals[i];
     3835    if(Ldep!=0)
     3836    {
     3837      for(j=1;j<=size(Ldep);j++)
     3838      {
     3839        N=L[Ldep[j]][1];
     3840        attrib(N,"isSB",1);
     3841        f=reduce(L[Lprals[i]][1][1],N);
     3842        if(f==0)
     3843        {
     3844          Lp=Lp,Ldep[j];
     3845        }
     3846      }
     3847    }
     3848    Ladd[size(Ladd)+1]=Lp;
     3849  }
     3850  list Lfi;
     3851  list La;
     3852  list Lb;
     3853  for (i=1;i<=size(Ladd);i++)
     3854  {
     3855    si=Ladd[i][1];
     3856    n=size(L[si[1]][2]);
     3857    kill elimin;
     3858    intvec elimin;
     3859    for (j=2;j<=size(Ladd[i]);j++)
     3860    {
     3861      sj=Ladd[i][j];
     3862      for(k=1;k<=n;k++)
     3863      {
     3864        if (equalideals(L[sj][1],L[si[1]][2][k])==1)
     3865        {
     3866          if(elimin==intvec(0)){elimin=k;}
     3867          else{elimin=elimin,k;}
     3868        }
     3869      }
     3870    }
     3871    kill Lb; list Lb;
     3872    for (k=1;k<=n;k++)
     3873    {
     3874      if (not(memberpos(k,elimin)[1]))
     3875      {
     3876        Lb[size(Lb)+1]=L[si[1]][2][k];
     3877      }
     3878    }
     3879    if (size(Lb)==0){Lb=ideal(1);}
     3880    La=list(L[si[1]][1],Lb);
     3881    if(size(L[si[1]])==3){La[3]=L[si[1]][3];}
     3882    Lfi[size(Lfi)+1]=La;
     3883  }
     3884  setring(R);
     3885  list Lout=imap(@P,Lfi);
     3886  kill @R; kill @RP; kill @P;
     3887  return(Lout);
    75983888}
    75993889example
    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 }
     3890{"EXAMPLE:"; echo = 2;
     3891  ring R=(0,a,b),(x,y),dp;
     3892  short=0;
     3893  ideal H=x^2+y^2-4,(b-2)*x-a*y+2*a,(a-x)^2+(b-y)^2-1;
     3894  def G=grobcov(H);
     3895  "grobcov(H)="; G; " ";
     3896  def Gp=locus2d(G);
     3897  "locus2d(G)="; Gp;
     3898}
     3899
     3900// locus2dto: Transforms the output of locus2d to a string that
     3901//    can be reed from different computational systems.
     3902// input:
     3903//   list L: The output of locus2d
     3904// output:
     3905//   string s: The output of locus2d converted to a string readable
     3906//             by other programs
     3907proc locus2dto(list L)
     3908"USAGE:   locus2dto(G);
     3909          The argument must be the output of locus2d  of a two dimensional
     3910          locus parametrical system with two parameters (a,b)
     3911          and so many variables as needed, representing the locus
     3912          points (a,b) who verify certain geometrical properties.
     3913          It transforms the output to a string in standard form
     3914          readable in many languages (Geogebra).
     3915
     3916RETURN: The two dimensional locus in string standard form
     3917NOTE:     It can only be called after computing the locus2d(grobcov(F)) of the
     3918          parametrical ideal.
     3919          The basering R, must be of the form Q[a,b][x,y,..].
     3920KEYWORDS: geometrical locus, locus, loci.
     3921EXAMPLE:  locus2dto; shows an example"
     3922{
     3923  int i; int j; int k;
     3924  string s;
     3925  s="[";
     3926  ideal p;
     3927  ideal q;
     3928  for(i=1;i<=size(L);i++)
     3929  {
     3930    s=string(s,"[[");
     3931    for (j=1;j<=size(L[i][1]);j++)
     3932    {
     3933      s=string(s,L[i][1][j],",");
     3934    }
     3935    s[size(s)]="]";
     3936    s=string(s,",[");
     3937    for(j=1;j<=size(L[i][2]);j++)
     3938    {
     3939      s=string(s,"[");
     3940      for(k=1;k<=size(L[i][2][j]);k++)
     3941      {
     3942        s=string(s,L[i][2][j][k],",");
     3943      }
     3944      s[size(s)]="]";
     3945      s=string(s,",");
     3946    }
     3947    s[size(s)]="]";
     3948    s=string(s,"],");
     3949    if(size(L[i])==3)
     3950    {
     3951      s[size(s)]=",";
     3952      s=string(s,"[",L[i][3],"]],");
     3953    }
     3954  }
     3955  s[size(s)]="]";
     3956  return(s);
     3957}
     3958example
     3959{"EXAMPLE:"; echo = 2;
     3960  ring R=(0,a,b),(x,y),dp;
     3961  short=0;
     3962  ideal H=x^2+y^2-4,(b-2)*x-a*y+2*a,(a-x)^2+(b-y)^2-1;
     3963  def G=grobcov(H);
     3964  "grobcov(H)="; G; " ";
     3965  def Gp=locus2d(G);
     3966  "locus2d(G)="; Gp;
     3967  def L=locus2dto(Gp); " ";
     3968  "locus2dto(Gp)="; L;
     3969}
     3970
     3971// indepparameters
     3972// Auxiliary routine to detect "Special" components of the locus2d
     3973// Input: ideal B
     3974// Output:
     3975//   1 if the solutions of the ideal do not depend on the parameters
     3976//   0 if they depend
     3977proc indepparameters(ideal B)
     3978{
     3979  def R=basering;
     3980  ideal B0; ideal B00;
     3981  int te;
     3982  int i; int j;
     3983  list s;
     3984  poly t;
     3985  ideal v=variables(B); // all the variables on B but not the parameters
     3986  setring(@RP);
     3987  ideal vv=imap(R,v);
     3988  def BP=imap(R,B);
     3989  option(redSB);
     3990  BP=std(BP);
     3991  setring(R);
     3992  B0=imap(@RP,BP);
     3993  for(i=1;i<=size(B0);i++)
     3994  {
     3995    if (equalideals(variables(B0[i]),ideal(0))){;}
     3996    else {B00[size(B00)+1]=B0[i];}
     3997  }
     3998  for(i=1;i<=size(B00);i++)
     3999  {
     4000    s=factorize(B00[i]);
     4001    for(j=1;j<=size(s[1]);j++)
     4002    {
     4003      if (equalideals(variables(s[1][j]),ideal(0))){;}
     4004      else{B00[i]=s[1][j];}
     4005    }
     4006  }
     4007  setring(@RP);
     4008  BP=imap(R,B00);
     4009  ideal vp=variables(BP);
     4010  if(equalideals(vv,vp)){te=1;} else{te=0;}
     4011  setring(R);
     4012  return(te);
     4013}
     4014
     4015// lsolve
     4016proc lsolve(ideal B)
     4017{
     4018  int i;
     4019  list L;
     4020  matrix c;
     4021  def v=variables(B);
     4022  ideal vi;
     4023  poly v0;
     4024  int te=1;
     4025  i=1;
     4026  while ((i<=size(B)) and te==1)
     4027  {
     4028    vi=variables(B[i]);
     4029    if (size(vi)==1)
     4030    {
     4031      v0=vi[1];
     4032      //"B[i]="; B[i];
     4033      c=coeffs(B[i],v0);
     4034      if (size(c)==2)
     4035      {
     4036        L[size(L)+1]=list(v0,-c[1,1]/c[2,1]);
     4037      }
     4038      else{te=0;}
     4039    }
     4040    else{te=0;}
     4041    i++;
     4042  }
     4043  if(te==1){return(L);}
     4044}
Note: See TracChangeset for help on using the changeset viewer.