# source:git/Singular/LIB/freegb.lib@0a2f7d

spielwiese
Last change on this file since 0a2f7d was 0a2f7d, checked in by Viktor Levandovskyy <levandov@…>, 13 years ago
*levandov: checklib changes of libs form Aachen git-svn-id: file:///usr/local/Singular/svn/trunk@13356 2c84dea3-7e68-4137-9b89-c4e89433aadc
• Property mode set to `100644`
File size: 69.7 KB
Line
1//////////////////////////////////////////////////////////////////////////////
2version="\$Id\$";
3category="Noncommutative";
4info="
5LIBRARY: freegb.lib   Compute two-sided Groebner bases in free algebras via letterplace
6AUTHOR: Viktor Levandovskyy,     levandov@math.rwth-aachen.de
7
8OVERVIEW: For the theory, see chapter 'Letterplace' in the @sc{Singular} Manual.
9
10PROCEDURES:
11makeLetterplaceRing(d);    creates a ring with d blocks of shifted original variables
12freeGBasis(L, n);   compute two-sided Groebner basis of ideal, encoded via L, up to degree n
13setLetterplaceAttributes(R,d,b);  supplies ring R with the letterplace structure
14
15
16lpMult(f,g);        letterplace multiplication of letterplace polynomials
17shiftPoly(p,i);    compute the i-th shift of letterplace polynomial p
18lpPower(f,n);     natural power of a letterplace polynomial
19lp2lstr(K, s);      convert letter-place ideal to a list of modules
20lst2str(L[, n]);     convert a list (of modules) into polynomials in free algebra
21mod2str(M[, n]); convert a module into a polynomial in free algebra
22vct2str(M[, n]);   convert a vector into a word in free algebra
23lieBracket(a,b[, N]);    compute Lie bracket ab-ba of two letterplace polynomials
24serreRelations(A,z);   compute the homogeneous part of Serre's relations associated to a generalized Cartan matrix A
25fullSerreRelations(A,N,C,P,d); compute the ideal of all Serre's relations associated to a generalized Cartan matrix A
26isVar(p);                   check whether p is a power of a single variable
27ademRelations(i,j);    compute the ideal of Adem relations for i<2j in char 0
28
30";
31
32// this library computes two-sided GB of an ideal
33// in a free associative algebra
34
35// a monomial is encoded via a vector V
36// where V[1] = coefficient
37// V[1+i] = the corresponding symbol
38
39LIB "qhmoduli.lib"; // for Max
40
41proc tstfreegb()
42{
43    /* tests all procs for consistency */
45  example makeLetterplaceRing;
46  example freeGBasis;
47  example setLetterplaceAttributes;
48  /* secondary */
49  example   lpMult;
50  example   shiftPoly;
51  example   lpPower;
52  example   lp2lstr;
53  example   lst2str;
54  example   mod2str;
55  example   vct2str;
56  example   lieBracket;
57  example   serreRelations;
58  example fullSerreRelations;
59  example   isVar;
61}
62
63proc setLetterplaceAttributes(def R, int uptodeg, int lV)
64"USAGE: setLetterplaceAttributes(R, d, b); R a ring, b,d integers
65RETURN: ring with special attributes set
66PURPOSE: sets attributes for a letterplace ring:
67@*      'isLetterplaceRing' = true, 'uptodeg' = d, 'lV' = b, where
68@*      'uptodeg' stands for the degree bound,
69@*      'lV' for the number of variables in the block 0.
70NOTE: Activate the resulting ring by using @code{setring}
71"
72{
73  if (uptodeg*lV != nvars(R))
74  {
75    ERROR("uptodeg and lV do not agree on the basering!");
76  }
77
78    // Set letterplace-specific attributes for the output ring!
79  attrib(R, "uptodeg", uptodeg);
80  attrib(R, "lV", lV);
81  attrib(R, "isLetterplaceRing", 1);
82  return (R);
83}
84example
85{
86  "EXAMPLE:"; echo = 2;
87  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
88  def R = setLetterplaceAttributes(r, 4, 2); setring R;
89  attrib(R,"isLetterplaceRing");
90  lieBracket(x(1),y(1),2);
91}
92
93
94// obsolete?
95
96static proc lshift(module M, int s, string varing, def lpring)
97{
98  // FINALLY IMPLEMENTED AS A PART OT THE CODE
99  // shifts a polynomial from the ring R to s positions
100  // M lives in varing, the result in lpring
101  // to be run from varing
102  int i, j, k, sm, sv;
103  vector v;
104  //  execute("setring "+lpring);
105  setring lpring;
106  poly @@p;
107  ideal I;
108  execute("setring "+varing);
109  sm = ncols(M);
110  for (i=1; i<=s; i++)
111  {
112    // modules, e.g. free polynomials
113    for (j=1; j<=sm; j++)
114    {
115      //vectors, e.g. free monomials
116      v  = M[j];
117      sv = size(v);
118      sp = "@@p = @@p + ";
119      for (k=2; k<=sv; k++)
120      {
121        sp = sp + string(v[k])+"("+string(k-1+s)+")*";
122      }
123      sp = sp + string(v[1])+";"; // coef;
124      setring lpring;
125      //      execute("setring "+lpring);
126      execute(sp);
127      execute("setring "+varing);
128    }
129    setring lpring;
130    //    execute("setring "+lpring);
131    I = I,@@p;
132    @@p = 0;
133  }
134  setring lpring;
135  //execute("setring "+lpring);
136  export(I);
137  //  setring varing;
138  execute("setring "+varing);
139}
140
141static proc skip0(vector v)
142{
143  // skips zeros in a vector, producing another vector
144  if ( (v[1]==0) || (v==0) ) { return(vector(0)); }
145  int sv = nrows(v);
146  int sw = size(v);
147  if (sv == sw)
148  {
149    return(v);
150  }
151  int i;
152  int j=1;
153  vector w;
154  for (i=1; i<=sv; i++)
155  {
156    if (v[i] != 0)
157    {
158      w = w + v[i]*gen(j);
159      j++;
160    }
161  }
162  return(w);
163}
164
165proc lst2str(list L, list #)
166"USAGE:  lst2str(L[,n]);  L a list of modules, n an optional integer
167RETURN:  list (of strings)
168PURPOSE: convert a list (of modules) into polynomials in free algebra
169EXAMPLE: example lst2str; shows examples
170NOTE: if an optional integer is not 0, stars signs are used in multiplication
171"
172{
173  // returns a list of strings
174  // being sentences in words built from L
175  // if #[1] = 1, use * between generators
176  int useStar = 0;
177  if ( size(#)>0 )
178  {
179    if ( typeof(#[1]) != "int")
180    {
181      ERROR("Second argument of type int expected");
182    }
183    if (#[1])
184    {
185      useStar = 1;
186    }
187  }
188  int i;
189  int s    = size(L);
190  if (s<1) { return(list(""));}
191  list N;
192  for(i=1; i<=s; i++)
193  {
194    if ((typeof(L[i]) == "module") || (typeof(L[i]) == "matrix") )
195    {
196      N[i] = mod2str(L[i],useStar);
197    }
198    else
199    {
200      "module or matrix expected in the list";
201      return(N);
202    }
203  }
204  return(N);
205}
206example
207{
208  "EXAMPLE:"; echo = 2;
209  ring r = 0,(x,y,z),(dp(1),dp(2));
210  module M = [-1,x,y],[-7,y,y],[3,x,x];
211  module N = [1,x,y,x,y],[-2,y,x,y,x],[6,x,y,y,x,y];
212  list L; L[1] = M; L[2] = N;
213  lst2str(L);
214  lst2str(L[1],1);
215}
216
217
218proc mod2str(module M, list #)
219"USAGE:  mod2str(M[,n]);  M a module, n an optional integer
220RETURN:  string
221PURPOSE: convert a module into a polynomial in free algebra
222EXAMPLE: example mod2str; shows examples
223NOTE: if an optional integer is not 0, stars signs are used in multiplication
224"
225{
226  if (size(M)==0) { return(""); }
227  // returns a string
228  // a sentence in words built from M
229  // if #[1] = 1, use * between generators
230  int useStar = 0;
231  if ( size(#)>0 )
232  {
233    if ( typeof(#[1]) != "int")
234    {
235      ERROR("Second argument of type int expected");
236    }
237    if (#[1])
238    {
239      useStar = 1;
240    }
241  }
242  int i;
243  int s    = ncols(M);
244  string t;
245  string mp;
246  for(i=1; i<=s; i++)
247  {
248    mp = vct2str(M[i],useStar);
249    if (mp[1] == "-")
250    {
251      t = t + mp;
252    }
253    else
254    {
255      if (mp != "")
256      {
257         t = t + "+" + mp;
258      }
259    }
260  }
261  if (t[1]=="+")
262  {
263    t = t[2..size(t)]; // remove first "+"
264  }
265  return(t);
266}
267example
268{
269  "EXAMPLE:"; echo = 2;
270  ring r = 0,(x,y,z),(dp);
271  module M = [1,x,y,x,y],[-2,y,x,y,x],[6,x,y,y,x,y];
272  mod2str(M);
273  mod2str(M,1);
274}
275
276proc vct2str(vector v, list #)
277"USAGE:  vct2str(v[,n]);  v a vector, n an optional integer
278RETURN:  string
279PURPOSE: convert a vector into a word in free algebra
280EXAMPLE: example vct2str; shows examples
281NOTE: if an optional integer is not 0, stars signs are used in multiplication
282"
283{
284  if (v==0) { return(""); }
285  // if #[1] = 1, use * between generators
286  int useStar = 0;
287  if ( size(#)>0 )
288  {
289    if (#[1])
290    {
291      useStar = 1;
292    }
293  }
294  int ppl = printlevel-voice+2;
295  // for a word, encoded by v
296  // produces a string for it
297  v = skip0(v);
298  if (v==0) { return(string(""));}
300  int s = size(v);
301  string vs,vv,vp,err;
302  int i,j,p,q;
303  for (i=1; i<=s-1; i++)
304  {
305    p     = isVar(v[i+1]);
306    if (p==0)
307    {
308      err = "Error: monomial expected at nonzero position " + string(i+1);
309      ERROR(err+" in vct2str");
310      //      dbprint(ppl,err);
311      //      return("_");
312    }
313    if (p==1)
314    {
315      if (useStar && (size(vs) >0))       {   vs = vs + "*"; }
316        vs = vs + string(v[i+1]);
317    }
318    else //power
319    {
320      vv = string(v[i+1]);
321      q = find(vv,"^");
322      if (q==0)
323      {
324        q = find(vv,string(p));
325        if (q==0)
326        {
327          err = "error in find for string "+vv;
328          dbprint(ppl,err);
329          return("_");
330        }
331      }
332      // q>0
333      vp = vv[1..q-1];
334      for(j=1;j<=p;j++)
335      {
336         if (useStar && (size(vs) >0))       {   vs = vs + "*"; }
337         vs = vs + vp;
338      }
339    }
340  }
341  string scf;
342  if (cf == -1)
343  {
344    scf = "-";
345  }
346  else
347  {
348    scf = string(cf);
349    if ( (cf == 1) && (size(vs)>0) )
350    {
351      scf = "";
352    }
353  }
354  if (useStar && (size(scf) >0) && (scf!="-") )       {   scf = scf + "*"; }
355  vs = scf + vs;
356  return(vs);
357}
358example
359{
360  "EXAMPLE:"; echo = 2;
361  ring r = (0,a),(x,y3,z(1)),dp;
362  vector v = [-7,x,y3^4,x2,z(1)^3];
363  vct2str(v);
364  vct2str(v,1);
365  vector w = [-7a^5+6a,x,y3,y3,x,z(1),z(1)];
366  vct2str(w);
367  vct2str(w,1);
368}
369
370proc isVar(poly p)
371"USAGE:  isVar(p);  poly p
372RETURN:  int
373PURPOSE: check, whether leading monomial of p is a power of a single variable
374@* from the basering. Returns the exponent or 0 if p is multivariate.
375EXAMPLE: example isVar; shows examples
376"
377{
378  // checks whether p is a variable indeed
379  // if it's a power of a variable, returns the power
380  if (p==0) {  return(0); } //"p=0";
382  if ( (p-lead(p)) !=0 ) { return(0); } // "p-lm(p)>0";
384  int s = size(v);
385  int i=1;
386  int cnt = 0;
387  int pwr = 0;
388  for (i=1; i<=s; i++)
389  {
390    if (v[i] != 0)
391    {
392      cnt++;
393      pwr = v[i];
394    }
395  }
396  //  "cnt:";  cnt;
397  if (cnt==1) { return(pwr); }
398  else { return(0); }
399}
400example
401{
402  "EXAMPLE:"; echo = 2;
403  ring r = 0,(x,y),dp;
404  poly f = xy+1;
405  isVar(f);
406  poly g = y^3;
407  isVar(g);
408  poly h = 7*x^3;
409  isVar(h);
410  poly i = 1;
411  isVar(i);
412}
413
414// new conversion routines
415
416static proc id2words(ideal I, int d)
417{
418  // NOT FINISHED
419  // input: ideal I of polys in letter-place notation
420  // in the ring with d real vars
421  // output: the list of strings: associative words
422  // extract names of vars
423  int i,m,n; string s; string place = "(1)";
424  list lv;
425  for(i=1; i<=d; i++)
426  {
427    s = string(var(i));
428    // get rid of place
429    n = find(s, place);
430    if (n>0)
431    {
432      s = s[1..n-1];
433    }
434    lv[i] = s;
435  }
436  poly p,q;
437  for (i=1; i<=ncols(I); i++)
438  {
439    if (I[i] != 0)
440    {
441      p = I[i];
442      while (p!=0)
443      {
445      }
446    }
447  }
448
449  return(lv);
450}
451example
452{
453  "EXAMPLE:"; echo = 2;
454  ring r = 0,(x(1),y(1),z(1),x(2),y(2),z(2)),dp;
455  ideal I = x(1)*y(2) -z(1)*x(2);
456  id2words(I,3);
457}
458
459static proc mono2word(poly p, int d)
460{
461}
462
463// given the element -7xy^2x, it is represented as [-7,x,y^2,x] or as [-7,x,y,y,x]
464// use the orig ord on (x,y,z) and expand it blockwise to (x(i),y(i),z(i))
465
466// the correspondences:
467// monomial in K<x,y,z>    <<--->> vector in R
468// polynomial in K<x,y,z>  <<--->> list of vectors (matrix/module) in R
469// ideal in K<x,y,z>       <<--->> list of matrices/modules in R
470
471
472// 1. form a new ring
473// 2. NOP
474// 3. compute GB -> with the kernel stuff
475// 4. skip shifted elts (check that no such exist?)
476// 5. go back to orig vars, produce strings/modules
477// 6. return the result
478
479proc freeGBasis(list LM, int d)
480"USAGE:  freeGBasis(L, d);  L a list of modules, d an integer
481RETURN:  ring
482ASSUME: L has a special form. Namely, it is a list of modules, where
483@* each generator of every module stands for a monomial times coefficient in free algebra.
484@* In such a vector generator, the 1st entry is a nonzero coefficient from the ground field
485@* and each next entry hosts a variable from the basering.
486PURPOSE: compute the two-sided Groebner basis of an ideal, encoded by L
487@* in the free associative algebra, up to degree d
488NOTE: Apply @code{lst2str} to the output in order to obtain a better readable presentation
489EXAMPLE: example freeGBasis; shows examples
490"
491{
492  // d = up to degree, will be shifted to d+1
493  if (d<1) {"bad d"; return(0);}
494
495  int ppl = printlevel-voice+2;
496  string err = "";
497
498  int i,j,s;
499  def save = basering;
500  // determine max no of places in the input
501  int slm = size(LM); // numbers of polys in the ideal
502  int sm;
503  intvec iv;
504  module M;
505  for (i=1; i<=slm; i++)
506  {
507    // modules, e.g. free polynomials
508    M  = LM[i];
509    sm = ncols(M);
510    for (j=1; j<=sm; j++)
511    {
512      //vectors, e.g. free monomials
513      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
514    }
515  }
516  int D = Max(iv); // max size of input words
517  if (d<D) {"bad d"; return(LM);}
518  D = D + d-1;
519  //  D = d;
520  list LR  = ringlist(save);
521  list L, tmp;
522  L[1] = LR[1]; // ground field
523  L[4] = LR[4]; // quotient ideal
524  tmp  = LR[2]; // varnames
525  s = size(LR[2]);
526  for (i=1; i<=D; i++)
527  {
528    for (j=1; j<=s; j++)
529    {
530      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
531    }
532  }
533  for (i=1; i<=s; i++)
534  {
535    tmp[i] = string(tmp[i])+"("+string(1)+")";
536  }
537  L[2] = tmp;
538  list OrigNames = LR[2];
539  // ordering: d blocks of the ord on r
540  // try to get whether the ord on r is blockord itself
541  s = size(LR[3]);
542  if (s==2)
543  {
544    // not a blockord, 1 block + module ord
545    tmp = LR[3][s]; // module ord
546    for (i=1; i<=D; i++)
547    {
548      LR[3][s-1+i] = LR[3][1];
549    }
550    LR[3][s+D] = tmp;
551  }
552  if (s>2)
553  {
554    // there are s-1 blocks
555    int nb = s-1;
556    tmp = LR[3][s]; // module ord
557    for (i=1; i<=D; i++)
558    {
559      for (j=1; j<=nb; j++)
560      {
561        LR[3][i*nb+j] = LR[3][j];
562      }
563    }
564    //    size(LR[3]);
565    LR[3][nb*(D+1)+1] = tmp;
566  }
567  L[3] = LR[3];
568  def @R = ring(L);
569  setring @R;
570  ideal I;
571  poly @p;
572  s = size(OrigNames);
573  //  "s:";s;
574  // convert LM to canonical vectors (no powers)
575  setring save;
576  kill M; // M was defined earlier
577  module M;
578  slm = size(LM); // numbers of polys in the ideal
579  int sv,k,l;
580  vector v;
581  //  poly p;
582  string sp;
583  setring @R;
584  poly @@p=0;
585  setring save;
586  for (l=1; l<=slm; l++)
587  {
588    // modules, e.g. free polynomials
589    M  = LM[l];
590    sm = ncols(M); // in intvec iv the sizes are stored
591    // modules, e.g. free polynomials
592    for (j=1; j<=sm; j++)
593    {
594      //vectors, e.g. free monomials
595      v  = M[j];
596      sv = size(v);
597      //        "sv:";sv;
598      sp = "@@p = @@p + ";
599      for (k=2; k<=sv; k++)
600      {
601        sp = sp + string(v[k])+"("+string(k-1)+")*";
602      }
603      sp = sp + string(v[1])+";"; // coef;
604      setring @R;
605      execute(sp);
606      setring save;
607    }
608    setring @R;
609    //      "@@p:"; @@p;
610    I = I,@@p;
611    @@p = 0;
612    setring save;
613  }
614  kill sp;
615  // 3. compute GB
616  setring @R;
617  dbprint(ppl,"computing GB");
618  ideal J = system("freegb",I,d,nvars(save));
619  //  ideal J = slimgb(I);
620  dbprint(ppl,J);
621  // 4. skip shifted elts
622  ideal K = select1(J,1..s); // s = size(OrigNames)
623  dbprint(ppl,K);
624  dbprint(ppl, "done with GB");
625  // K contains vars x(1),...z(1) = images of originals
626  // 5. go back to orig vars, produce strings/modules
627  if (K[1] == 0)
628  {
629    "no reasonable output, GB gives 0";
630    return(0);
631  }
632  int sk = size(K);
633  int sp, sx, a, b;
634  intvec x;
635  poly p,q;
636  poly pn;
637  // vars in 'save'
638  setring save;
639  module N;
640  list LN;
641  vector V;
642  poly pn;
643  // test and skip exponents >=2
644  setring @R;
645  for(i=1; i<=sk; i++)
646  {
647    p  = K[i];
648    while (p!=0)
649    {
651      //      "processing q:";q;
653      sx = size(x);
654      for(k=1; k<=sx; k++)
655      {
656        if ( x[k] >= 2 )
657        {
658          err = "skip: the value x[k] is " + string(x[k]);
659          dbprint(ppl,err);
660          //            return(0);
661          K[i] = 0;
662          p    = 0;
663          q    = 0;
664          break;
665        }
666      }
667      p  = p - q;
668    }
669  }
670  K  = simplify(K,2);
671  sk = size(K);
672  for(i=1; i<=sk; i++)
673  {
674    //    setring save;
675    //    V  = 0;
676    setring @R;
677    p  = K[i];
678    while (p!=0)
679    {
681      err =  "processing q:" + string(q);
682      dbprint(ppl,err);
684      sx = size(x);
686      setring save;
687      pn = imap(@R,pn);
688      V  = V + leadcoef(pn)*gen(1);
689      for(k=1; k<=sx; k++)
690      {
691        if (x[k] ==1)
692        {
693          a = k / s; // block number=a+1, a!=0
694          b = k % s; // remainder
695          //          printf("a: %s, b: %s",a,b);
696          if (b == 0)
697          {
698            // that is it's the last var in the block
699            b = s;
700            a = a-1;
701          }
702          V = V + var(b)*gen(a+2);
703        }
704//         else
705//         {
706//           printf("error: the value x[k] is %s", x[k]);
707//           return(0);
708//         }
709      }
710      err = "V: " + string(V);
711      dbprint(ppl,err);
712      //      printf("V: %s", string(V));
713      N = N,V;
714      V  = 0;
715      setring @R;
716      p  = p - q;
717      pn = 0;
718    }
719    setring save;
720    LN[i] = simplify(N,2);
721    N     = 0;
722  }
723  setring save;
724  return(LN);
725}
726example
727{
728  "EXAMPLE:"; echo = 2;
729  ring r = 0,(x,y,z),(dp(1),dp(2));
730  module M = [-1,x,y],[-7,y,y],[3,x,x]; // stands for free poly -xy - 7yy - 3xx
731  module N = [1,x,y,x],[-1,y,x,y]; // stands for free poly xyx - yxy
732  list L; L[1] = M; L[2] = N; // list of modules stands for an ideal in free algebra
733  lst2str(L); // list to string conversion of input polynomials
734  def U = freeGBasis(L,5); // 5 is the degree bound
735  lst2str(U);
736}
737
738static proc crs(list LM, int d)
739"USAGE:  crs(L, d);  L a list of modules, d an integer
740RETURN:  ring
741PURPOSE: create a ring and shift the ideal
742EXAMPLE: example crs; shows examples
743"
744{
745  // d = up to degree, will be shifted to d+1
746  if (d<1) {"bad d"; return(0);}
747
748  int ppl = printlevel-voice+2;
749  string err = "";
750
751  int i,j,s;
752  def save = basering;
753  // determine max no of places in the input
754  int slm = size(LM); // numbers of polys in the ideal
755  int sm;
756  intvec iv;
757  module M;
758  for (i=1; i<=slm; i++)
759  {
760    // modules, e.g. free polynomials
761    M  = LM[i];
762    sm = ncols(M);
763    for (j=1; j<=sm; j++)
764    {
765      //vectors, e.g. free monomials
766      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
767    }
768  }
769  int D = Max(iv); // max size of input words
770  if (d<D) {"bad d"; return(LM);}
771  D = D + d-1;
772  //  D = d;
773  list LR  = ringlist(save);
774  list L, tmp;
775  L[1] = LR[1]; // ground field
776  L[4] = LR[4]; // quotient ideal
777  tmp  = LR[2]; // varnames
778  s = size(LR[2]);
779  for (i=1; i<=D; i++)
780  {
781    for (j=1; j<=s; j++)
782    {
783      tmp[i*s+j] = string(tmp[j])+"("+string(i)+")";
784    }
785  }
786  for (i=1; i<=s; i++)
787  {
788    tmp[i] = string(tmp[i])+"("+string(0)+")";
789  }
790  L[2] = tmp;
791  list OrigNames = LR[2];
792  // ordering: d blocks of the ord on r
793  // try to get whether the ord on r is blockord itself
794  s = size(LR[3]);
795  if (s==2)
796  {
797    // not a blockord, 1 block + module ord
798    tmp = LR[3][s]; // module ord
799    for (i=1; i<=D; i++)
800    {
801      LR[3][s-1+i] = LR[3][1];
802    }
803    LR[3][s+D] = tmp;
804  }
805  if (s>2)
806  {
807    // there are s-1 blocks
808    int nb = s-1;
809    tmp = LR[3][s]; // module ord
810    for (i=1; i<=D; i++)
811    {
812      for (j=1; j<=nb; j++)
813      {
814        LR[3][i*nb+j] = LR[3][j];
815      }
816    }
817    //    size(LR[3]);
818    LR[3][nb*(D+1)+1] = tmp;
819  }
820  L[3] = LR[3];
821  def @R = ring(L);
822  setring @R;
823  ideal I;
824  poly @p;
825  s = size(OrigNames);
826  //  "s:";s;
827  // convert LM to canonical vectors (no powers)
828  setring save;
829  kill M; // M was defined earlier
830  module M;
831  slm = size(LM); // numbers of polys in the ideal
832  int sv,k,l;
833  vector v;
834  //  poly p;
835  string sp;
836  setring @R;
837  poly @@p=0;
838  setring save;
839  for (l=1; l<=slm; l++)
840  {
841    // modules, e.g. free polynomials
842    M  = LM[l];
843    sm = ncols(M); // in intvec iv the sizes are stored
844    for (i=0; i<=d-iv[l]; i++)
845    {
846      // modules, e.g. free polynomials
847      for (j=1; j<=sm; j++)
848      {
849        //vectors, e.g. free monomials
850        v  = M[j];
851        sv = size(v);
852        //        "sv:";sv;
853        sp = "@@p = @@p + ";
854        for (k=2; k<=sv; k++)
855        {
856          sp = sp + string(v[k])+"("+string(k-2+i)+")*";
857        }
858        sp = sp + string(v[1])+";"; // coef;
859        setring @R;
860        execute(sp);
861        setring save;
862      }
863      setring @R;
864      //      "@@p:"; @@p;
865      I = I,@@p;
866      @@p = 0;
867      setring save;
868    }
869  }
870  setring @R;
871  export I;
872  return(@R);
873}
874example
875{
876  "EXAMPLE:"; echo = 2;
877  ring r = 0,(x,y,z),(dp(1),dp(2));
878  module M = [-1,x,y],[-7,y,y],[3,x,x];
879  module N = [1,x,y,x],[-1,y,x,y];
880  list L; L[1] = M; L[2] = N;
881  lst2str(L);
882  def U = crs(L,5);
883  setring U; U;
884  I;
885}
886
887static proc polylen(ideal I)
888{
889  // returns the ideal of length of polys
890  int i;
891  intvec J;
892  number s = 0;
893  for(i=1;i<=ncols(I);i++)
894  {
895    J[i] = size(I[i]);
896    s = s + J[i];
897  }
898  printf("the sum of length %s",s);
899  //  print(s);
900  return(J);
901}
902
903// new: uniting both mLR1 (homog) and mLR2 (nonhomog)
904proc makeLetterplaceRing(int d, list #)
905"USAGE:  makeLetterplaceRing(d [,h]); d an integer, h an optional integer
906RETURN:  ring
907PURPOSE: creates a ring with the ordering, used in letterplace computations
908NOTE: if h is given and nonzero, the pure homogeneous letterplace block ordering will be used.
909EXAMPLE: example makeLetterplaceRing; shows examples
910"
911{
912  int use_old_mlr = 0;
913  if ( size(#)>0 )
914  {
915    if (( typeof(#[1]) == "int" ) || ( typeof(#[1]) == "poly" ) )
916    {
917      poly x = poly(#[1]);
918      if (x!=0)
919      {
920        use_old_mlr = 1;
921      }
922    }
923  }
924  if (use_old_mlr)
925  {
926    def @A = makeLetterplaceRing1(d);
927  }
928  else
929  {
930    def @A = makeLetterplaceRing2(d);
931  }
932  return(@A);
933}
934example
935{
936  "EXAMPLE:"; echo = 2;
937  ring r = 0,(x,y,z),(dp(1),dp(2));
938  def A = makeLetterplaceRing(2);
939  setring A;  A;
940  attrib(A,"isLetterplaceRing");
941  attrib(A,"uptodeg");  // degree bound
942  attrib(A,"lV"); // number of variables in the main block
943  setring r; def B = makeLetterplaceRing(2,1); // to compare:
944  setring B;  B;
945}
946
947//proc freegbRing(int d)
948proc makeLetterplaceRing1(int d)
949"USAGE:  makeLetterplaceRing1(d); d an integer
950RETURN:  ring
951PURPOSE: creates a ring with a special ordering, suitable for
952@* the use of homogeneous letterplace (d blocks of shifted original variables)
953EXAMPLE: example makeLetterplaceRing1; shows examples
954"
955{
956  // d = up to degree, will be shifted to d+1
957  if (d<1) {"bad d"; return(0);}
958
959  int uptodeg = d; int lV = nvars(basering);
960
961  int ppl = printlevel-voice+2;
962  string err = "";
963
964  int i,j,s;
965  def save = basering;
966  int D = d-1;
967  list LR  = ringlist(save);
968  list L, tmp;
969  L[1] = LR[1]; // ground field
970  L[4] = LR[4]; // quotient ideal
971  tmp  = LR[2]; // varnames
972  s = size(LR[2]);
973  for (i=1; i<=D; i++)
974  {
975    for (j=1; j<=s; j++)
976    {
977      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
978    }
979  }
980  for (i=1; i<=s; i++)
981  {
982    tmp[i] = string(tmp[i])+"("+string(1)+")";
983  }
984  L[2] = tmp;
985  list OrigNames = LR[2];
986  // ordering: d blocks of the ord on r
987  // try to get whether the ord on r is blockord itself
988  // TODO: make L(2) ordering! exponent is maximally 2
989  s = size(LR[3]);
990  if (s==2)
991  {
992    // not a blockord, 1 block + module ord
993    tmp = LR[3][s]; // module ord
994    for (i=1; i<=D; i++)
995    {
996      LR[3][s-1+i] = LR[3][1];
997    }
998    LR[3][s+D] = tmp;
999  }
1000  if (s>2)
1001  {
1002    // there are s-1 blocks
1003    int nb = s-1;
1004    tmp = LR[3][s]; // module ord
1005    for (i=1; i<=D; i++)
1006    {
1007      for (j=1; j<=nb; j++)
1008      {
1009        LR[3][i*nb+j] = LR[3][j];
1010      }
1011    }
1012    //    size(LR[3]);
1013    LR[3][nb*(D+1)+1] = tmp;
1014  }
1015  L[3] = LR[3];
1016  def @R = ring(L);
1017  //  setring @R;
1018  //  int uptodeg = d; int lV = nvars(basering); // were defined before
1019  def @@R = setLetterplaceAttributes(@R,uptodeg,lV);
1020  return (@@R);
1021}
1022example
1023{
1024  "EXAMPLE:"; echo = 2;
1025  ring r = 0,(x,y,z),(dp(1),dp(2));
1026  def A = makeLetterplaceRing1(2);
1027  setring A;
1028  A;
1029  attrib(A,"isLetterplaceRing");
1030  attrib(A,"uptodeg");  // degree bound
1031  attrib(A,"lV"); // number of variables in the main block
1032}
1033
1034proc makeLetterplaceRing2(int d)
1035"USAGE:  makeLetterplaceRing2(d); d an integer
1036RETURN:  ring
1037PURPOSE: creates a ring with a special ordering, suitable for
1038@* the use of non-homogeneous letterplace
1039NOTE: the matrix for the ordering looks as follows: first row is 1,1,...,1
1040@* then there come 'd' blocks of shifted original variables
1041EXAMPLE: example makeLetterplaceRing2; shows examples
1042"
1043{
1044  // d = up to degree, will be shifted to d+1
1045  if (d<1) {"bad d"; return(0);}
1046
1047  int uptodeg = d; int lV = nvars(basering);
1048
1049  int ppl = printlevel-voice+2;
1050  string err = "";
1051
1052  int i,j,s;
1053  def save = basering;
1054  int D = d-1;
1055  list LR  = ringlist(save);
1056  list L, tmp, tmp2, tmp3;
1057  L[1] = LR[1]; // ground field
1058  L[4] = LR[4]; // quotient ideal
1059  tmp  = LR[2]; // varnames
1060  s = size(LR[2]);
1061  for (i=1; i<=D; i++)
1062  {
1063    for (j=1; j<=s; j++)
1064    {
1065      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
1066    }
1067  }
1068  for (i=1; i<=s; i++)
1069  {
1070    tmp[i] = string(tmp[i])+"("+string(1)+")";
1071  }
1072  L[2] = tmp;
1073  list OrigNames = LR[2];
1074  // ordering: one 1..1 a above
1075  // ordering: d blocks of the ord on r
1076  // try to get whether the ord on r is blockord itself
1077  // TODO: make L(2) ordering! exponent is maximally 2
1078  s = size(LR[3]);
1079  if (s==2)
1080  {
1081    // not a blockord, 1 block + module ord
1082    tmp = LR[3][s]; // module ord
1083    for (i=1; i<=d; i++)
1084    {
1085      LR[3][s-1+i] = LR[3][1];
1086    }
1087    //    LR[3][s+D] = tmp;
1088    LR[3][s+1+D] = tmp;
1089    LR[3][1] = list("a",intvec(1: int(d*lV))); // deg-ord
1090  }
1091  if (s>2)
1092  {
1093    // there are s-1 blocks
1094    int nb = s-1;
1095    tmp = LR[3][s]; // module ord to place at the very end
1096    tmp2 = LR[3]; tmp2 = tmp2[1..nb];
1097    tmp3[1] = list("a",intvec(1: int(d*lV))); // deg-ord, insert as the 1st
1098    for (i=1; i<=d; i++)
1099    {
1100      tmp3 = tmp3 + tmp2;
1101    }
1102    tmp3 = tmp3 + list(tmp);
1103    LR[3] = tmp3;
1104//     for (i=1; i<=d; i++)
1105//     {
1106//       for (j=1; j<=nb; j++)
1107//       {
1108//         //        LR[3][i*nb+j+1]= LR[3][j];
1109//         LR[3][i*nb+j+1]= tmp2[j];
1110//       }
1111//     }
1112//     //    size(LR[3]);
1113//     LR[3][(s-1)*d+2] = tmp;
1114//     LR[3] = list("a",intvec(1: int(d*lV))) + LR[3]; // deg-ord, insert as the 1st
1115    // remove everything behind nb*(D+1)+1 ?
1116    //    tmp = LR[3];
1117    //    LR[3] = tmp[1..size(tmp)-1];
1118  }
1119  L[3] = LR[3];
1120  def @R = ring(L);
1121  //  setring @R;
1122  //  int uptodeg = d; int lV = nvars(basering); // were defined before
1123  def @@R = setLetterplaceAttributes(@R,uptodeg,lV);
1124  return (@@R);
1125}
1126example
1127{
1128  "EXAMPLE:"; echo = 2;
1129  ring r = 0,(x,y,z),(dp(1),dp(2));
1130  def A = makeLetterplaceRing2(2);
1131  setring A;
1132  A;
1133  attrib(A,"isLetterplaceRing");
1134  attrib(A,"uptodeg");  // degree bound
1135  attrib(A,"lV"); // number of variables in the main block
1136}
1137
1138
1139proc makeLetterplaceRing3(int d)
1140"USAGE:  makeLetterplaceRing1(d); d an integer
1141RETURN:  ring
1142PURPOSE: creates a ring with a special ordering, representing
1143@* the original P[s,sigma] (adds d blocks of shifted s)
1144ASSUME: basering is a letterplace ring as well
1145NOTE: experimental status
1146EXAMPLE: example makeLetterplaceRing1; shows examples
1147"
1148{
1149  // d = up to degree, will be shifted to d+1
1150  if (d<1) {"bad d"; return(0);}
1151
1152  int uptodeg = d; int lV = nvars(basering);
1153
1154  int ppl = printlevel-voice+2;
1155  string err = "";
1156
1157  int i,j,s;
1158  def save = basering;
1159  int D = d-1;
1160  list LR  = ringlist(save);
1161  list L, tmp;
1162  L[1] = LR[1]; // ground field
1163  L[4] = LR[4]; // quotient ideal
1164  tmp  = LR[2]; // varnames
1165  tmp[size(tmp)+1] = "s";
1167  //  string newSname = "@s";
1168  s = size(LR[2]);
1169  for (i=1; i<=D; i++)
1170  {
1171    for (j=1; j<=s; j++)
1172    {
1173      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
1174    }
1175  }
1176  // the final index is D*s+s = (D+1)*s = degBound*s
1177  for (i=1; i<=d; i++)
1178  {
1179    tmp[FIndex + i] =  string(newSname)+"("+string(i)+")";
1180  }
1181  L[2] = tmp;
1182  list OrigNames = LR[2];
1183  // ordering: d blocks of the MODIFIED ord on r
1184  // try to get whether the ord on r is blockord itself
1185  // TODO: make L(2) ordering! exponent is maximally 2
1186  s = size(LR[3]);
1187
1188  // assume: basering was a letterplace, so get its block
1189  tmp = LR[3][1]; // ASSUME: it's a nice block
1190  // modify it
1191  // add (0,..,0,1) ... as antiblock part
1192  intvec iv; list ttmp, tmp1;
1193  for (i=1; i<=d; i++)
1194  {
1195    // the position to hold 1:
1196    iv = intvec( gen( i*(lV+1)-1 ) );
1197    ttmp[1] = "a";
1198    ttmp[2] = iv;
1199    tmp1[i] = ttmp;
1200  }
1201  // finished: antiblock part //TOCONTINUE
1202
1203  if (s==2)
1204  {
1205    // not a blockord, 1 block + module ord
1206    tmp = LR[3][s]; // module ord
1207    for (i=1; i<=D; i++)
1208    {
1209      LR[3][s-1+i] = LR[3][1];
1210    }
1211    LR[3][s+D] = tmp;
1212  }
1213  if (s>2)
1214  {
1215    // there are s-1 blocks
1216    int nb = s-1;
1217    tmp = LR[3][s]; // module ord
1218    for (i=1; i<=D; i++)
1219    {
1220      for (j=1; j<=nb; j++)
1221      {
1222        LR[3][i*nb+j] = LR[3][j];
1223      }
1224    }
1225    //    size(LR[3]);
1226    LR[3][nb*(D+1)+1] = tmp;
1227  }
1228  L[3] = LR[3];
1229  def @R = ring(L);
1230  //  setring @R;
1231  //  int uptodeg = d; int lV = nvars(basering); // were defined before
1232  def @@R = setLetterplaceAttributes(@R,uptodeg,lV);
1233  return (@@R);
1234}
1235example
1236{
1237  "EXAMPLE:"; echo = 2;
1238  ring r = 0,(x,y,z),(dp(1),dp(2));
1239  def A = makeLetterplaceRing3(2);
1240  setring A;
1241  A;
1242  attrib(A,"isLetterplaceRing");
1243  attrib(A,"uptodeg");  // degree bound
1244  attrib(A,"lV"); // number of variables in the main block
1245}
1246
1247
1248
1249/* EXAMPLES:
1250
1251//static proc ex_shift()
1252{
1253  LIB "freegb.lib";
1254  ring r = 0,(x,y,z),(dp(1),dp(2));
1255  module M = [-1,x,y],[-7,y,y],[3,x,x];
1256  module N = [1,x,y,x],[-1,y,x,y];
1257  list L; L[1] = M; L[2] = N;
1258  lst2str(L);
1259  def U = crs(L,5);
1260  setring U; U;
1261  I;
1262  poly p = I[2]; // I[8];
1263  p;
1264  system("stest",p,7,7,3); // error -> the world is ok
1265  poly q1 = system("stest",p,1,7,3); //ok
1266  poly q6 = system("stest",p,6,7,3); //ok
1267  system("btest",p,3); //ok
1268  system("btest",q1,3); //ok
1269  system("btest",q6,3); //ok
1270}
1271
1272//static proc test_shrink()
1273{
1274  LIB "freegb.lib";
1275  ring r =0,(x,y,z),dp;
1276  int d = 5;
1277  def R = makeLetterplaceRing(d);
1278  setring R;
1279  poly p1 = x(1)*y(2)*z(3);
1280  poly p2 = x(1)*y(4)*z(5);
1281  poly p3 = x(1)*y(1)*z(3);
1282  poly p4 = x(1)*y(2)*z(2);
1283  poly p5 = x(3)*z(5);
1284  poly p6 = x(1)*y(1)*x(3)*z(5);
1285  poly p7 = x(1)*y(2)*x(3)*y(4)*z(5);
1286  poly p8 = p1+p2+p3+p4+p5 + p6 + p7;
1287  p1; system("shrinktest",p1,3);
1288  p2; system("shrinktest",p2,3);
1289  p3; system("shrinktest",p3,3);
1290  p4; system("shrinktest",p4,3);
1291  p5; system("shrinktest",p5,3);
1292  p6; system("shrinktest",p6,3);
1293  p7; system("shrinktest",p7,3);
1294  p8; system("shrinktest",p8,3);
1295  poly p9 = p1 + 2*p2 + 5*p5 + 7*p7;
1296  p9; system("shrinktest",p9,3);
1297}
1298
1299//static proc ex2()
1300{
1301  option(prot);
1302  LIB "freegb.lib";
1303  ring r = 0,(x,y),dp;
1304  module M = [-1,x,y],[3,x,x]; // 3x^2 - xy
1305  def U = freegb(M,7);
1306  lst2str(U);
1307}
1308
1309//static proc ex_nonhomog()
1310{
1311  option(prot);
1312  LIB "freegb.lib";
1313  ring r = 0,(x,y,h),dp;
1314  list L;
1315  module M;
1316  M = [-1,y,y],[1,x,x,x];  // x3-y2
1317  L[1] = M;
1318  M = [1,x,h],[-1,h,x];  // xh-hx
1319  L[2] = M;
1320  M = [1,y,h],[-1,h,y];  // yh-hy
1321  L[3] = M;
1322  def U = freegb(L,4);
1323  lst2str(U);
1324  // strange elements in the basis
1325}
1326
1327//static proc ex_nonhomog_comm()
1328{
1329  option(prot);
1330  LIB "freegb.lib";
1331  ring r = 0,(x,y),dp;
1332  module M = [-1,y,y],[1,x,x,x];
1333  def U = freegb(M,5);
1334  lst2str(U);
1335}
1336
1337//static proc ex_nonhomog_h()
1338{
1339  option(prot);
1340  LIB "freegb.lib";
1341  ring r = 0,(x,y,h),(a(1,1),dp);
1342  module M = [-1,y,y,h],[1,x,x,x]; // x3 - y2h
1343  def U = freegb(M,6);
1344  lst2str(U);
1345}
1346
1347//static proc ex_nonhomog_h2()
1348{
1349  option(prot);
1350  LIB "freegb.lib";
1351  ring r = 0,(x,y,h),(dp);
1352  list L;
1353  module M;
1354  M = [-1,y,y,h],[1,x,x,x]; // x3 - y2h
1355  L[1] = M;
1356  M = [1,x,h],[-1,h,x]; // xh - hx
1357  L[2] = M;
1358  M = [1,y,h],[-1,h,y]; // yh - hy
1359  L[3] = M;
1360  def U = freeGBasis(L,3);
1361  lst2str(U);
1363}
1364
1365
1366//static proc ex_nonhomog_3()
1367{
1368  option(prot);
1369  LIB "./freegb.lib";
1370  ring r = 0,(x,y,z),(dp);
1371  list L;
1372  module M;
1373  M = [1,z,y],[-1,x]; // zy - x
1374  L[1] = M;
1375  M = [1,z,x],[-1,y]; // zx - y
1376  L[2] = M;
1377  M = [1,y,x],[-1,z]; // yx - z
1378  L[3] = M;
1379  lst2str(L);
1380  list U = freegb(L,4);
1381  lst2str(U);
1383}
1384
1385//static proc ex_densep_2()
1386{
1387  option(prot);
1388  LIB "freegb.lib";
1389  ring r = (0,a,b,c),(x,y),(Dp); // deglex
1390  module M = [1,x,x], [a,x,y], [b,y,x], [c,y,y];
1391  lst2str(M);
1392  list U = freegb(M,5);
1393  lst2str(U);
1394  // a=b is important -> finite basis!!!
1395  module M = [1,x,x], [a,x,y], [a,y,x], [c,y,y];
1396  lst2str(M);
1397  list U = freegb(M,5);
1398  lst2str(U);
1399}
1400
1401// END COMMENTED EXAMPLES
1402
1403*/
1404
1405// 1. form a new ring
1406// 2. produce shifted generators
1407// 3. compute GB
1408// 4. skip shifted elts
1409// 5. go back to orig vars, produce strings/modules
1410// 6. return the result
1411
1412static proc freegbold(list LM, int d)
1413"USAGE:  freegbold(L, d);  L a list of modules, d an integer
1414RETURN:  ring
1415PURPOSE: compute the two-sided Groebner basis of an ideal, encoded by L in
1416the free associative algebra, up to degree d
1417EXAMPLE: example freegbold; shows examples
1418"
1419{
1420  // d = up to degree, will be shifted to d+1
1421  if (d<1) {"bad d"; return(0);}
1422
1423  int ppl = printlevel-voice+2;
1424  string err = "";
1425
1426  int i,j,s;
1427  def save = basering;
1428  // determine max no of places in the input
1429  int slm = size(LM); // numbers of polys in the ideal
1430  int sm;
1431  intvec iv;
1432  module M;
1433  for (i=1; i<=slm; i++)
1434  {
1435    // modules, e.g. free polynomials
1436    M  = LM[i];
1437    sm = ncols(M);
1438    for (j=1; j<=sm; j++)
1439    {
1440      //vectors, e.g. free monomials
1441      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
1442    }
1443  }
1444  int D = Max(iv); // max size of input words
1445  if (d<D) {"bad d"; return(LM);}
1446  D = D + d-1;
1447  //  D = d;
1448  list LR  = ringlist(save);
1449  list L, tmp;
1450  L[1] = LR[1]; // ground field
1451  L[4] = LR[4]; // quotient ideal
1452  tmp  = LR[2]; // varnames
1453  s = size(LR[2]);
1454  for (i=1; i<=D; i++)
1455  {
1456    for (j=1; j<=s; j++)
1457    {
1458      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
1459    }
1460  }
1461  for (i=1; i<=s; i++)
1462  {
1463    tmp[i] = string(tmp[i])+"("+string(1)+")";
1464  }
1465  L[2] = tmp;
1466  list OrigNames = LR[2];
1467  // ordering: d blocks of the ord on r
1468  // try to get whether the ord on r is blockord itself
1469  // TODO: make L(2) ordering! exponent is maximally 2
1470  s = size(LR[3]);
1471  if (s==2)
1472  {
1473    // not a blockord, 1 block + module ord
1474    tmp = LR[3][s]; // module ord
1475    for (i=1; i<=D; i++)
1476    {
1477      LR[3][s-1+i] = LR[3][1];
1478    }
1479    LR[3][s+D] = tmp;
1480  }
1481  if (s>2)
1482  {
1483    // there are s-1 blocks
1484    int nb = s-1;
1485    tmp = LR[3][s]; // module ord
1486    for (i=1; i<=D; i++)
1487    {
1488      for (j=1; j<=nb; j++)
1489      {
1490        LR[3][i*nb+j] = LR[3][j];
1491      }
1492    }
1493    //    size(LR[3]);
1494    LR[3][nb*(D+1)+1] = tmp;
1495  }
1496  L[3] = LR[3];
1497  def @R = ring(L);
1498  setring @R;
1499  ideal I;
1500  poly @p;
1501  s = size(OrigNames);
1502  //  "s:";s;
1503  // convert LM to canonical vectors (no powers)
1504  setring save;
1505  kill M; // M was defined earlier
1506  module M;
1507  slm = size(LM); // numbers of polys in the ideal
1508  int sv,k,l;
1509  vector v;
1510  //  poly p;
1511  string sp;
1512  setring @R;
1513  poly @@p=0;
1514  setring save;
1515  for (l=1; l<=slm; l++)
1516  {
1517    // modules, e.g. free polynomials
1518    M  = LM[l];
1519    sm = ncols(M); // in intvec iv the sizes are stored
1520    for (i=0; i<=d-iv[l]; i++)
1521    {
1522      // modules, e.g. free polynomials
1523      for (j=1; j<=sm; j++)
1524      {
1525        //vectors, e.g. free monomials
1526        v  = M[j];
1527        sv = size(v);
1528        //        "sv:";sv;
1529        sp = "@@p = @@p + ";
1530        for (k=2; k<=sv; k++)
1531        {
1532          sp = sp + string(v[k])+"("+string(k-1+i)+")*";
1533        }
1534        sp = sp + string(v[1])+";"; // coef;
1535        setring @R;
1536        execute(sp);
1537        setring save;
1538      }
1539      setring @R;
1540      //      "@@p:"; @@p;
1541      I = I,@@p;
1542      @@p = 0;
1543      setring save;
1544    }
1545  }
1546  kill sp;
1547  // 3. compute GB
1548  setring @R;
1549  dbprint(ppl,"computing GB");
1550  //  ideal J = groebner(I);
1551  ideal J = slimgb(I);
1552  dbprint(ppl,J);
1553  // 4. skip shifted elts
1554  ideal K = select1(J,1..s); // s = size(OrigNames)
1555  dbprint(ppl,K);
1556  dbprint(ppl, "done with GB");
1557  // K contains vars x(1),...z(1) = images of originals
1558  // 5. go back to orig vars, produce strings/modules
1559  if (K[1] == 0)
1560  {
1561    "no reasonable output, GB gives 0";
1562    return(0);
1563  }
1564  int sk = size(K);
1565  int sp, sx, a, b;
1566  intvec x;
1567  poly p,q;
1568  poly pn;
1569  // vars in 'save'
1570  setring save;
1571  module N;
1572  list LN;
1573  vector V;
1574  poly pn;
1575  // test and skip exponents >=2
1576  setring @R;
1577  for(i=1; i<=sk; i++)
1578  {
1579    p  = K[i];
1580    while (p!=0)
1581    {
1583      //      "processing q:";q;
1585      sx = size(x);
1586      for(k=1; k<=sx; k++)
1587      {
1588        if ( x[k] >= 2 )
1589        {
1590          err = "skip: the value x[k] is " + string(x[k]);
1591          dbprint(ppl,err);
1592          //            return(0);
1593          K[i] = 0;
1594          p    = 0;
1595          q    = 0;
1596          break;
1597        }
1598      }
1599      p  = p - q;
1600    }
1601  }
1602  K  = simplify(K,2);
1603  sk = size(K);
1604  for(i=1; i<=sk; i++)
1605  {
1606    //    setring save;
1607    //    V  = 0;
1608    setring @R;
1609    p  = K[i];
1610    while (p!=0)
1611    {
1613      err =  "processing q:" + string(q);
1614      dbprint(ppl,err);
1616      sx = size(x);
1618      setring save;
1619      pn = imap(@R,pn);
1620      V  = V + leadcoef(pn)*gen(1);
1621      for(k=1; k<=sx; k++)
1622      {
1623        if (x[k] ==1)
1624        {
1625          a = k / s; // block number=a+1, a!=0
1626          b = k % s; // remainder
1627          //          printf("a: %s, b: %s",a,b);
1628          if (b == 0)
1629          {
1630            // that is it's the last var in the block
1631            b = s;
1632            a = a-1;
1633          }
1634          V = V + var(b)*gen(a+2);
1635        }
1636//         else
1637//         {
1638//           printf("error: the value x[k] is %s", x[k]);
1639//           return(0);
1640//         }
1641      }
1642      err = "V: " + string(V);
1643      dbprint(ppl,err);
1644      //      printf("V: %s", string(V));
1645      N = N,V;
1646      V  = 0;
1647      setring @R;
1648      p  = p - q;
1649      pn = 0;
1650    }
1651    setring save;
1652    LN[i] = simplify(N,2);
1653    N     = 0;
1654  }
1655  setring save;
1656  return(LN);
1657}
1658example
1659{
1660  "EXAMPLE:"; echo = 2;
1661  ring r = 0,(x,y,z),(dp(1),dp(2));
1662  module M = [-1,x,y],[-7,y,y],[3,x,x];
1663  module N = [1,x,y,x],[-1,y,x,y];
1664  list L; L[1] = M; L[2] = N;
1665  lst2str(L);
1666  def U = freegbold(L,5);
1667  lst2str(U);
1668}
1669
1670/* begin older procs and tests
1671
1672static proc sgb(ideal I, int d)
1673{
1674  // new code
1675  // map x_i to x_i(1) via map()
1676  //LIB "freegb.lib";
1677  def save = basering;
1678  //int d =7;// degree
1679  int nv = nvars(save);
1680  def R = makeLetterplaceRing(d);
1681  setring R;
1682  int i;
1683  ideal Imap;
1684  for (i=1; i<=nv; i++)
1685  {
1686    Imap[i] = var(i);
1687  }
1688  //ideal I = x(1)*y(2), y(1)*x(2)+z(1)*z(2);
1689  ideal I = x(1)*x(2),x(1)*y(2) + z(1)*x(2);
1690  option(prot);
1691  //option(teach);
1692  ideal J = system("freegb",I,d,nv);
1693}
1694
1695static proc checkCeq()
1696{
1697  ring r = 0,(x,y),Dp;
1698  def A = makeLetterplaceRing(4);
1699  setring A;
1700  A;
1701  // I = x2-xy
1702  ideal I = x(1)*x(2) - x(1)*y(2), x(2)*x(3) - x(2)*y(3), x(3)*x(4) - x(3)*y(4);
1703  ideal C = x(2)-x(1),x(3)-x(2),x(4)-x(3),y(2)-y(1),y(3)-y(2),y(4)-y(3);
1704  ideal K = I,C;
1705  groebner(K);
1706}
1707
1708static proc exHom1()
1709{
1711  // z*y - x, z*x - y, y*x - z
1712  LIB "freegb.lib";
1713  LIB "elim.lib";
1714  ring r = 0,(x,y,z,h),dp;
1715  list L;
1716  module M;
1717  M = [1,z,y],[-1,x,h]; // zy - xh
1718  L[1] = M;
1719  M = [1,z,x],[-1,y,h]; // zx - yh
1720  L[2] = M;
1721  M = [1,y,x],[-1,z,h]; // yx - zh
1722  L[3] = M;
1723  lst2str(L);
1724  def U = crs(L,4);
1725  setring U;
1726  I = I,
1727    y(2)*h(3)+z(2)*x(3),     y(3)*h(4)+z(3)*x(4),
1728    y(2)*x(3)-z(2)*h(3),     y(3)*x(4)-z(3)*h(4);
1729  I = simplify(I,2);
1730  ring r2 = 0,(x(0..4),y(0..4),z(0..4),h(0..4)),dp;
1731  ideal J = imap(U,I);
1732  //  ideal K = homog(J,h);
1733  option(redSB);
1734  option(redTail);
1735  ideal L = groebner(J); //(K);
1736  ideal LL = sat(L,ideal(h))[1];
1737  ideal M = subst(LL,h,1);
1738  M = simplify(M,2);
1739  setring U;
1740  ideal M = imap(r2,M);
1741  lst2str(U);
1742}
1743
1744static proc test1()
1745{
1746  LIB "freegb.lib";
1747  ring r = 0,(x,y),Dp;
1748  int d = 10; // degree
1749  def R = makeLetterplaceRing(d);
1750  setring R;
1751  ideal I = x(1)*x(2) - y(1)*y(2);
1752  option(prot);
1753  option(teach);
1754  ideal J = system("freegb",I,d,2);
1755  J;
1756}
1757
1758static proc test2()
1759{
1760  LIB "freegb.lib";
1761  ring r = 0,(x,y),Dp;
1762  int d = 10; // degree
1763  def R = makeLetterplaceRing(d);
1764  setring R;
1765  ideal I = x(1)*x(2) - x(1)*y(2);
1766  option(prot);
1767  option(teach);
1768  ideal J = system("freegb",I,d,2);
1769  J;
1770}
1771
1772static proc test3()
1773{
1774  LIB "freegb.lib";
1775  ring r = 0,(x,y,z),dp;
1776  int d =5; // degree
1777  def R = makeLetterplaceRing(d);
1778  setring R;
1779  ideal I = x(1)*y(2), y(1)*x(2)+z(1)*z(2);
1780  option(prot);
1781  option(teach);
1782  ideal J = system("freegb",I,d,3);
1783}
1784
1785static proc schur2-3()
1786{
1787  // nonhomog:
1788  //  h^4-10*h^2+9,f*e-e*f+h, h*2-e*h-2*e,h*f-f*h+2*f
1789  // homogenized with t
1790  //  h^4-10*h^2*t^2+9*t^4,f*e-e*f+h*t, h*2-e*h-2*e*t,h*f-f*h+2*f*t,
1791  // t*h - h*t, t*f - f*t, t*e - e*t
1792}
1793
1794end older procs and tests */
1795
1798RETURN:  ring (and exports ideal)
1799ASSUME: there are at least i+j variables in the basering
1800PURPOSE: compute the ideal of Adem relations for i<2j in characteristic 0
1801@*  the ideal is exported under the name AdemRel in the output ring
1803"
1804{
1805  // produces Adem relations for i<2j in char 0
1806  // assume: 0<i<2j
1807  // requires presence of vars up to i+j
1808  if ( (i<0) || (i >= 2*j) )
1809  {
1810    ERROR("arguments out of range"); return(0);
1811  }
1812  ring @r = 0,(s(i+j..0)),lp;
1813  poly p,q;
1814  number n;
1815  int ii = i div 2; int k;
1816  // k=0 => s(0)=1
1817  n = binomial(j-1,i);
1818  q = n*s(i+j)*s(0);
1819  //  printf("k=0, term=%s",q);
1820  p = p + q;
1821  for (k=1; k<= ii; k++)
1822  {
1823    n = binomial(j-k-1,i-2*k);
1824    q = n*s(i+j-k)*s(k);;
1825    //    printf("k=%s, term=%s",k,q);
1826    p = p + q;
1827  }
1830  return(@r);
1831}
1832example
1833{
1834  "EXAMPLE:"; echo = 2;
1836  setring A;
1838}
1839
1840/*
18411,1: 0
18421,2: s(3)*s(0) == s(3) -> def for s(3):=s(1)s(2)
18442,2: s(3)*s(1) == s(1)s(2)s(1)
18451,3: 0 ( since 2*s(4)*s(0) = 0 mod 2)
18472,3: s(5)*s(0)+s(4)*s(1) == s(5)+s(4)*s(1)
18483,2: 0
18493,3: s(5)*s(1)
18501,4: 3*s(5)*s(0) == s(5)  -> def for s(5):=s(1)*s(4)
18522,4: 3*s(6)*s(0)+s(5)*s(1) == s(6) + s(5)*s(1) == s(6) + s(1)*s(4)*s(1)
18544,3: s(5)*s(2)
18553,4: s(7)*s(0)+2*s(6)*s(1) == s(7) -> def for s(7):=s(3)*s(4)
18564,4: s(7)*s(1)+s(6)*s(2)
1857*/
1858
1859/* s1,s2:
1860s1*s1 =0, s2*s2 = s1*s2*s1
1861*/
1862
1863/*
1864try char 0:
1865s1,s2:
1866s1*s1 =0, s2*s2 = s1*s2*s1, s(1)*s(3)== s(1)*s(1)*s(3) == 0 = 2*s(4) ->def for s(4)
1867hence 2==0! only in char 2
1868 */
1869
1870  // Adem rels modulo 2 are interesting
1871
1872static proc stringpoly2lplace(string s)
1873{
1874  // decomposes sentence into terms
1875  s = replace(s,newline,""); // get rid of newlines
1876  s = replace(s," ",""); // get rid of empties
1877  //arith symbols: +,-
1878  // decompose into words with coeffs
1879  list LS;
1880  int i,j,ie,je,k,cnt;
1881  // s[1]="-" situation
1882  if (s[1]=="-")
1883  {
1884    LS = stringpoly2lplace(string(s[2..size(s)]));
1885    LS[1] = string("-"+string(LS[1]));
1886    return(LS);
1887  }
1888  i = find(s,"-",2);
1889  // i==1 might happen if the 1st symbol coeff is negative
1890  j = find(s,"+");
1891  list LL;
1892  if (i==j)
1893  {
1894    "return a monomial";
1895    // that is both are 0 -> s is a monomial
1896    LS[1] = s;
1897    return(LS);
1898  }
1899  if (i==0)
1900  {
1901    "i==0 situation";
1902    // no minuses at all => pluses only
1903    cnt++;
1904    LS[cnt] = string(s[1..j-1]);
1905    s = s[j+1..size(s)];
1906    while (s!= "")
1907    {
1908      j = find(s,"+");
1909      cnt++;
1910      if (j==0)
1911      {
1912        LS[cnt] = string(s);
1913        s = "";
1914      }
1915      else
1916      {
1917        LS[cnt] = string(s[1..j-1]);
1918        s = s[j+1..size(s)];
1919      }
1920    }
1921    return(LS);
1922  }
1923  if (j==0)
1924  {
1925    "j==0 situation";
1926    // no pluses at all except the lead coef => the rest are minuses only
1927    cnt++;
1928    LS[cnt] = string(s[1..i-1]);
1929    s = s[i..size(s)];
1930    while (s!= "")
1931    {
1932      i = find(s,"-",2);
1933      cnt++;
1934      if (i==0)
1935      {
1936        LS[cnt] = string(s);
1937        s = "";
1938      }
1939      else
1940      {
1941        LS[cnt] = string(s[1..i-1]);
1942        s = s[i..size(s)];
1943      }
1944    }
1945    return(LS);
1946  }
1947  // now i, j are nonzero
1948  if (i>j)
1949  {
1950    "i>j situation";
1951    // + comes first, at place j
1952    cnt++;
1953    //    "cnt:"; cnt; "j:"; j;
1954    LS[cnt] = string(s[1..j-1]);
1955    s = s[j+1..size(s)];
1956    LL = stringpoly2lplace(s);
1957    LS = LS + LL;
1958    kill LL;
1959    return(LS);
1960  }
1961  else
1962  {
1963    "j>i situation";
1964    // - might come first, at place i
1965    if (i>1)
1966    {
1967      cnt++;
1968      LS[cnt] = string(s[1..i-1]);
1969      s = s[i..size(s)];
1970    }
1971    else
1972    {
1973      // i==1->  minus at leadcoef
1974      ie = find(s,"-",i+1);
1975      je = find(s,"+",i+1);
1976      if (je == ie)
1977      {
1978         "ie=je situation";
1979        //monomial
1980        cnt++;
1981        LS[cnt] = s;
1982        return(LS);
1983      }
1984      if (je < ie)
1985      {
1986         "je<ie situation";
1987        // + comes first
1988        cnt++;
1989        LS[cnt] = s[1..je-1];
1990        s = s[je+1..size(s)];
1991      }
1992      else
1993      {
1994        // ie < je
1995         "ie<je situation";
1996        cnt++;
1997        LS[cnt] = s[1..ie-1];
1998        s = s[ie..size(s)];
1999      }
2000    }
2001    "going into recursion with "+s;
2002    LL = stringpoly2lplace(s);
2003    LS = LS + LL;
2004    return(LS);
2005  }
2006}
2007example
2008{
2009  "EXAMPLE:"; echo = 2;
2010  string s = "x*y+y*z+z*t"; // + only
2011  stringpoly2lplace(s);
2012  string s2 = "x*y - y*z-z*t*w*w"; // +1, - only
2013  stringpoly2lplace(s2);
2014  string s3 = "-x*y + y - 2*x +7*w*w*w";
2015  stringpoly2lplace(s3);
2016}
2017
2019{
2020  // adds places to the list of strings
2021  // according to their order in the list
2022  int s = size(L);
2023  int i;
2024  for (i=1; i<=s; i++)
2025  {
2026    if (typeof(L[i]) == "string")
2027    {
2028      L[i] = L[i] + "(" + string(i) + ")";
2029    }
2030    else
2031    {
2032      ERROR("entry of type string expected");
2033      return(0);
2034    }
2035  }
2036  return(L);
2037}
2038example
2039{
2040  "EXAMPLE:"; echo = 2;
2041  string a = "f1";   string b = "f2";
2042  list L = a,b,a;
2044}
2045
2046static proc sent2lplace(string s)
2047{
2048  // SENTence of words TO LetterPLACE
2049  list L =   stringpoly2lplace(s);
2050  int i; int ss = size(L);
2051  for(i=1; i<=ss; i++)
2052  {
2053    L[i] = str2lplace(L[i]);
2054  }
2055  return(L);
2056}
2057example
2058{
2059  "EXAMPLE:"; echo = 2;
2060  ring r = 0,(f2,f1),dp;
2061  string s = "f2*f1*f1 - 2*f1*f2*f1+ f1*f1*f2";
2062  sent2lplace(s);
2063}
2064
2065static proc testnumber(string s)
2066{
2067  string t;
2068  if (s[1]=="-")
2069  {
2070    // two situations: either there's a negative number
2071    t = s[2..size(s)];
2072    if (testnumber(t))
2073    {
2074      //a negative number
2075    }
2076    else
2077    {
2078      // a variable times -1
2079    }
2080    // or just a "-" for -1
2081  }
2082  t = "ring @r=(";
2083  t = t + charstr(basering)+"),";
2084  t = t + string(var(1))+",dp;";
2085  //  write(":w tstnum.tst",t);
2086  t = t+ "number @@Nn = " + s + ";"+"\$";
2087  write(":w tstnum.tst",t);
2088  string runsing = system("Singular");
2089  int k;
2090  t = runsing+ " -teq <tstnum.tst >tstnum.out";
2091  k = system("sh",t);
2092  if (k!=0)
2093  {
2094    ERROR("Problems running Singular");
2095  }
2096  int i = system("sh", "grep error tstnum.out > /dev/NULL");
2097  if (i!=0)
2098  {
2099    // no error: s is a number
2100    i = 1;
2101  }
2102  k = system("sh","rm tstnum.tst tstnum.out > /dev/NULL");
2103  return(i);
2104}
2105example
2106{
2107  "EXAMPLE:"; echo = 2;
2108  ring r = (0,a),x,dp;
2109  string s = "a^2+7*a-2";
2110  testnumber(s);
2111  s = "b+a";
2112  testnumber(s);
2113}
2114
2115static proc str2lplace(string s)
2116{
2117  // converts a word (monomial) with coeff into letter-place
2118  // string: coef*var1^exp1*var2^exp2*...varN^expN
2119  s = strpower2rep(s); // expand powers
2120  if (size(s)==0) { return(0); }
2121  int i,j,k,insC;
2122  string a,b,c,d,t;
2123  // 1. get coeff
2124  i = find(s,"*");
2125  if (i==0) { return(s); }
2126  list VN;
2127  c = s[1..i-1]; // incl. the case like (-a^2+1)
2128  int tn = testnumber(c);
2129  if (tn == 0)
2130  {
2131    // failed test
2132    if (c[1]=="-")
2133    {
2134      // two situations: either there's a negative number
2135      t = c[2..size(c)];
2136      if (testnumber(t))
2137      {
2138         //a negative number
2139        // nop here
2140      }
2141      else
2142      {
2143         // a variable times -1
2144          c = "-1";
2145          j++; VN[j] = t; //string(c[2..size(c)]);
2146          insC = 1;
2147      }
2148    }
2149    else
2150    {
2151      // just a variable with coeff 1
2152          j++; VN[j] = string(c);
2153          c = "1";
2154          insC = 1;
2155    }
2156  }
2157 // get vars
2158  t = s;
2159  //  t = s[i+1..size(s)];
2160  k = size(t); //j = 0;
2161  while (k>0)
2162  {
2163    t = t[i+1..size(t)]; //next part
2164    i = find(t,"*"); // next *
2165    if (i==0)
2166    {
2167      // last monomial
2168      j++;
2169      VN[j] = t;
2170      k = size(t);
2171      break;
2172    }
2173    b = t[1..i-1];
2174    //    print(b);
2175    j++;
2176    VN[j] = b;
2177    k = size(t);
2178  }
2180  VN[size(VN)+1] = string(c);
2181  return(VN);
2182}
2183example
2184{
2185  "EXAMPLE:"; echo = 2;
2186  ring r = (0,a),(f2,f1),dp;
2187  str2lplace("-2*f2^2*f1^2*f2");
2188  str2lplace("-f1*f2");
2189  str2lplace("(-a^2+7a)*f1*f2");
2190}
2191
2192static proc strpower2rep(string s)
2193{
2194  // makes x*x*x*x out of x^4 ., rep statys for repetitions
2195  // looks for "-" problem
2196  // exception: "-" as coeff
2197  string ex,t;
2198  int i,j,k;
2199
2200  i = find(s,"^"); // first ^
2201  if (i==0) { return(s); } // no ^ signs
2202
2203  if (s[1] == "-")
2204  {
2205    // either -coef or -1
2206    // got the coeff:
2207    i = find(s,"*");
2208    if (i==0)
2209    {
2210      // no *'s   => coef == -1 or s == -23
2211      i = size(s)+1;
2212    }
2213    t = string(s[2..i-1]); // without "-"
2214    if ( testnumber(t) )
2215    {
2216      // a good number
2217      t = strpower2rep(string(s[2..size(s)]));
2218      t = "-"+t;
2219      return(t);
2220    }
2221    else
2222    {
2223      // a variable
2224      t = strpower2rep(string(s[2..size(s)]));
2225      t = "-1*"+ t;
2226      return(t);
2227    }
2228  }
2229  // the case when leadcoef is a number in ()
2230  if (s[1] == "(")
2231  {
2232    i = find(s,")",2);    // must be nonzero
2233    t = s[2..i-1];
2234    if ( testnumber(t) )
2235    {
2236      // a good number
2237    }
2238    else {"strpower2rep: bad number as coef";}
2239    ex = string(s[i+2..size(s)]); // 2 because of *
2240    ex =  strpower2rep(ex);
2241    t = "("+t+")*"+ex;
2242    return(t);
2243  }
2244
2245  i = find(s,"^"); // first ^
2246  j = find(s,"*",i+1); // next * == end of ^
2247  if (j==0)
2248  {
2249    ex = s[i+1..size(s)];
2250  }
2251  else
2252  {
2253    ex = s[i+1..j-1];
2254  }
2255  execute("int @exp = " + ex + ";"); //@exp = exponent
2256  // got varname
2257  for (k=i-1; k>0; k--)
2258  {
2259    if (s[k] == "*") break;
2260  }
2261  string varn = s[k+1..i-1];
2262  //  "varn:";  varn;
2263  string pref;
2264  if (k>0)
2265  {
2266    pref = s[1..k]; // with * on the k-th place
2267  }
2268  //  "pref:";  pref;
2269  string suf;
2270  if ( (j>0) && (j+1 <= size(s)) )
2271  {
2272    suf = s[j+1..size(s)]; // without * on the 1st place
2273  }
2274  //  "suf:"; suf;
2275  string toins;
2276  for (k=1; k<=@exp; k++)
2277  {
2278    toins = toins + varn+"*";
2279  }
2280  //  "toins: ";  toins;
2281  if (size(suf) == 0)
2282  {
2283    toins = toins[1..size(toins)-1]; // get rid of trailing *
2284  }
2285  else
2286  {
2287    suf = strpower2rep(suf);
2288  }
2289  ex = pref + toins + suf;
2290  return(ex);
2291  //  return(strpower2rep(ex));
2292}
2293example
2294{
2295  "EXAMPLE:"; echo = 2;
2296  ring r = (0,a),(x,y,z,t),dp;
2297  strpower2rep("-x^4");
2298  strpower2rep("-2*x^4*y^3*z*t^2");
2299  strpower2rep("-a^2*x^4");
2300}
2301
2302proc lieBracket(poly a, poly b, list #)
2303"USAGE:  lieBracket(a,b[,N]); a,b letterplace polynomials, N an optional integer
2304RETURN:  poly
2305ASSUME: basering has a letterplace ring structure
2306PURPOSE: compute the Lie bracket [a,b] = ab - ba between letterplace polynomials
2307NOTE: if N>1 is specified, then the left normed bracket [a,[...[a,b]]]] is computed.
2308EXAMPLE: example lieBracket; shows examples
2309"
2310{
2311  if (lpAssumeViolation())
2312  {
2313    //    ERROR("Either 'uptodeg' or 'lV' global variables are not set!");
2314    ERROR("Incomplete Letterplace structure on the basering!");
2315  }
2316  // alias ppLiebr;
2317  //if int N is given compute [a,[...[a,b]]]] left normed bracket
2318  poly q;
2319  int N=1;
2320  if (size(#)>0)
2321  {
2322    if (typeof(#[1])=="int")
2323    {
2324      N = int(#[1]);
2325    }
2326  }
2327  if (N<=0) { return(q); }
2328  while (b!=0)
2329  {
2330    q = q + pmLiebr(a,lead(b));
2331    b = b - lead(b);
2332  }
2333  int i;
2334  if (N >1)
2335  {
2336    for(i=1; i<=N; i++)
2337    {
2338      q = lieBracket(a,q);
2339    }
2340  }
2341  return(q);
2342}
2343example
2344{
2345  "EXAMPLE:"; echo = 2;
2346  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
2347  def R = setLetterplaceAttributes(r,4,2); // supply R with letterplace structure
2348  setring R;
2349  poly a = x(1)*y(2); poly b = y(1);
2350  lieBracket(a,b);
2351  lieBracket(x(1),y(1),2);
2352}
2353
2354static proc pmLiebr(poly a, poly b)
2355{
2356  //  a poly, b mono
2357  poly s;
2358  while (a!=0)
2359  {
2361    a = a - lead(a);
2362  }
2363  return(s);
2364}
2365
2366proc shiftPoly(poly a, int i)
2367"USAGE:  shiftPoly(p,i); p letterplace poly, i int
2368RETURN: poly
2369ASSUME: basering has letterplace ring structure
2370PURPOSE: compute the i-th shift of letterplace polynomial p
2371EXAMPLE: example shiftPoly; shows examples
2372"
2373{
2374  // shifts a monomial a by i
2375  // calls pLPshift(p,sh,uptodeg,lVblock);
2376  if (lpAssumeViolation())
2377  {
2378    ERROR("Incomplete Letterplace structure on the basering!");
2379  }
2380  int uptodeg = attrib(basering,"uptodeg");
2381  int lV = attrib(basering,"lV");
2382  if (deg(a) + i > uptodeg)
2383  {
2384    ERROR("degree bound violated by the shift!");
2385  }
2386  return(system("stest",a,i,uptodeg,lV));
2387}
2388example
2389{
2390  "EXAMPLE:"; echo = 2;
2391  ring r = 0,(x,y,z),dp;
2392  int uptodeg = 5; int lV = 3;
2393  def R = makeLetterplaceRing(uptodeg);
2394  setring R;
2395  poly f = x(1)*z(2)*y(3) - 2*z(1)*y(2) + 3*x(1);
2396  shiftPoly(f,1);
2397  shiftPoly(f,2);
2398}
2399
2400
2401static proc mmLiebr(poly a, poly b)
2402{
2403  // a,b, monomials
2406  int sa = deg(a);
2407  int sb = deg(b);
2408  poly v = a*shiftPoly(b,sa) - b*shiftPoly(a,sb);
2409  return(v);
2410}
2411
2412static proc test_shift()
2413{
2414  LIB "freegb.lib";
2415  ring r = 0,(a,b),dp;
2416  int d =5;
2417  def R = makeLetterplaceRing(d);
2418  setring R;
2419  int uptodeg = d;
2420  int lV = 2;
2421  def R = setLetterplaceAttributes(r,uptodeg,2); // supply R with letterplace structure
2422  setring R;
2423  poly p = mmLiebr(a(1),b(1));
2424  poly p = lieBracket(a(1),b(1));
2425}
2426
2427proc serreRelations(intmat A, int zu)
2428"USAGE:  serreRelations(A,z); A an intmat, z an int
2429RETURN:  ideal
2430ASSUME: basering has a letterplace ring structure and
2431@*          A is a generalized Cartan matrix with integer entries
2432PURPOSE: compute the ideal of Serre's relations associated to A
2433EXAMPLE: example serreRelations; shows examples
2434"
2435{
2436  // zu = 1 -> with commutators [f_i,f_j]; zu == 0 without them
2437  // suppose that A is cartan matrix
2438  // then Serre's relations are
2439  // (ad f_j)^{1-A_{ij}} ( f_i)
2440  int ppl = printlevel-voice+2;
2441  int n = ncols(A); // hence n variables
2442  int i,j,k,el;
2443  poly p,q;
2444  ideal I;
2445  for (i=1; i<=n; i++)
2446  {
2447    for (j=1; j<=n; j++)
2448    {
2449      el = 1 - A[i,j];
2450      //     printf("i:%s, j: %s, l: %s",i,j,l);
2451      dbprint(ppl,"i, j, l: ",i,j,el);
2452      //      if ((i!=j) && (l >0))
2453      //      if ( (i!=j) &&  ( ((zu ==0) &&  (l >=2)) || ((zu ==1) &&  (l >=1)) ) )
2454      if ((i!=j) && (el >0))
2455      {
2456        q = lieBracket(var(j),var(i));
2457        dbprint(ppl,"first bracket: ",q);
2458        //        if (l >=2)
2459        //        {
2460          for (k=1; k<=el-1; k++)
2461          {
2462            q = lieBracket(var(j),q);
2463            dbprint(ppl,"further bracket:",q);
2464          }
2465          //        }
2466      }
2467      if (q!=0) { I = I,q; q=0;}
2468    }
2469  }
2470  I = simplify(I,2);
2471  return(I);
2472}
2473example
2474{
2475  "EXAMPLE:"; echo = 2;
2476  intmat A[3][3] =
2477    2, -1, 0,
2478    -1, 2, -3,
2479    0, -1, 2; // G^1_2 Cartan matrix
2480  ring r = 0,(f1,f2,f3),dp;
2481  int uptodeg = 5;
2482  def R = makeLetterplaceRing(uptodeg);
2483  setring R;
2484  ideal I = serreRelations(A,1); I = simplify(I,1+2+8);
2485  I;
2486}
2487
2488/* setup for older example:
2489  intmat A[2][2] = 2, -1, -1, 2; // sl_3 == A_2
2490  ring r = 0,(f1,f2),dp;
2491  int uptodeg = 5; int lV = 2;
2492*/
2493
2494proc fullSerreRelations(intmat A, ideal rNegative, ideal rCartan, ideal rPositive, int uptodeg)
2495"USAGE:  fullSerreRelations(A,N,C,P,d); A an intmat, N,C,P ideals, d an int
2496RETURN:  ring (and ideal)
2497PURPOSE: compute the inhomogeneous Serre's relations associated to A in given variable names
2498ASSUME: three ideals in the input are of the same sizes and contain merely variables
2499@* which are interpreted as follows: N resp. P stand for negative resp. positive roots,
2500@* C stand for Cartan elements. d is the degree bound for letterplace ring, which will be returned.
2501@* The matrix A is a generalized Cartan matrix with integer entries
2502@* The result is the ideal called 'fsRel' in the returned ring.
2503EXAMPLE: example fullSerreRelations; shows examples
2504"
2505{
2506  /* SerreRels on rNeg and rPos plus Cartans etc. */
2507  int ppl = printlevel -voice+2;
2508  /* ideals must be written in variables: assume each term is of degree 1 */
2509  int i,j,k;
2510  int N = nvars(basering);
2511  def save = basering;
2512  int comFlag = 0;
2513  /* assume:  (size(rNegative) == size(rPositive)) */
2514  /* assume:  (size(rNegative) == size(rCartan)) i.e. nonsimple Cartans */
2515  if ( (size(rNegative) != size(rPositive)) || (size(rNegative) != size(rCartan)) )
2516  {
2517    ERROR("All input ideals must be of the same size");
2518  }
2519
2520//   if (size(rNegative) != size(rPositive))
2521//   {
2522//     ERROR("The 1st and the 3rd input ideals must be of the same size");
2523//   }
2524
2525  /* assume:  2*size(rNegative) + size(rCartan) >= nvars(basering) */
2526  i = 2*size(rNegative) + size(rCartan);
2527  if (i>N)
2528  {
2529    ERROR("The total number of elements in input ideals must not exceed the dimension of the ground ring");
2530  }
2531  if (i < N)
2532  {
2533    comFlag = N-i; // so many elements will commute
2534    "Warning: some elements will be treated as mutually commuting";
2535  }
2536  /* extract varnames from input ideals */
2537  intvec iNeg = varIdeal2intvec(rNegative);
2538  intvec iCartan = varIdeal2intvec(rCartan);
2539  intvec iPos = varIdeal2intvec(rPositive);
2540  /* for each vector in rNeg and rPositive, go into the corr. ring and create SerreRels */
2541  /* rNegative: */
2542  list L = ringlist(save);
2543  def LPsave = makeLetterplaceRing2(uptodeg); setring save;
2544  list LNEG = L; list tmp;
2545  /* L[1] field as is; L[2] vars: a subset; L[3] ordering: dp, L[4] as is */
2546  for (i=1; i<=size(iNeg); i++)
2547  {
2548    tmp[i] = string(var(iNeg[i]));
2549  }
2550  LNEG[2] = tmp; LNEG[3] = list(list("dp",intvec(1:size(iNeg))), list("C",0));
2551  def RNEG = ring(LNEG); setring RNEG;
2552  def RRNEG = makeLetterplaceRing2(uptodeg);
2553  setring RRNEG;
2554  ideal I = serreRelations(A,1); I = simplify(I,1+2+8);
2555  setring LPsave;
2556  ideal srNeg = imap(RRNEG,I);
2557  dbprint(ppl,"0-1 ideal of negative relations is ready");
2558  dbprint(ppl-1,srNeg);
2559  setring save; kill L,tmp,RRNEG,RNEG, LNEG;
2560  /* rPositive: */
2561  list L = ringlist(save);
2562  list LPOS = L; list tmp;
2563  /* L[1] field as is; L[2] vars: a subset; L[3] ordering: dp, L[4] as is */
2564  for (i=1; i<=size(iPos); i++)
2565  {
2566    tmp[i] = string(var(iPos[i]));
2567  }
2568  LPOS[2] = tmp; LPOS[3] = list(list("dp",intvec(1:size(iPos))), list("C",0));
2569  def RPOS = ring(LPOS); setring RPOS;
2570  def RRPOS = makeLetterplaceRing2(uptodeg);
2571  setring RRPOS;
2572  ideal I = serreRelations(A,1); I = simplify(I,1+2+8);
2573  setring LPsave;
2574  ideal srPos = imap(RRPOS,I);
2575  dbprint(ppl,"0-2 ideal of positive relations is ready");
2576  dbprint(ppl-1,srPos);
2577  setring save; kill L,tmp,RRPOS,RPOS, LPOS;
2578  string sMap = "ideal Mmap =";
2579  for (i=1; i<=nvars(save); i++)
2580  {
2581    sMap = sMap + string(var(i)) +"(1),";
2582  }
2583  sMap[size(sMap)] = ";";
2584  /* cartans: h_j h_i = h_i h_j */
2585  setring LPsave;
2586  ideal ComCartan;
2587  for (i=1; i<size(iCartan); i++)
2588  {
2589    for (j=i+1; j<=size(iCartan); j++)
2590    {
2591      ComCartan =  ComCartan + lieBracket(var(iCartan[j]),var(iCartan[i]));
2592    }
2593  }
2594  ComCartan = simplify(ComCartan,1+2+8);
2595  execute(sMap); // defines an ideal Mmap
2596  map F = save, Mmap;
2597  dbprint(ppl,"1. commuting Cartans: ");
2598  dbprint(ppl-1,ComCartan);
2599  /* [e_i, f_j] =0 if i<>j */
2600  ideal ComPosNeg; // assume: #Neg=#Pos
2601  for (i=1; i<size(iPos); i++)
2602  {
2603    for (j=1; j<=size(iPos); j++)
2604    {
2605      if (j !=i)
2606      {
2607        ComPosNeg =  ComPosNeg + lieBracket(var(iPos[i]),var(iNeg[j]));
2608        ComPosNeg =  ComPosNeg + lieBracket(var(iPos[j]),var(iNeg[i]));
2609      }
2610    }
2611  }
2612  ComPosNeg = simplify(ComPosNeg,1+2+8);
2613  dbprint(ppl,"2. commuting Positive and Negative:");
2614  dbprint(ppl-1,ComPosNeg);
2615  /* [e_i, f_i] = h_i */
2616  poly tempo;
2617  for (i=1; i<=size(iCartan); i++)
2618  {
2619    tempo = lieBracket(var(iPos[i]),var(iNeg[i])) - var(iCartan[i]);
2620    ComPosNeg =  ComPosNeg + tempo;
2621  }
2622  //  ComPosNeg = simplify(ComPosNeg,1+2+8);
2623  dbprint(ppl,"3. added sl2 triples [e_i,f_i]=h_i");
2624  dbprint(ppl-1,ComPosNeg);
2625
2626  /* [h_i, e_j] = A_ij e_j */
2627  /* [h_i, f_j] = -A_ij f_j */
2628  ideal ActCartan; // assume: #Neg=#Pos
2629  for (i=1; i<=size(iCartan); i++)
2630  {
2631    for (j=1; j<=size(iCartan); j++)
2632    {
2633      tempo = lieBracket(var(iCartan[i]),var(iPos[j])) - A[i,j]*var(iPos[j]);
2634      ActCartan = ActCartan + tempo;
2635      tempo = lieBracket(var(iCartan[i]),var(iNeg[j])) + A[i,j]*var(iNeg[j]);
2636      ActCartan = ActCartan + tempo;
2637    }
2638  }
2639  ActCartan = simplify(ActCartan,1+2+8);
2640  dbprint(ppl,"4. actions of Cartan:");
2641  dbprint(ppl-1, ActCartan);
2642
2643  /* final part: prepare the output */
2644  setring LPsave;
2645  ideal fsRel = srNeg, srPos, ComPosNeg, ComCartan, ActCartan;
2646  export fsRel;
2647  setring save;
2648  return(LPsave);
2649}
2650example
2651{
2652  "EXAMPLE:"; echo = 2;
2653  intmat A[2][2] =
2654    2, -1,
2655    -1, 2; // A_2 = sl_3 Cartan matrix
2656  ring r = 0,(f1,f2,h1,h2,e1,e2),dp;
2657  ideal negroots = f1,f2; ideal cartans = h1,h2; ideal posroots = e1,e2;
2658  int uptodeg = 5;
2659  def RS = fullSerreRelations(A,negroots,cartans,posroots,uptodeg);
2660  setring RS; fsRel;
2661}
2662
2663proc varIdeal2intvec(ideal I)
2664{
2665  /* assume1:  input ideal is a list of variables of the ground ring */
2666  int i,j; intvec V;
2667  for (i=1; i<= size(I); i++)
2668  {
2669    j = univariate(I[i]);
2670    if (j<=0)
2671    {
2672      ERROR("input ideal must contain only variables");
2673    }
2674    V[i] = j;
2675  }
2676  dbprint(printlevel-voice+2,V);
2677  /* now we make a smaller list of non-repeating entries */
2678  ideal iW = simplify(ideal(V),2+4); // no zeros, no repetitions
2679  if (size(iW) < size(V))
2680  {
2681    /* extract intvec from iW */
2682    intvec inW;
2683    for(j=1; j<=size(iW); j++)
2684    {
2686    }
2687    return(inW);
2688  }
2689  return(V);
2690}
2691example
2692{
2693  "EXAMPLE:"; echo = 2;
2694  ring r = 0,(x,y,z),dp;
2695  ideal I = x,z;
2696  varIdeal2intvec(I);
2697  varIdeal2intvec(ideal(x2,y^3,x+1));
2698  varIdeal2intvec(ideal(x*y,y,x+1));
2699}
2700
2701proc lp2lstr(ideal K, def save)
2702"USAGE:  lp2lstr(K,s); K an ideal, s a ring name
2703RETURN:  nothing (exports object @LN into the ring named s)
2704ASSUME: basering has a letterplace ring structure
2705PURPOSE: converts letterplace ideal to list of modules
2706NOTE: useful as preprocessing to 'lst2str'
2707EXAMPLE: example lp2lstr; shows examples
2708"
2709{
2710  def @R = basering;
2711  string err;
2712  int s = nvars(save);
2713  int i,j,k;
2714    // K contains vars x(1),...z(1) = images of originals
2715  // 5. go back to orig vars, produce strings/modules
2716  int sk = size(K);
2717  int sp, sx, a, b;
2718  intvec x;
2719  poly p,q;
2720  poly pn;
2721  // vars in 'save'
2722  setring save;
2723  module N;
2724  list LN;
2725  vector V;
2726  poly pn;
2727  // test and skip exponents >=2
2728  setring @R;
2729  for(i=1; i<=sk; i++)
2730  {
2731    p  = K[i];
2732    while (p!=0)
2733    {
2735      //      "processing q:";q;
2737      sx = size(x);
2738      for(k=1; k<=sx; k++)
2739      {
2740        if ( x[k] >= 2 )
2741        {
2742          err = "skip: the value x[k] is " + string(x[k]);
2743          dbprint(ppl,err);
2744          //            return(0);
2745          K[i] = 0;
2746          p    = 0;
2747          q    = 0;
2748          break;
2749        }
2750      }
2751      p  = p - q;
2752    }
2753  }
2754  K  = simplify(K,2);
2755  sk = size(K);
2756  for(i=1; i<=sk; i++)
2757  {
2758    //    setring save;
2759    //    V  = 0;
2760    setring @R;
2761    p  = K[i];
2762    while (p!=0)
2763    {
2765      err =  "processing q:" + string(q);
2766      dbprint(ppl,err);
2768      sx = size(x);
2770      setring save;
2771      pn = imap(@R,pn);
2772      V  = V + leadcoef(pn)*gen(1);
2773      for(k=1; k<=sx; k++)
2774      {
2775        if (x[k] ==1)
2776        {
2777          a = k / s; // block number=a+1, a!=0
2778          b = k % s; // remainder
2779          //          printf("a: %s, b: %s",a,b);
2780          if (b == 0)
2781          {
2782            // that is it's the last var in the block
2783            b = s;
2784            a = a-1;
2785          }
2786          V = V + var(b)*gen(a+2);
2787        }
2788      }
2789      err = "V: " + string(V);
2790      dbprint(ppl,err);
2791      //      printf("V: %s", string(V));
2792      N = N,V;
2793      V  = 0;
2794      setring @R;
2795      p  = p - q;
2796      pn = 0;
2797    }
2798    setring save;
2799    LN[i] = simplify(N,2);
2800    N     = 0;
2801  }
2802  setring save;
2803  list @LN = LN;
2804  export @LN;
2805  //  return(LN);
2806}
2807example
2808{
2809  "EXAMPLE:"; echo = 2;
2810  intmat A[2][2] = 2, -1, -1, 2; // sl_3 == A_2
2811  ring r = 0,(f1,f2),dp;
2812  def R = makeLetterplaceRing(3);
2813  setring R;
2814  ideal I = serreRelations(A,1);
2815  lp2lstr(I,r);
2816  setring r;
2817  lst2str(@LN,1);
2818}
2819
2820static proc strList2poly(list L)
2821{
2822  //  list L comes from sent2lplace (which takes a polynomial as input)
2823  // each entry of L is a sublist with the coef on the last place
2824  int s = size(L); int t;
2825  int i,j;
2826  list M;
2827  poly p,q;
2828  string Q;
2829  for(i=1; i<=s; i++)
2830  {
2831    M = L[i];
2832    t = size(M);
2833    //    q = M[t]; // a constant
2834    Q = string(M[t]);
2835    for(j=1; j<t; j++)
2836    {
2837      //      q = q*M[j];
2838      Q = Q+"*"+string(M[j]);
2839    }
2840    execute("q="+Q+";");
2841    //    q;
2842    p = p + q;
2843  }
2844  kill Q;
2845  return(p);
2846}
2847example
2848{
2849  "EXAMPLE:"; echo = 2;
2850  ring r =0,(x,y,z,t),Dp;
2851  def A = makeLetterplaceRing(4);
2852  setring A;
2853  string t = "-2*y*z*y*z + y*t*z*z - z*x*x*y  + 2*z*y*z*y";
2854  list L = sent2lplace(t);
2855  L;
2856  poly p = strList2poly(L);
2857  p;
2858}
2859
2860static proc file2lplace(string fname)
2861"USAGE:  file2lplace(fnm);  fnm a string
2862RETURN:  ideal
2863PURPOSE: convert the contents of the file fnm into ideal of polynomials in free algebra
2864EXAMPLE: example file2lplace; shows examples
2865"
2866{
2867  // format: from the usual string to letterplace
2869  // assume: file is a comma-sep list of polys
2870  // the vars are declared before
2871  // the file ends with ";"
2872  string t; int i;
2873  ideal I;
2874  list tst;
2875  while (s!="")
2876  {
2877    i = find(s,",");
2878    "i"; i;
2879    if (i==0)
2880    {
2881      i = find(s,";");
2882      if (i==0)
2883      {
2884        // no ; ??
2885         "no colon or semicolon found anymore";
2886         return(I);
2887      }
2888      // no "," but ";" on the i-th place
2889      t = s[1..i-1];
2890      s = "";
2891      "processing: "; t;
2892      tst = sent2lplace(t);
2893      tst;
2894      I = I, strList2poly(tst);
2895      return(I);
2896    }
2897    // here i !=0
2898    t = s[1..i-1];
2899    s = s[i+1..size(s)];
2900    "processing: "; t;
2901    tst = sent2lplace(t);
2902    tst;
2903    I = I, strList2poly(tst);
2904  }
2905  return(I);
2906}
2907example
2908{
2909  "EXAMPLE:"; echo = 2;
2910  ring r =0,(x,y,z,t),dp;
2911  def A = makeLetterplaceRing(4);
2912  setring A;
2913  string fn = "myfile";
2914  string s1 = "z*y*y*y - 3*y*z*x*y  + 3*y*y*z*y - y*x*y*z,";
2915  string s2 = "-2*y*x*y*z + y*y*z*z - z*z*y*y + 2*z*y*z*y,";
2916  string s3 = "z*y*x*t - 2*y*z*y*t + y*y*z*t - t*z*y*y + 2*t*y*z*y - t*x*y*z;";
2917  write(":w "+fn,s1);  write(":a "+fn,s2);   write(":a "+fn,s3);
2919  ideal I = file2lplace(fn);
2920  I;
2921}
2922
2923/* EXAMPLES AGAIN:
2924//static proc get_ls3nilp()
2925{
2926//first app of file2lplace
2927  ring r =0,(x,y,z,t),dp;
2928  int d = 10;
2929  def A = makeLetterplaceRing(d);
2930  setring A;
2931  ideal I = file2lplace("./ls3nilp.bg");
2932  // and now test the correctness: go back from lplace to strings
2933  lp2lstr(I,r);
2934  setring r;
2935  lst2str(@LN,1); // agree!
2936}
2937
2938//static proc doc_example()
2939{
2940  LIB "freegb.lib";
2941  ring r = 0,(x,y,z),dp;
2942  int d =4; // degree bound
2943  def R = makeLetterplaceRing(d);
2944  setring R;
2945  ideal I = x(1)*y(2) + y(1)*z(2), x(1)*x(2) + x(1)*y(2) - y(1)*x(2) - y(1)*y(2);
2946  option(redSB);option(redTail);
2947  ideal J = system("freegb",I,d,nvars(r));
2948  J;
2949  // visualization:
2950  lp2lstr(J,r); // export an object called @LN to the ring r
2951  setring r;  // change to the ring r
2952  lst2str(@LN,1); // output the strings
2953}
2954
2955*/
2956
2957// TODO:
2958// multiply two letterplace polynomials, lpMult: done
2959// reduction/ Normalform? needs kernel stuff
2960
2961proc lpMult(poly f, poly g)
2962"USAGE:  lpMult(f,g); f,g letterplace polynomials
2963RETURN:  poly
2964ASSUME: basering has a letterplace ring structure
2965PURPOSE: compute the letterplace form of f*g
2966EXAMPLE: example lpMult; shows examples
2967"
2968{
2969  if (lpAssumeViolation())
2970  {
2971    ERROR("Incomplete Letterplace structure on the basering!");
2972  }
2973  int sf = deg(f);
2974  int sg = deg(g);
2975  int uptodeg = attrib(basering, "uptodeg");
2976  if (sf+sg > uptodeg)
2977  {
2978    ERROR("degree bound violated by the product!");
2979  }
2980  //  if (sf>1) { sf = sf -1; }
2981  poly v = f*shiftPoly(g,sf);
2982  return(v);
2983}
2984example
2985{
2986  "EXAMPLE:"; echo = 2;
2987  // define a ring in letterplace form as follows:
2988  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
2989  def R = setLetterplaceAttributes(r,4,2); // supply R with letterplace structure
2990  setring R;
2991  poly a = x(1)*y(2); poly b = y(1);
2992  lpMult(b,a);
2993  lpMult(a,b);
2994}
2995
2996proc lpPower(poly f, int n)
2997"USAGE:  lpPower(f,n); f letterplace polynomial, int n
2998RETURN:  poly
2999ASSUME: basering has a letterplace ring structure
3000PURPOSE: compute the letterplace form of f^n
3001EXAMPLE: example lpPower; shows examples
3002"
3003{
3004  if (n<0) { ERROR("the power must be a natural number!"); }
3005  if (n==0) { return(poly(1)); }
3006  if (n==1) { return(f); }
3007  int i;
3008  poly p = 1;
3009  for(i=1; i<= n; i++)
3010  {
3011    p = lpMult(p,f);
3012  }
3013  return(p);
3014}
3015example
3016{
3017  "EXAMPLE:"; echo = 2;
3018  // define a ring in letterplace form as follows:
3019  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
3020  def R = setLetterplaceAttributes(r,4,2); // supply R with letterplace structure
3021  setring R;
3022  poly a = x(1)*y(2); poly b = y(1);
3023  lpPower(a,2);
3024  lpPower(b,4);
3025}
3026
3027// under development for Roberto
3028proc extractLinearPart(module M)
3029{
3030  /* returns vectors from a module whose max leadexp is 1 */
3031  /* does not take place nonlinearity into account yet */
3032  /* use rather kernel function isinV to get really nonlinear things */
3033  int i; int s = ncols(M);
3035  vector v; module Ret;
3036  for(i=1; i<=s; i++)
3037  {
3038    if ( isLinearVector(M[i]) )
3039    {
3040      Ret = Ret, M[i];
3041    }
3042  }
3043  Ret = simplify(Ret,2);
3044  return(Ret);
3045}
3046
3047// under development for Roberto
3048proc isLinearVector(vector v)
3049{
3050  /* returns true iff max leadexp is 1 */
3051  int i,j,k;
3052  intvec w;
3053  int s = size(v);
3054  poly p;
3056  for(i=1; i<=s; i++)
3057  {
3058    p = v[i];
3059    while (p != 0)
3060    {
3062      j = Max(w);
3063      if (j >=2)
3064      {
3067      }
3069    }
3070  }
3072}
3073
3074
3075// // the following is to determine a shift of a mono/poly from the
3076// // interface
3077
3078// proc whichshift(poly p, int numvars)
3079// {
3080// // numvars = number of vars of the orig free algebra
3081// // assume: we are in the letterplace ring
3082// // takes  monomial on the input
3085// if (v==0) { return(int(0)); }
3086// int sv = size(v);
3087// int i=1;
3088// while ( (v[i]==0) && (i<sv) ) { i++; }
3089// i = sv div i;
3090// return(i);
3091// }
3092
3093
3094// LIB "qhmoduli.lib";
3095// proc polyshift(poly p,  int numvars)
3096// {
3097//   poly q = p; int i = 0;
3098//   while (q!=0)
3099//   {
3100//     i = Max(i, whichshift(q,numvars));
3101//     q = q - lead(q);
3102//   }
3103//   return(q);
3104// }
3105
3106static proc lpAssumeViolation()
3107{
3108  // checks whether the global vars
3109  // uptodeg and lV are defined
3110  // returns Boolean : yes/no [for assume violation]
3111  def lpring = attrib(basering,"isLetterplaceRing");
3112  if ( typeof(lpring)!="int" )
3113  {
3114    //  if ( typeof(lpring)=="string" ) ??
3115    // basering is NOT lp Ring
3116
3117    return(1);
3118  }
3119  def uptodeg = attrib(basering,"uptodeg");
3120  if ( typeof(uptodeg)!="int" )
3121  {
3122    return(1);
3123  }
3124  def lV = attrib(basering,"lV");
3125  if ( typeof(lV)!="int" )
3126  {
3127    return(1);
3128  }
3129  //  int i = ( defined(uptodeg) && (defined(lV)) );
3130  //  return ( !i );
3131  return(0);
3132}
Note: See TracBrowser for help on using the repository browser.