source: git/Singular/LIB/bfct.lib @ 2653d3

spielwiese
Last change on this file since 2653d3 was 2653d3, checked in by Viktor Levandovskyy <levandov@…>, 15 years ago
*levandov: debug + docu enhancements git-svn-id: file:///usr/local/Singular/svn/trunk@11322 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100755
File size: 41.5 KB
Line 
1//////////////////////////////////////////////////////////////////////////////
2version="$Id: bfct.lib,v 1.12 2009-01-15 19:19:09 levandov Exp $";
3category="Noncommutative";
4info="
5LIBRARY: bfct.lib     Algorithms for b-functions and Bernstein-Sato polynomial
6AUTHORS: Daniel Andres, daniel.andres@math.rwth-aachen.de
7@* Viktor Levandovskyy,      levandov@math.rwth-aachen.de
8
9THEORY: Given a polynomial ring R = K[x_1,...,x_n] and a polynomial F in R,
10@*      one is interested in the global b-Function (also known as Bernstein-Sato
11@*      polynomial) b(s) in K[s], defined to be the monic polynomial, satisfying a functional
12@*      identity L * F^{s+1} = b(s) F^s,   for some operator L in D[s]. Here, D stands for an
13@*      n-th Weyl algebra K<x_1,...,x_n,d_1,...,d_n | d_j x_j = x_j d_j +1>.
14@*      One is interested in the following data:
15@*      - Bernstein-Sato polynomial b(s) in K[s],
16@*      - the list of its roots, which are known to be rational
17@*      - the multiplicities of the roots.
18@*      References: Saito, Sturmfels, Takayama: Groebner Deformations of Hypergeometric
19@*      Differential Equations (2000), Noro: An Efficient Modular Algorithm for Computing
20@*      the Global b-function, (2002).
21
22
23MAIN PROCEDURES:
24
25bfct(f[,s,t,v]);            computes the Bernstein-Sato polynomial of poly f
26bfctSyz(f[,r,s,t,u,v]);     computes the Bernstein-Sato polynomial of poly f
27bfctAnn(f[,s]);             computes the Bernstein-Sato polynomial of poly f
28bfctOneGB(f[,s,t]);         computes the Bernstein-Sato polynomial of poly f
29bfctIdeal(I,w[,s,t]);       computes the global b-function of ideal I w.r.t. the weight w
30pIntersect(f,I);            intersection of the ideal I with the subalgebra K[f] for a poly f
31pIntersectSyz(f,I[,p,s,t]); intersection of the ideal I with the subalgebra K[f] for a poly f
32linReduce(f,I[,s]);         reduces a poly by linear reductions only
33linReduceIdeal(I,[s,t]);    reduces generators of ideal by linear reductions only
34linSyzSolve(I[,s]);         computes a linear dependency of the elements of ideal I
35
36AUXILIARY PROCEDURES:
37
38allPositive(v);  checks whether all entries of an intvec are positive
39scalarProd(v,w); computes the standard scalar product of two intvecs
40vec2poly(v[,i]); constructs an univariate poly with given coefficients
41
42SEE ALSO: dmod_lib, dmodapp_lib, gmssing_lib
43";
44
45
46LIB "qhmoduli.lib"; // for Max
47LIB "dmod.lib";     // for SannfsBFCT etc
48LIB "dmodapp.lib";  // for initialIdealW etc
49
50
51///////////////////////////////////////////////////////////////////////////////
52// testing for consistency of the library:
53proc testbfctlib ()
54{
55  // tests all procs for consistency
56  "AUXILIARY PROCEDURES:";
57  example allPositive;
58  example scalarProd;
59  example vec2poly;
60  "MAIN PROCEDURES:";
61  example bfct;
62  example bfctSyz;
63  example bfctAnn;
64  example bfctOneGB;
65  example bfctIdeal;
66  example pIntersect;
67  example pIntersectSyz;
68  example linReduce;
69  example linReduceIdeal;
70  example linSyzSolve;
71}
72
73//--------------- auxiliary procedures ---------------------------------------------------------
74
75static proc gradedWeyl (intvec u,intvec v)
76"USAGE:  gradedWeyl(u,v); u,v intvecs
77RETURN:  a ring, the associated graded ring of the basering w.r.t. u and v
78PURPOSE: compute the associated graded ring of the basering w.r.t. u and v
79ASSUME: basering is a Weyl algebra
80EXAMPLE: example gradedWeyl; shows examples
81NOTE:    u[i] is the weight of x(i), v[i] the weight of D(i).
82@*       u+v has to be a non-negative intvec.
83"
84{
85  int i;
86  def save = basering;
87  int n = nvars(save)/2;
88  if (nrows(u)<>n || nrows(v)<>n)
89  {
90    ERROR("weight vectors have wrong dimension");
91  }
92  intvec uv,gr;
93  uv = u+v;
94  for (i=1; i<=n; i++)
95  {
96    if (uv[i]>=0)
97    {
98      if (uv[i]==0)
99      {
100        gr[i] = 0;
101      }
102      else
103      {
104        gr[i] = 1;
105      }
106    }
107    else
108    {
109      ERROR("the sum of the weight vectors has to be a non-negative intvec");
110    }
111  }
112  list l = ringlist(save);
113  list l2 = l[2];
114  matrix l6 = l[6];
115  for (i=1; i<=n; i++)
116  {
117    if (gr[i] == 1) 
118    {
119       l2[n+i] = "xi("+string(i)+")";
120       l6[i,n+i] = 0;
121    }
122  }
123  l[2] = l2;
124  l[6] = l6;
125  def G = ring(l);
126  return(G);
127}
128example
129{
130  "EXAMPLE:"; echo = 2;
131  ring @D = 0,(x,y,z,Dx,Dy,Dz),dp;
132  def D = Weyl();
133  setring D;
134  intvec u = -1,-1,1; intvec v = 2,1,1;
135  def G = gradedWeyl(u,v);
136  setring G; G;
137}
138
139
140proc allPositive (intvec v)
141"USAGE:  allPositive(v);  v an intvec
142RETURN:  int, 1 if all components of v are positive, or 0 otherwise
143PURPOSE: check whether all components of an intvec are positive
144EXAMPLE: example allPositive; shows an example
145"
146{
147  int i;
148  for (i=1; i<=size(v); i++)
149  {
150    if (v[i]<=0)
151    {
152      return(0);
153      break;
154    }
155  }
156  return(1);
157}
158example
159{
160  "EXAMPLE:"; echo = 2;
161  intvec v = 1,2,3;
162  allPositive(v);
163  intvec w = 1,-2,3;
164  allPositive(w);
165}
166
167static proc findFirst (list l, i)
168"USAGE:  findFirst(l,i);  l a list, i an argument of any type
169RETURN:  int, the position of the first appearance of i in l, or 0 if i is not a member of l
170PURPOSE: check whether the second argument is a member of a list
171EXAMPLE: example findFirst; shows an example
172"
173{
174  int j;
175  for (j=1; j<=size(l); j++)
176  {
177    if (l[j]==i)
178    {
179      return(j);
180      break;
181    }
182  }
183  return(0);
184}
185//   isin(list(1, 2, list(1)),2);       // seems to be a bit buggy,
186//   isin(list(1, 2, list(1)),3);       // but works for the purposes
187//   isin(list(1, 2, list(1)),list(1)); // of this library
188//   isin(l,list(2));
189example
190{
191  "EXAMPLE:"; echo = 2;
192  ring r = 0,x,dp;
193  list l = 1,2,3;
194  findFirst(l,4);
195  findFirst(l,2);
196}
197
198proc scalarProd (intvec v, intvec w)
199"USAGE:  scalarProd(v,w);  v,w intvecs
200RETURN:  int, the standard scalar product of v and w
201PURPOSE: computes the scalar product of two intvecs
202ASSUME:  the arguments are of the same size
203EXAMPLE: example scalarProd; shows examples
204"
205{
206  int i; int sp;
207  if (size(v)!=size(w))
208  {
209    ERROR("non-matching dimensions");
210  }
211  else
212  {
213    for (i=1; i<=size(v);i++)
214    {
215      sp = sp + v[i]*w[i];
216    }
217  }
218  return(sp);
219}
220example
221{
222  "EXAMPLE:"; echo = 2;
223  intvec v = 1,2,3;
224  intvec w = 4,5,6;
225  scalarProd(v,w);
226}
227
228//-------------- main procedures -------------------------------------------------------
229
230proc linReduceIdeal(ideal I, list #)
231"USAGE:  linReduceIdeal(I [,s,t]); I an ideal, s,t optional ints
232RETURN:  ideal/list, linear reductum (over field) of I by its elements
233PURPOSE: reduce a list of polys only by linear reductions (no monomial multiplications)
234NOTE:    If s<>0, a list consisting of the reduced ideal and the coefficient
235@*       vectors of the used reductions given as module is returned.
236@*       Otherwise (and by default), only the reduced ideal is returned.
237@*       If t=0 (and by default) all monomials are reduced (if possible),
238@*       otherwise, only leading monomials are reduced.
239DISPLAY: If @code{printlevel}>=1, all debug messages will be printed.
240EXAMPLE: example linReduceIdeal; shows examples
241"
242{
243  // #[1] = remembercoeffs
244  // #[2] = redtail
245  int ppl = printlevel - voice + 2;
246  int remembercoeffs = 0; // default
247  int redtail        = 0; // default
248  if (size(#)>0)
249  {
250    if (typeof(#[1])=="int" || typeof(#[1])=="number")
251    {
252      remembercoeffs = #[1];
253    }
254    if (size(#)>1)
255    {
256      if (typeof(#[2])=="int" || typeof(#[2])=="number")
257      {
258        redtail = #[2];
259      }
260    }
261  }
262  int sI = ncols(I);
263  int sZeros = sI - size(I);
264  dbprint(ppl,"ideal contains "+string(sZeros)+" zero(s)");
265  int i,j;
266  ideal J,lmJ,ordJ;
267  list lJ = sort(I);
268  module M; // for the coefficients
269  if (sZeros > 0) // I contains zeros
270  {
271    if (remembercoeffs <> 0)
272    {
273      j = 0;
274      for (i=1; i<=sI; i++)
275      {
276        if (I[i] == 0)
277        {
278          j++;
279          J[j] = 0;
280          ordJ[j] = -1;
281          M[j] = gen(i);
282        }
283        else
284        {
285          M[i+sZeros-j] = gen(lJ[2][i-j]+j);
286        }
287      }
288    }
289    else
290    {
291      for (i=1; i<=sZeros; i++)
292      {
293        J[i] = 0;
294        ordJ[i] = -1;
295      }
296    }
297    I = J,lJ[1];
298  }
299  else
300  {
301    I = lJ[1];
302    if (remembercoeffs <> 0)
303    {
304      for (i=1; i<=size(lJ[1]); i++) { M[i+sZeros] = gen(lJ[2][i]); }
305    }
306  }
307  dbprint(ppl,"initially sorted ideal:", I);
308  if (remembercoeffs <> 0) { dbprint(ppl," used permutations:", M); }
309  poly lm,c,redpoly,maxlmJ;
310  J[sZeros+1] = I[sZeros+1];
311  lm = I[sZeros+1];
312  maxlmJ = leadmonom(lm);
313  lmJ[sZeros+1] = maxlmJ;
314  int ordlm,reduction,maxordJ;
315  maxordJ = ord(lm);
316  ordJ[sZeros+1] = maxordJ;
317  vector v;
318  for (i=sZeros+2; i<=sI; i++)
319  {
320    redpoly = I[i];
321    lm = leadmonom(redpoly);
322    ordlm = ord(lm);
323    reduction = 1;
324    if (remembercoeffs <> 0) { v = M[i]; }
325    while (reduction == 1) // while there was a reduction
326    {
327      reduction = 0;
328      for (j=sZeros+1; j<i; j++)
329      {
330        if (lm == 0) { break; }
331        if (ordlm > maxordJ) { break; }
332        if (ordlm == ordJ[j])
333        {           
334          if (lm > maxlmJ) { break; }
335          if (lm == lmJ[j])
336          {
337            dbprint(ppl,"reducing " + string(redpoly));
338            dbprint(ppl," with " + string(J[j]));
339            c = leadcoef(redpoly)/leadcoef(J[j]);
340            redpoly = redpoly - c*J[j];
341            dbprint(ppl," to " + string(redpoly));
342            lm = leadmonom(redpoly);
343            ordlm = ord(lm);
344            if (remembercoeffs <> 0) { M[i] = M[i] - c * M[j]; }
345            reduction = 1;
346          }
347        }
348      }
349    }
350    for (j=sZeros+1; j<i; j++)
351    {
352      if (redpoly < J[j]) { break; }
353    }
354    J = insertGenerator(J,redpoly,j);
355    lmJ = insertGenerator(lmJ,lm,j);
356    ordJ = insertGenerator(ordJ,poly(ordlm),j);
357    if (remembercoeffs <> 0)
358    {
359      v = M[i];
360      M = deleteGenerator(M,i);
361      M = insertGenerator(M,v,j);
362    }
363    maxordJ = ord(J[i]);
364    maxlmJ = lmJ[i];
365  }
366  if (redtail <> 0)
367  {
368    dbprint(ppl,"finished reducing leading monomials:",J);
369    if (remembercoeffs <> 0) { dbprint(ppl,"used reductions:",M); }
370    int k;
371    for (i=sZeros+1; i<=sI; i++)
372    {
373      lm = lmJ[i];
374      for (j=i+1; j<=sI; j++)
375      {
376        for (k=2; k<=size(J[j]); k++) // run over all terms in J[j]
377        {
378          if (ordJ[i] == ord(J[j][k]))
379          {   
380            if (lm == normalize(J[j][k]))
381            {
382              c = leadcoef(J[j][k])/leadcoef(J[i]);
383              dbprint(ppl,"reducing " + string(J[j]));
384              dbprint(ppl," with " + string(J[i]));
385              J[j] = J[j] - c*J[i];
386              dbprint(ppl," to " + string(J[j]));
387              if (remembercoeffs <> 0) { M[j] = M[j] - c * M[i]; }
388            }
389          }
390        }
391      }
392    }
393  }
394  if (remembercoeffs <> 0) { return(list(J,M)); }
395  else { return(J); }
396}
397example
398{
399  "EXAMPLE:"; echo = 2;
400  ring r = 0,(x,y),dp;
401  ideal I = 3,x+9,y4,y4+7x+2;
402  linReduceIdeal(I);
403  linReduceIdeal(I,0,1);
404  list l = linReduceIdeal(I,1,1); l;
405  module M = I;
406  l[1] - ideal(M*l[2]);
407}
408
409proc linReduce(poly f, ideal I, list #)
410"USAGE:  linReduce(f, I [,s,t]); f a poly, I an ideal, s,t optional ints
411RETURN:  poly/list, linear reductum (over field) of f by elements from I
412PURPOSE: reduce a poly only by linear reductions (no monomial multiplications)
413NOTE:    If s<>0, a list consisting of the reduced poly and the coefficient
414@*       vector of the used reductions is returned, otherwise (and by default)
415@*       only reduced poly is returned.
416@*       If t=0 (and by default) all monomials are reduced (if possible),
417@*       otherwise, only leading monomials are reduced.
418DISPLAY: If @code{printlevel}>=1, all debug messages will be printed.
419EXAMPLE: example linReduce; shows examples
420"
421{
422  int ppl = printlevel - voice + 2;
423  int remembercoeffs = 0; // default
424  int redtail        = 0; // default
425  int prepareideal   = 1; // default
426  if (size(#)>0)
427  {
428    if (typeof(#[1])=="int" || typeof(#[1])=="number")
429    {
430      remembercoeffs = #[1];
431    }
432    if (size(#)>1)
433    {
434      if (typeof(#[2])=="int" || typeof(#[2])=="number")
435      {
436        redtail = #[2];
437      }
438      if (size(#)>2)
439      {
440        if (typeof(#[3])=="int" || typeof(#[3])=="number")
441        {
442          prepareideal = #[3];
443        }
444      }
445    }
446  }
447  int i,j,k;
448  int sI = ncols(I);
449  // pre-reduce I:
450  module M;
451  if (prepareideal <> 0)
452  {
453    if (remembercoeffs <> 0)
454    {
455      list sortedI = linReduceIdeal(I,1,redtail);
456      I = sortedI[1];
457      M = sortedI[2];
458      dbprint(ppl,"prepared ideal:",I);
459      dbprint(ppl," with operations:",M);
460    }
461    else
462    {
463      I = linReduceIdeal(I,0,redtail);
464    }
465  }
466  else
467  {
468    if (remembercoeffs <> 0)
469    {
470      for (i=1; i<=sI; i++)
471      {
472        M[i] = gen(i);
473      }
474    }
475  }
476  ideal lmI,lcI,ordI;
477  for (i=1; i<=sI; i++)
478  {
479    lmI[i] = leadmonom(I[i]);
480    lcI[i] = leadcoef(I[i]);
481    ordI[i] = ord(lmI[i]);
482  }
483  vector v;
484  poly c;
485  // === reduce leading monomials ===
486  poly lm = leadmonom(f);
487  int ordf = ord(lm);
488  for (i=sI; i>=1; i--)  // I is sorted: smallest lm's on top
489  {
490    if (lm == 0)
491    {
492      break;
493    }
494    else
495    {
496      if (ordf == ordI[i])
497      {
498        if (lm == lmI[i])
499        {
500          c = leadcoef(f)/lcI[i];
501          f = f - c*I[i];
502          lm = leadmonom(f);
503          ordf = ord(lm);
504          if (remembercoeffs <> 0)
505          {
506            v = v - c * M[i];
507          }
508        }
509      }
510    }
511  }
512  // === reduce tails as well ===
513  if (redtail <> 0)
514  {
515    dbprint(ppl,"poly after reduction of leading monomials:",f);
516    for (i=1; i<=sI; i++)
517    {
518      dbprint(ppl,"testing ideal entry:",i);
519      for (j=1; j<=size(f); j++)
520      {
521        if (ord(f[j]) == ordI[i])
522        {
523          if (normalize(f[j]) == lmI[i])
524          {
525            c = leadcoef(f[j])/lcI[i];
526            f = f - c*I[i];
527            dbprint(ppl,"reducing poly to ",f);
528            if (remembercoeffs <> 0)
529            {
530              v = v - c * M[i];
531            }
532          }
533        }
534      }
535    }
536  }
537  if (remembercoeffs <> 0)
538  {
539    list l = f,v;
540    return(l);
541  }
542  else
543  {
544    return(f);
545  }
546}
547example
548{
549  "EXAMPLE:"; echo = 2;
550  ring r = 0,(x,y),dp;
551  ideal I = 1,y,xy;
552  poly f = 5xy+7y+3;
553  poly g = 7x+5y+3;
554  linReduce(g,I);
555  linReduce(g,I,0,1);
556  linReduce(f,I,1);
557  f = x3 + y2 + x2 + y + x;
558  I = x3 - y3, y3 - x2, x3 - y2, x2 - y, y2-x;
559  list l = linReduce(f, I, 1);
560  l;
561  module M = I;
562  f - (l[1] - (M*l[2])[1,1]);
563}
564
565proc linSyzSolve (ideal I, list #)
566"USAGE:  linSyzSolve(I[,s]);  I an ideal, s an optional int
567RETURN:  vector, coefficient vector of a linear combination of 0 in the elements of I
568PURPOSE: compute a linear dependency between the elements of an ideal
569@*       if such one exists
570NOTE:    If s<>0, @code{std} is used for Groebner basis computations,
571@*       otherwise, @code{slimgb} is used.
572@*       By default, @code{slimgb} is used in char 0 and @code{std} in char >0.
573DISPLAY: If printlevel=1, progress debug messages will be printed,
574@*       if printlevel>=2, all the debug messages will be printed.
575EXAMPLE: example linSyzSolve; shows examples
576"
577{
578  int whichengine     = 0; // default
579  int enginespecified = 0; // default
580  if (size(#)>0)
581  {
582    if (typeof(#[1])=="int" || typeof(#[1])=="number")
583    {
584      whichengine = int( #[1]);
585      enginespecified = 1;
586    }
587  }
588  int ppl = printlevel - voice +2;
589  int sI = ncols(I);
590  // check if we are done
591  if (I[sI]==0)
592  {
593    vector v = gen(sI);
594  }
595  else
596  {
597    // ------- 1. introduce undefined coeffs ------------------
598    def save = basering;
599    int p = char(save);
600    if (enginespecified == 0)
601    {
602      if (p <> 0)
603      {
604        whichengine = 1;
605      }
606    }
607    ring @A = p,(@a(1..sI)),lp;
608    ring @aA = (p,@a(1..sI)), (@z),dp;
609    // TODO: BUG! WHAT IF THE ORIGINAL RING ALREADY HAS SUCH VARIABLES/PARAMETERS!!!?
610    // TODO: YOU CAN OVERCOME THIS BY MEANS SIMILAR TO "chooseSafeVarName" FROM NEW "matrix.lib"
611    def @B = save + @aA;
612    setring @B;
613    ideal I = imap(save,I);
614    // ------- 2. form the linear system for the undef coeffs ---
615    int i;   poly W;  ideal QQ;
616    for (i=1; i<=sI; i++)
617    {
618      W = W + @a(i)*I[i];
619    }
620    while (W!=0)
621    {
622      QQ = QQ,leadcoef(W);
623      W = W - lead(W);
624    }
625    // QQ consists of polynomial expressions in @a(i) of type number
626    setring @A;
627    ideal QQ = imap(@B,QQ);
628    // ------- 3. this QQ is a polynomial ideal, so "solve" the system -----
629    dbprint(ppl, "linSyzSolve: starting Groebner basis computation with engine:", whichengine);
630    QQ = engine(QQ,whichengine);
631    dbprint(ppl, "QQ after engine:", QQ);
632    if (dim(QQ) == -1)
633    {
634      dbprint(ppl+1, "no solutions by linSyzSolve");
635      // output zeroes
636      setring save;
637      kill @A,@aA,@B;
638      return(v);
639    }
640    // ------- 4. in order to get the numeric values -------
641    matrix AA = matrix(maxideal(1));
642    module MQQ = std(module(QQ));
643    AA = NF(AA,MQQ); // todo: we still receive NF warnings
644    dbprint(ppl, "AA after NF:",AA);
645    //    "AA after NF:"; print(AA);
646    for(i=1; i<=sI; i++)
647    {
648      AA = subst(AA,var(i),1);
649    }
650    dbprint(ppl, "AA after subst:",AA);
651    //    "AA after subst: "; print(AA);
652    vector v = (module(transpose(AA)))[1];
653    setring save;
654    vector v = imap(@A,v);
655    kill @A,@aA,@B;
656  }
657  return(v);
658}
659example
660{
661  "EXAMPLE:"; echo = 2;
662  ring r = 0,x,dp;
663  ideal I = x,2x;
664  linSyzSolve(I);
665  ideal J = x,x2;
666  linSyzSolve(J);
667}
668
669proc pIntersect (poly s, ideal I)
670"USAGE:  pIntersect(f, I);  f a poly, I an ideal
671RETURN:  vector, coefficient vector of the monic polynomial
672PURPOSE: compute the intersection of ideal I with the subalgebra K[f]
673ASSUME:  I is given as Groebner basis.
674NOTE:    If the intersection is zero, this proc might not terminate.
675DISPLAY: If printlevel=1, progress debug messages will be printed,
676@*       if printlevel>=2, all the debug messages will be printed.
677EXAMPLE: example pIntersect; shows examples
678"
679{
680  // assume I is given in Groebner basis
681  if (attrib(I,"isSB") <> 1)
682  {
683    print("WARNING: The input has no SB attribute!");
684    print(" Treating it as if it were a Groebner basis and proceeding...");
685    attrib(I,"isSB",1); // set attribute for suppressing NF messages
686  }
687  int ppl = printlevel-voice+1;
688  // ---case 1: I = basering---
689  if (size(I) == 1)
690  {
691    if (simplify(I,2)[1] == 1)
692    {
693      return(gen(2)); // = s
694    }
695  }
696  def save = basering;
697  int n = nvars(save);
698  int i,j,k;
699  // ---case 2: intersection is zero---
700  intvec degs = leadexp(s);
701  intvec possdegbounds;
702  list degI;
703  i = 1;
704  while (i <= ncols(I))
705  {
706    if (i == ncols(I)+1)
707    {
708      break;
709    }
710    degI[i] = leadexp(I[i]);
711    for (j=1; j<=n; j++)
712    {
713      if (degs[j] == 0)
714      {
715        if (degI[i][j] <> 0)
716        {
717          break;
718        }
719      }
720      if (j == n)
721      {
722        k++;
723        possdegbounds[k] = Max(degI[i]);
724      }
725    }
726    i++;
727  }
728  int degbound = Min(possdegbounds);
729  dbprint(ppl,"a lower bound for the degree of the insection is:");
730  dbprint(ppl,degbound);
731  if (degbound == 0) // lm(s) does not appear in lm(I)
732  {
733    return(vector(0));
734  }
735  // ---case 3: intersection is non-trivial---
736  ideal redNI = 1;
737  vector v;
738  list l,ll;
739  l[1] = vector(0);
740  poly toNF,tobracket,newNF,rednewNF,oldNF,secNF;
741  i = 1;
742  dbprint(ppl+1,"pIntersect starts...");
743  while (1)
744  {
745    dbprint(ppl,"testing degree: "+string(i));
746    if (i>1)
747    {
748      oldNF = newNF;
749      tobracket = s^(i-1) - oldNF;
750      if (tobracket==0) // todo bug in bracket?
751      {
752        toNF = 0;
753      }
754      else
755      {
756        toNF = bracket(tobracket,secNF);
757      }
758      newNF = NF(toNF+oldNF*secNF,I);  // = NF(s^i,I)
759    }
760    else
761    {
762      newNF = NF(s,I);
763      secNF = newNF;
764    }
765    ll = linReduce(newNF,redNI,1);
766    rednewNF = ll[1];
767    l[i+1] = ll[2];
768    dbprint(ppl,"newNF is:", newNF);
769    dbprint(ppl,"rednewNF is:", rednewNF);
770    if (rednewNF != 0) // no linear dependency
771    {
772      redNI[i+1] = rednewNF;
773      i++;
774    }
775    else // there is a linear dependency, hence we are done
776    {
777      dbprint(ppl+1,"the degree of the generator of the intersection is:", i);
778      break;
779    }
780  }
781  dbprint(ppl,"used linear reductions:", l);
782  // we obtain the coefficients of the generator of the intersection by the used reductions:
783  ring @R = 0,(a(1..i+1)),dp;
784  setring @R;
785  list l = imap(save,l);
786  ideal C;
787  for (j=1;j<=i+1;j++)
788  {
789    C[j] = 0;
790    for (k=1;k<=j;k++)
791    {
792      C[j] = C[j]+l[j][k]*a(k);
793    }
794  }
795  for (j=i;j>=1;j--)
796  {
797    C[i+1]= subst(C[i+1],a(j),a(j)+C[j]);
798  }
799  matrix m = coeffs(C[i+1],maxideal(1));
800  vector v = gen(i+1);
801  for (j=1;j<=i+1;j++)
802  {
803    v = v + m[j,1]*gen(j);
804  }
805  setring save;
806  v = imap(@R,v);
807  kill @R;
808  dbprint(ppl+1,"pIntersect finished");
809  return(v);
810}
811example
812{
813  "EXAMPLE:"; echo = 2;
814  ring r = 0,(x,y),dp;
815  poly f = x^2+y^3+x*y^2;
816  def D = initialMalgrange(f);
817  setring D;
818  inF;
819  pIntersect(t*Dt,inF);
820}
821
822proc pIntersectSyz (poly s, ideal II, list #)
823"USAGE:  pIntersectSyz(f, I [,p,s,t]);  f a poly, I an ideal, p, t optial ints, p a prime number
824RETURN:  vector, coefficient vector of the monic polynomial
825PURPOSE: compute the intersection of an ideal I with the subalgebra K[f]
826ASSUME:  I is given as Groebner basis.
827NOTE:    If the intersection is zero, this procedure might not terminate.
828@*       If p>0 is given, this proc computes the generator of the intersection in char p first
829@*       and then only searches for a generator of the obtained degree in the basering.
830@*       Otherwise, it searched for all degrees by computing syzygies.
831@*       If s<>0, @code{std} is used for Groebner basis computations in char 0,
832@*       otherwise, and by default, @code{slimgb} is used.
833@*       If t<>0 and by default, @code{std} is used for Groebner basis computations in char >0,
834@*       otherwise, @code{slimgb} is used.
835DISPLAY: If printlevel=1, progress debug messages will be printed,
836@*       if printlevel>=2, all the debug messages will be printed.
837EXAMPLE: example pIntersectSyz; shows examples
838"
839{
840  // assume I is given in Groebner basis
841  ideal I = II;
842  if (attrib(I,"isSB") <> 1)
843  {
844    print("WARNING: The input has no SB attribute!");
845    print(" Treating it as if it were a Groebner basis and proceeding...");
846    attrib(I,"isSB",1); // set attribute for suppressing NF messages
847  }
848  int ppl = printlevel-voice+2;
849  int whichengine  = 0; // default
850  int modengine    = 1; // default
851  int solveincharp = 0; // default
852  def save = basering;
853  if (size(#)>0)
854  {
855    if (typeof(#[1])=="int" || typeof(#[1])=="number")
856    {
857      solveincharp = int(#[1]);
858    }
859    if (size(#)>1)
860    {
861      if (typeof(#[2])=="int" || typeof(#[2])=="number")
862      {
863        whichengine = int(#[2]);
864      }
865      if (size(#)>2)
866      {
867        if (typeof(#[3])=="int" || typeof(#[3])=="number")
868        {
869          modengine = int(#[3]);
870        }
871      }
872    }
873  }
874  int i,j;
875  vector v;
876  poly tobracket,toNF,newNF,p;
877  ideal NI = 1;
878  newNF = NF(s,I);
879  NI[2] = newNF;
880  if (solveincharp<>0)
881  {
882    list l = ringlist(save);
883    l[1] = solveincharp;
884    matrix l5 = l[5];
885    matrix l6 = l[6];
886    def @Rp = ring(l);
887    setring @Rp;
888    list l = ringlist(@Rp);
889    l[5] = fetch(save,l5);
890    l[6] = fetch(save,l6);
891    def Rp = ring(l);
892    setring Rp;
893    kill @Rp;
894    dbprint(ppl+1,"solving in ring ", Rp);
895    vector v;
896    map phi = save,maxideal(1);
897    poly s = phi(s);
898    ideal NI = 1;
899    setring save;
900  }
901  i = 1;
902  dbprint(ppl+1,"pIntersectSyz starts...");
903  dbprint(ppl+1,"with ideal I=", I);
904  while (1)
905  {
906    dbprint(ppl,"i:"+string(i));
907    if (i>1)
908    {
909      tobracket = s^(i-1)-NI[i];
910      if (tobracket!=0)
911      {
912        toNF = bracket(tobracket,NI[2]) + NI[i]*NI[2];
913      }
914      else
915      {
916        toNF = NI[i]*NI[2];
917      }
918      newNF =  NF(toNF,I);
919      NI[i+1] = newNF;
920    }
921    // look for a solution
922    dbprint(ppl,"linSyzSolve starts with: "+string(matrix(NI)));
923    if (solveincharp<>0) // modular method
924    {
925      setring Rp;
926      NI[i+1] = phi(newNF);
927      v = linSyzSolve(NI,modengine);
928      if (v!=0) // there is a modular solution
929      {
930        dbprint(ppl,"got solution in char ",solveincharp," of degree " ,i);
931        setring save;
932        v = linSyzSolve(NI,whichengine);
933        if (v==0)
934        {
935          break;
936        }
937      }
938      else // no modular solution
939      {
940        setring save;
941        v = 0;
942      }
943    }
944    else // non-modular method
945    {
946      v = linSyzSolve(NI,whichengine);
947    }
948    matrix MM[1][nrows(v)] = matrix(v);
949    dbprint(ppl,"linSyzSolve ready  with: "+string(MM));
950    kill MM;
951    //  "linSyzSolve ready with"; print(v);
952    if (v!=0)
953    {
954      // a solution:
955      //check for the reality of the solution
956      p = 0;
957      for (j=1; j<=i+1; j++)
958      {
959        p = p + v[j]*NI[j];
960      }
961      if (p!=0)
962      {
963        dbprint(ppl,"linSyzSolve: bad solution!");
964      }
965      else
966      {
967        dbprint(ppl,"linSyzSolve: got solution!");
968        // "got solution!";
969        break;
970      }
971    }
972    // no solution:
973    i++;
974  }
975  dbprint(ppl+1,"pIntersectSyz finished");
976  return(v);
977}
978example
979{
980  "EXAMPLE:"; echo = 2;
981  ring r = 0,(x,y),dp;
982  poly f = x^2+y^3+x*y^2;
983  def D = initialMalgrange(f);
984  setring D;
985  inF;
986  poly s = t*Dt;
987  pIntersectSyz(s,inF);
988  int p = prime(20000);
989  pIntersectSyz(s,inF,p,0,0);
990}
991
992proc vec2poly (list #)
993"USAGE:  vec2poly(v [,i]);  v a vector or an intvec, i an optional int
994RETURN:  poly, an univariate poly in i-th variable with coefficients given by v
995PURPOSE: constructs an univariate poly in K[var(i)] with given coefficients,
996@*       such that the coefficient at var(i)^{j-1} is v[j].
997NOTE:    The optional argument i must be positive, by default i is 1.
998EXAMPLE: example vec2poly; shows examples
999"
1000{
1001  def save = basering;
1002  int i,ringvar;
1003  ringvar = 1; // default
1004  if (size(#) > 0)
1005  {
1006    if (typeof(#[1])=="vector" || typeof(#[1])=="intvec")
1007    {
1008      def v = #[1];
1009    }
1010    else
1011    {
1012      ERROR("wrong input: expected vector/intvec expression");
1013    }
1014    if (size(#) > 1)
1015    {
1016      if (typeof(#[2])=="int" || typeof(#[2])=="number")
1017      {
1018        ringvar = int(#[2]);
1019      }
1020    }
1021  }
1022  if (ringvar > nvars(save))
1023  {
1024    ERROR("var out of range");
1025  }
1026  poly p;
1027  for (i=1; i<=nrows(v); i++)
1028  {
1029    p = p + v[i]*(var(ringvar))^(i-1);
1030  }
1031  return(p);
1032}
1033example
1034{
1035  "EXAMPLE:"; echo = 2;
1036  ring r = 0,(x,y),dp;
1037  vector v = gen(1) + 3*gen(3) + 22/9*gen(4);
1038  intvec iv = 3,2,1;
1039  vec2poly(v,2);
1040  vec2poly(iv);
1041}
1042
1043static proc listofroots (list #)
1044{
1045  def save = basering;
1046  int n = nvars(save);
1047  int i;
1048  poly p;
1049  if (typeof(#[1])=="vector")
1050  {
1051    vector b = #[1];
1052    for (i=1; i<=nrows(b); i++)
1053    {
1054      p = p + b[i]*(var(1))^(i-1);
1055    }
1056  }
1057  else
1058  {
1059    p = #[1];
1060  }
1061  int substitution = int(#[2]);
1062  ring S = 0,s,dp;
1063  ideal J;
1064  for (i=1; i<=n; i++)
1065  {
1066    J[i] = s;
1067  }
1068  map @m = save,J;
1069  poly p = @m(p);
1070  if (substitution == 1)
1071  {
1072    p = subst(p,s,-s-1);
1073  }
1074  // the rest of this proc is nicked from bernsteinBM from dmod.lib
1075  list P = factorize(p);//with constants and multiplicities
1076  ideal bs; intvec m;   //the Bernstein polynomial is monic, so we are not interested in constants
1077  for (i=2; i<= size(P[1]); i++)  //we delete P[1][1] and P[2][1]
1078  {
1079    bs[i-1] = P[1][i];
1080    m[i-1]  = P[2][i];
1081  }
1082  bs =  normalize(bs);
1083  bs = -subst(bs,s,0);
1084  setring save;
1085  ideal bs = imap(S,bs);
1086  kill S;
1087  list BS = bs,m;
1088  return(BS);
1089}
1090
1091static proc bfctengine (poly f, int inorann, int whichengine, int methodord, int methodpIntersect, int pIntersectchar, int modengine, intvec u0)
1092{
1093  int ppl = printlevel - voice +2;
1094  int i;
1095  def save = basering;
1096  int n = nvars(save);
1097  if (size(variables(f)) == 0) // f is constant
1098  {
1099    return(list(ideal(0),intvec(0)));
1100  } 
1101  if (inorann == 0) // bfct using initial ideal
1102  {
1103    def D = initialMalgrange(f,whichengine,methodord,1,u0);
1104    setring D;
1105    ideal J = inF;
1106    kill inF;
1107    poly s = t*Dt;
1108  }
1109  else // bfct using Ann(f^s)
1110  {
1111    def D = SannfsBFCT(f,whichengine);
1112    setring D;
1113    ideal J = LD;
1114    kill LD;
1115  }
1116  vector b;
1117  // try it modular
1118  if (methodpIntersect <> 0) // pIntersectSyz
1119  {
1120    if (pIntersectchar == 0) // pIntersectSyz::modular
1121    {
1122      int lb = 30000;
1123      int ub = 536870909;
1124      i = 1;
1125      list usedprimes;
1126      while (b == 0)
1127      {
1128        dbprint(ppl,"number of run in the loop: "+string(i));
1129        int q = prime(random(lb,ub));
1130        if (findFirst(usedprimes,q)==0) // if q was not already used
1131        {
1132          usedprimes = usedprimes,q;
1133          dbprint(ppl,"used prime is: "+string(q));
1134          b = pIntersectSyz(s,J,q,whichengine,modengine);
1135        }
1136        i++;
1137      }
1138    }
1139    else // pIntersectSyz::non-modular
1140    {
1141      b = pIntersectSyz(s,J,0,whichengine);
1142    }
1143  }
1144  else // pIntersect: linReduce
1145  {
1146    b = pIntersect(s,J);
1147  }
1148  setring save;
1149  vector b = imap(D,b);
1150  if (inorann == 0)
1151  {
1152    list l = listofroots(b,1);
1153  }
1154  else
1155  {
1156    list l = listofroots(b,0);
1157  }
1158  return(l);
1159}
1160
1161proc bfct (poly f, list #)
1162"USAGE:  bfct(f [,s,t,v]);  f a poly, s,t optional ints, v an optional intvec
1163RETURN:  list of ideal and intvec
1164PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s)
1165@*       for the hypersurface defined by f.
1166ASSUME:  The basering is a commutative polynomial ring in char 0.
1167BACKGROUND: In this proc, the initial Malgrange ideal is computed according to the algorithm
1168@*       by Masayuki Noro and then a system of linear equations is solved by linear reductions.
1169NOTE:    In the output list, the ideal contains all the roots
1170@*       and the intvec their multiplicities.
1171@*       If s<>0, @code{std} is used for GB computations,
1172@*       otherwise, and by default, @code{slimgb} is used.
1173@*       If t<>0, a matrix ordering is used for Groebner basis computations,
1174@*       otherwise, and by default, a block ordering is used.
1175@*       If v is a positive weight vector, v is used for homogenization computations,
1176@*       otherwise and by default, no weights are used.
1177DISPLAY: If printlevel=1, progress debug messages will be printed,
1178@*       if printlevel>=2, all the debug messages will be printed.
1179EXAMPLE: example bfct; shows examples
1180"
1181{
1182  int ppl = printlevel - voice +2;
1183  int i;
1184  int n = nvars(basering);
1185  // in # we have two switches:
1186  // one for the engine used for Groebner basis computations,
1187  // one for  M() ordering or its realization
1188  // in # can also be the optional weight vector
1189  int whichengine  = 0; // default
1190  int methodord    = 0; // default
1191  intvec u0        = 0; // default
1192  if (size(#)>0)
1193  {
1194    if (typeof(#[1])=="int" || typeof(#[1])=="number")
1195    {
1196      whichengine = int(#[1]);
1197    }
1198    if (size(#)>1)
1199    {
1200      if (typeof(#[2])=="int" || typeof(#[2])=="number")
1201      {
1202        methodord = int(#[2]);
1203      }
1204      if (size(#)>2)
1205      {
1206        if (typeof(#[3])=="intvec" && size(#[3])==n && allPositive(#[3])==1)
1207        {
1208          u0 = #[3];
1209        }
1210      }
1211    }
1212  }
1213  list b = bfctengine(f,0,whichengine,methodord,0,0,0,u0);
1214  return(b);
1215}
1216example
1217{
1218  "EXAMPLE:"; echo = 2;
1219  ring r = 0,(x,y),dp;
1220  poly f = x^2+y^3+x*y^2;
1221  bfct(f);
1222  intvec v = 3,2;
1223  bfct(f,1,0,v);
1224}
1225
1226proc bfctSyz (poly f, list #)
1227"USAGE:  bfctSyz(f [,r,s,t,u,v]);  f a poly, r,s,t,u optional ints, v an optional intvec
1228RETURN:  list of ideal and intvec
1229PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s)
1230@*       for the hypersurface defined by f
1231ASSUME:  The basering is a commutative polynomial ring in char 0.
1232BACKGROUND: In this proc, the initial Malgrange ideal is computed according to the algorithm
1233@*       by Masayuki Noro and then a system of linear equations is solved by computing syzygies.
1234NOTE:    In the output list, the ideal contains all the roots
1235@*       and the intvec their multiplicities.
1236@*       If r<>0, @code{std} is used for GB computations in characteristic 0,
1237@*       otherwise, and by default, @code{slimgb} is used.
1238@*       If s<>0, a matrix ordering is used for GB computations, otherwise,
1239@*       and by default, a block ordering is used.
1240@*       If t<>0, the computation of the intersection is solely performed over
1241@*       charasteristic 0, otherwise and by default, a modular method is used.
1242@*       If u<>0 and by default, @code{std} is used for GB computations in
1243@*       characteristic >0, otherwise, @code{slimgb} is used.
1244@*       If v is a positive weight vector, v is used for homogenization
1245@*       computations, otherwise and by default, no weights are used.
1246DISPLAY: If printlevel=1, progress debug messages will be printed,
1247@*       if printlevel>=2, all the debug messages will be printed.
1248EXAMPLE: example bfctSyz; shows examples
1249"
1250{
1251  int ppl = printlevel - voice +2;
1252  int i;
1253  // in # we have four switches:
1254  // one for the engine used for Groebner basis computations in char 0,
1255  // one for  M() ordering or its realization
1256  // one for a modular method when computing the intersection
1257  // and one for the engine used for Groebner basis computations in char >0
1258  // in # can also be the optional weight vector
1259  def save = basering;
1260  int n = nvars(save);
1261  int whichengine = 0; // default
1262  int methodord   = 0; // default
1263  int pIntersectchar  = 0; // default
1264  int modengine   = 1; // default
1265  intvec u0       = 0; // default
1266  if (size(#)>0)
1267  {
1268    if (typeof(#[1])=="int" || typeof(#[1])=="number")
1269    {
1270      whichengine = int(#[1]);
1271    }
1272    if (size(#)>1)
1273    {
1274      if (typeof(#[2])=="int" || typeof(#[2])=="number")
1275      {
1276        methodord = int(#[2]);
1277      }
1278      if (size(#)>2)
1279      {
1280        if (typeof(#[3])=="int" || typeof(#[3])=="number")
1281        {
1282          pIntersectchar = int(#[3]);
1283        }
1284        if (size(#)>3)
1285        {
1286          if (typeof(#[4])=="int" || typeof(#[4])=="number")
1287          {
1288            modengine = int(#[4]);
1289          }
1290          if (size(#)>4)
1291          {
1292            if (typeof(#[5])=="intvec" && size(#[5])==n && allPositive(#[5])==1)
1293            {
1294              u0 = #[5];
1295            }
1296          }
1297        }
1298      }
1299    }
1300  }
1301  list b = bfctengine(f,0,whichengine,methodord,1,pIntersectchar,modengine,u0);
1302  return(b);
1303}
1304example
1305{
1306  "EXAMPLE:"; echo = 2;
1307  ring r = 0,(x,y),dp;
1308  poly f = x^2+y^3+x*y^2;
1309  bfctSyz(f);
1310  intvec v = 3,2;
1311  bfctSyz(f,0,1,1,0,v);
1312}
1313
1314proc bfctIdeal (ideal I, intvec w, list #)
1315"USAGE:  bfctIdeal(I,w[,s,t]);  I an ideal, w an intvec, s,t optional ints
1316RETURN:  list of ideal and intvec
1317PURPOSE: computes the roots of the global b-function of I wrt the weight vector (-w,w).
1318ASSUME:  The basering is the n-th Weyl algebra in char 0, where the sequence of
1319@*       the variables is x(1),...,x(n),D(1),...,D(n).
1320BACKGROUND:  In this proc, the initial ideal of I is computed according to the algorithm by
1321@*       Masayuki Noro and then a system of linear equations is solved by linear reductions.
1322NOTE:    In the output list, the ideal contains all the roots
1323@*       and the intvec their multiplicities.
1324@*       If s<>0, @code{std} is used for GB computations in characteristic 0,
1325@*       otherwise, and by default, @code{slimgb} is used.
1326@*       If t<>0, a matrix ordering is used for GB computations, otherwise,
1327@*       and by default, a block ordering is used.
1328DISPLAY: If printlevel=1, progress debug messages will be printed,
1329@*       if printlevel>=2, all the debug messages will be printed.
1330EXAMPLE: example bfctIdeal; shows examples
1331"
1332{
1333  int ppl = printlevel - voice +2;
1334  int i;
1335  def save = basering;
1336  int n = nvars(save)/2;
1337  int whichengine = 0; // default
1338  int methodord   = 0; // default
1339  if (size(#)>0)
1340  {
1341    if (typeof(#[1])=="int" || typeof(#[1])=="number")
1342    {
1343      whichengine = int(#[1]);
1344    }
1345    if (size(#)>1)
1346    {
1347      if (typeof(#[2])=="int" || typeof(#[2])=="number")
1348      {
1349        methodord = int(#[2]);
1350      }
1351    }
1352  }
1353  ideal J = initialIdealW(I,-w,w,whichengine,methodord);
1354  poly s;
1355  for (i=1; i<=n; i++)
1356  {
1357    s = s + w[i]*var(i)*var(n+i);
1358  }
1359  vector b = pIntersect(s,J);
1360  list l = listofroots(b,0);
1361  return(l);
1362}
1363example
1364{
1365  "EXAMPLE:"; echo = 2;
1366  ring @D = 0,(x,y,Dx,Dy),dp;
1367  def D = Weyl();
1368  setring D;
1369  ideal I = std(3*x^2*Dy+2*y*Dx,2*x*Dx+3*y*Dy+6); I;
1370  intvec w1 = 1,1;
1371  intvec w2 = 1,2;
1372  intvec w3 = 2,3;
1373  bfctIdeal(I,w1);
1374  bfctIdeal(I,w2,1);
1375  bfctIdeal(I,w3,0,1);
1376}
1377
1378proc bfctOneGB (poly f,list #)
1379"USAGE:  bfctOneGB(f [,s,t]);  f a poly, s,t optional ints
1380RETURN:  list of ideal and intvec
1381PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s) for the
1382@*       hypersurface defined by f, using only one GB computation
1383ASSUME:  The basering is a commutative polynomial ring in char 0.
1384BACKGROUND: In this proc, the initial Malgrange ideal is computed based on the
1385@*       algorithm by Masayuki Noro and combined with an elimination ordering.
1386NOTE:    In the output list, the ideal contains all the roots
1387@*       and the intvec their multiplicities.
1388@*       If s<>0, @code{std} is used for the GB computation, otherwise,
1389@*       and by default, @code{slimgb} is used.
1390@*       If t<>0, a matrix ordering is used for GB computations,
1391@*       otherwise, and by default, a block ordering is used.
1392DISPLAY: If printlevel=1, progress debug messages will be printed,
1393@*       if printlevel>=2, all the debug messages will be printed.
1394EXAMPLE: example bfctOneGB; shows examples
1395"
1396{
1397  int ppl = printlevel - voice +2;
1398  def save = basering;
1399  int n = nvars(save);
1400  int noofvars = 2*n+4;
1401  int i;
1402  int whichengine = 0; // default
1403  int methodord   = 0; // default
1404  if (size(#)>0)
1405  {
1406    if (typeof(#[1])=="int" || typeof(#[1])=="number")
1407    {
1408      whichengine = int(#[1]);
1409    }
1410    if (size(#)>1)
1411    {
1412      if (typeof(#[2])=="int" || typeof(#[2])=="number")
1413      {
1414        methodord = int(#[2]);
1415      }
1416    }
1417  }
1418  intvec uv;
1419  uv[n+3] = 1;
1420  ring r = 0,(x(1..n)),dp;
1421  poly f = fetch(save,f);
1422  uv[1] = -1; uv[noofvars] = 0;
1423  //  for the ordering
1424  intvec @a; @a = 1:noofvars; @a[2] = 2;
1425  intvec @a2 = @a; @a2[2] = 0; @a2[2*n+4] = 0;
1426  if (methodord == 0) // default: block ordering
1427  {
1428    ring Dh = 0,(t,s,x(n..1),Dt,D(n..1),h),(a(@a),a(@a2),a(uv),dp(noofvars-1),lp(1));
1429  }
1430  else // M() ordering
1431  {
1432    intmat @Ord[noofvars][noofvars];
1433    @Ord[1,1..noofvars] = uv;
1434    @Ord[2,1..noofvars] = 1:(noofvars-1);
1435    for (i=1; i<=noofvars-2; i++)
1436    {
1437      @Ord[2+i,noofvars - i] = -1;
1438    }
1439    dbprint(ppl,"weights for ordering:",transpose(@a));
1440    dbprint(ppl,"the ordering matrix:",@Ord);
1441    ring Dh = 0,(t,s,x(n..1),Dt,D(n..1),h),(a(@a),a(@a2),M(@Ord));
1442  }
1443  dbprint(ppl,"the ring Dh:",Dh);
1444  // non-commutative relations
1445  matrix @relD[noofvars][noofvars];
1446  @relD[1,2] = t*h^2;// s*t = t*s+t*h^2
1447  @relD[2,n+3] = Dt*h^2;// Dt*s = s*Dt+h^2
1448  @relD[1,n+3] = h^2;
1449  for (i=1; i<=n; i++)
1450  {
1451    @relD[i+2,n+3+i] = h^2;
1452  }
1453  dbprint(ppl,"nc relations:",@relD);
1454  def DDh = nc_algebra(1,@relD);
1455  setring DDh;
1456  dbprint(ppl,"computing in ring",DDh);
1457  ideal I;
1458  poly f = imap(r,f);
1459  kill r;
1460  f = homog(f,h);
1461  I = t - f, t*Dt - s;  // defining the Malgrange ideal
1462  for (i=1; i<=n; i++)
1463  {
1464    I = I, D(i)+diff(f,x(i))*Dt;
1465  }
1466  dbprint(ppl, "starting Groebner basis computation with engine:", whichengine);
1467  I = engine(I, whichengine);
1468  dbprint(ppl, "finished Groebner basis computation");
1469  dbprint(ppl, "I before dehomogenization is" ,I);
1470  I = subst(I,h,1); // dehomogenization
1471  dbprint(ppl, "I after dehomogenization is" ,I);
1472  I = inForm(I,uv); // we are only interested in the initial form w.r.t. uv
1473  dbprint(ppl, "the initial ideal:", string(matrix(I)));
1474  intvec tonselect = 1;
1475  for (i=3; i<=2*n+4; i++) { tonselect = tonselect,i; }
1476  I = nselect(I,tonselect);
1477  dbprint(ppl, "generators containing only s:", string(matrix(I)));
1478  I = engine(I, whichengine); // is now a principal ideal;
1479  setring save;
1480  ideal J; J[2] = var(1);
1481  map @m = DDh,J;
1482  ideal I = @m(I);
1483  poly p = I[1];
1484  list l = listofroots(p,1);
1485  return(l);
1486}
1487example
1488{
1489  "EXAMPLE:"; echo = 2;
1490  ring r = 0,(x,y),dp;
1491  poly f = x^2+y^3+x*y^2;
1492  bfctOneGB(f);
1493  bfctOneGB(f,1,1);
1494}
1495
1496proc bfctAnn (poly f, list #)
1497"USAGE:  bfctAnn(f [,r]);  f a poly, r an optional int
1498RETURN:  list of ideal and intvec
1499PURPOSE: computes the roots of the Bernstein-Sato polynomial b(s)
1500@*       for the hypersurface defined by f
1501ASSUME:  The basering is a commutative polynomial ring in char 0.
1502BACKGROUND: In this proc, ann(f^s) is computed and then a system of linear
1503@*       equations is solved by linear reductions.
1504NOTE:    In the output list, the ideal contains all the roots
1505@*       and the intvec their multiplicities.
1506@*       If r<>0, @code{std} is used for GB computations,
1507@*       otherwise, and by default, @code{slimgb} is used.
1508DISPLAY: If printlevel=1, progress debug messages will be printed,
1509@*       if printlevel>=2, all the debug messages will be printed.
1510EXAMPLE: example bfctAnn; shows examples
1511"
1512{
1513  def save = basering;
1514  int ppl = printlevel - voice + 2;
1515  int whichengine = 0; // default
1516  if (size(#)>0)
1517  {
1518    if (typeof(#[1])=="int" || typeof(#[1])=="number")
1519    {
1520      whichengine = int(#[1]);
1521    }
1522  }
1523  list b = bfctengine(f,1,whichengine,0,1,0,0,0);
1524  return(b);
1525}
1526example
1527{
1528  "EXAMPLE:"; echo = 2;
1529  ring r = 0,(x,y),dp;
1530  poly f = x^2+y^3+x*y^2;
1531  bfctAnn(f);
1532}
1533
1534/*
1535//static proc hardexamples ()
1536{
1537  //  some hard examples
1538  ring r1 = 0,(x,y,z,w),dp;
1539  // ab34
1540  poly ab34 = (z3+w4)*(3z2x+4w3y);
1541  bfct(ab34);
1542  // ha3
1543  poly ha3 = xyzw*(x+y)*(x+z)*(x+w)*(y+z+w);
1544  bfct(ha3);
1545  // ha4
1546  poly ha4 = xyzw*(x+y)*(x+z)*(x+w)*(y+z)*(y+w);
1547  bfct(ha4);
1548  // chal4: reiffen(4,5)*reiffen(5,4)
1549  ring r2 = 0,(x,y),dp;
1550  poly chal4 = (x4+xy4+y5)*(x5+x4y+y4);
1551  bfct(chal4);
1552  // (xy+z)*reiffen(4,5)
1553  ring r3 = 0,(x,y,z),dp;
1554  poly xyzreiffen45 = (xy+z)*(y4+yz4+z5);
1555  bfct(xyzreiffen45);
1556}
1557*/
Note: See TracBrowser for help on using the repository browser.