source: git/Singular/LIB/freegb.lib @ 841e940

spielwiese
Last change on this file since 841e940 was 841e940, checked in by Hans Schönemann <hannes@…>, 15 years ago
*hannes: discretize_lib removed git-svn-id: file:///usr/local/Singular/svn/trunk@11643 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 53.8 KB
Line 
1//////////////////////////////////////////////////////////////////////////////
2version="$Id: freegb.lib,v 1.20 2009-04-08 11:11:20 Singular Exp $";
3category="Noncommutative";
4info="
5LIBRARY: freegb.lib   Twosided Noncommutative Groebner bases in Free Algebras via Letterplace
6AUTHOR: Viktor Levandovskyy,     levandov@math.rwth-aachen.de
7
8THEORY: See chapter 'LETTERPLACE' in the 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
15AUXILIARY PROCEDURES:
16
17lpMult(f,g);        letterplace multiplication of letterplace polynomials
18lp2lstr(K, s);      convert letter-place ideal to a list of modules
19lst2str(L[, n]);     convert a list (of modules) into polynomials in free algebra
20mod2str(M[, n]); convert a module into a polynomial in free algebra
21vct2str(M[, n]);   convert a vector into a word in free algebra
22lieBracket(a,b[, N]);    compute Lie bracket ab-ba of two letterplace polynomials
23serreRelations(A,z);   compute the ideal of Serre's relations associated to a generalized Cartan matrix A
24isVar(p);                   check whether p is a power of a single variable
25ademRelations(i,j);    compute the ideal of Adem relations for i<2j in char 0
26
27SEE ALSO: LETTERPLACE
28"
29
30// this library computes two-sided GB of an ideal
31// in a free associative algebra
32
33// a monomial is encoded via a vector V
34// where V[1] = coefficient
35// V[1+i] = the corresponding symbol
36
37LIB "qhmoduli.lib"; // for Max
38
39proc testfreegblib()
40{
41  example makeLetterplaceRing;
42  example freeGBasis;
43  example setLetterplaceAttributes;
44    "AUXILIARY PROCEDURES: ";
45  example shiftPoly;
46  example lpMult;
47  example lp2lstr;
48  example lst2str;
49  example mod2str;
50  example vct2str;
51  example lieBracket;
52  example serreRelations;
53  example isVar;
54}
55
56
57proc setLetterplaceAttributes(def R, int uptodeg, int lV)
58"USAGE: setLetterplaceAttributes(R, d, b); R a ring, b,d integers
59RETURN: ring with special attributes set
60PURPOSE: sets attributes for a letterplace ring:
61@*      'isLetterplaceRing' = true, 'uptodeg' = d, 'lV' = b, where
62@*      'uptodeg' stands for the degree bound,
63@*      'lV' for the number of variables in the block 0.
64"
65{
66  if (uptodeg*lV != nvars(R))
67  {
68    ERROR("uptodeg and lV do not agree on the basering!");
69  }
70 
71    // Set letterplace-specific attributes for the output ring!
72  attrib(R, "uptodeg", uptodeg);
73  attrib(R, "lV", lV); 
74  attrib(R, "isLetterplaceRing", 1); 
75  return (R);
76}
77example
78{
79  "EXAMPLE:"; echo = 2;
80  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
81  def R = setLetterplaceAttributes(r, 4, 2); setring R;
82  attrib(R,"isLetterplaceRing");
83  lieBracket(x(1),y(1),2);
84}
85
86
87// obsolete?
88
89static proc lshift(module M, int s, string varing, def lpring)
90{
91  // FINALLY IMPLEMENTED AS A PART OT THE CODE
92  // shifts a poly from the ring @R to s positions
93  // M lives in varing, the result in lpring
94  // to be run from varing
95  int i, j, k, sm, sv;
96  vector v;
97  //  execute("setring "+lpring);
98  setring lpring;
99  poly @@p;
100  ideal I;
101  execute("setring "+varing);
102  sm = ncols(M);
103  for (i=1; i<=s; i++)
104  {
105    // modules, e.g. free polynomials
106    for (j=1; j<=sm; j++)
107    {
108      //vectors, e.g. free monomials
109      v  = M[j];
110      sv = size(v);
111      sp = "@@p = @@p + ";
112      for (k=2; k<=sv; k++)
113      {
114        sp = sp + string(v[k])+"("+string(k-1+s)+")*";
115      }
116      sp = sp + string(v[1])+";"; // coef;
117      setring lpring;
118      //      execute("setring "+lpring);
119      execute(sp);
120      execute("setring "+varing);
121    }
122    setring lpring;
123    //    execute("setring "+lpring);
124    I = I,@@p;
125    @@p = 0;
126  }
127  setring lpring;
128  //execute("setring "+lpring);
129  export(I);
130  //  setring varing;
131  execute("setring "+varing);
132}
133
134static proc skip0(vector v)
135{
136  // skips zeros in a vector, producing another vector
137  if ( (v[1]==0) || (v==0) ) { return(vector(0)); }
138  int sv = nrows(v);
139  int sw = size(v);
140  if (sv == sw)
141  {
142    return(v);
143  }
144  int i;
145  int j=1;
146  vector w;
147  for (i=1; i<=sv; i++)
148  {
149    if (v[i] != 0)
150    {
151      w = w + v[i]*gen(j);
152      j++;
153    }
154  }
155  return(w);
156}
157
158proc lst2str(list L, list #)
159"USAGE:  lst2str(L[,n]);  L a list of modules, n an optional integer
160RETURN:  list (of strings)
161PURPOSE: convert a list (of modules) into polynomials in free algebra
162EXAMPLE: example lst2str; shows examples
163NOTE: if an optional integer is not 0, stars signs are used in multiplication
164"
165{
166  // returns a list of strings
167  // being sentences in words built from L
168  // if #[1] = 1, use * between generators
169  int useStar = 0;
170  if ( size(#)>0 )
171  {
172    if ( typeof(#[1]) != "int")
173    {
174      ERROR("Second argument of type int expected");
175    }
176    if (#[1])
177    {
178      useStar = 1;
179    }
180  }
181  int i;
182  int s    = size(L);
183  if (s<1) { return(list(""));}
184  list N;
185  for(i=1; i<=s; i++)
186  {
187    if ((typeof(L[i]) == "module") || (typeof(L[i]) == "matrix") )
188    {
189      N[i] = mod2str(L[i],useStar);
190    }
191    else
192    {
193      "module or matrix expected in the list";
194      return(N);
195    }
196  }
197  return(N);
198}
199example
200{
201  "EXAMPLE:"; echo = 2;
202  ring r = 0,(x,y,z),(dp(1),dp(2));
203  module M = [-1,x,y],[-7,y,y],[3,x,x];
204  module N = [1,x,y,x,y],[-2,y,x,y,x],[6,x,y,y,x,y];
205  list L; L[1] = M; L[2] = N;
206  lst2str(L);
207  lst2str(L[1],1);
208}
209
210
211proc mod2str(module M, list #)
212"USAGE:  mod2str(M[,n]);  M a module, n an optional integer
213RETURN:  string
214PURPOSE: convert a module into a polynomial in free algebra
215EXAMPLE: example mod2str; shows examples
216NOTE: if an optional integer is not 0, stars signs are used in multiplication
217"
218{
219  if (size(M)==0) { return(""); }
220  // returns a string
221  // a sentence in words built from M
222  // if #[1] = 1, use * between generators
223  int useStar = 0;
224  if ( size(#)>0 )
225  {
226    if ( typeof(#[1]) != "int")
227    {
228      ERROR("Second argument of type int expected");
229    }
230    if (#[1])
231    {
232      useStar = 1;
233    }
234  }
235  int i;
236  int s    = ncols(M);
237  string t;
238  string mp;
239  for(i=1; i<=s; i++)
240  {
241    mp = vct2str(M[i],useStar);
242    if (mp[1] == "-")
243    {
244      t = t + mp;
245    }
246    else
247    {
248      if (mp != "")
249      {
250         t = t + "+" + mp;
251      }
252    }
253  }
254  if (t[1]=="+")
255  {
256    t = t[2..size(t)]; // remove first "+"
257  }
258  return(t);
259}
260example
261{
262  "EXAMPLE:"; echo = 2;
263  ring r = 0,(x,y,z),(dp);
264  module M = [1,x,y,x,y],[-2,y,x,y,x],[6,x,y,y,x,y];
265  mod2str(M);
266  mod2str(M,1);
267}
268
269proc vct2str(vector v, list #)
270"USAGE:  vct2str(v[,n]);  v a vector, n an optional integer
271RETURN:  string
272PURPOSE: convert a vector into a word in free algebra
273EXAMPLE: example vct2str; shows examples
274NOTE: if an optional integer is not 0, stars signs are used in multiplication
275"
276{
277  if (v==0) { return(""); }
278  // if #[1] = 1, use * between generators
279  int useStar = 0;
280  if ( size(#)>0 )
281  {
282    if (#[1])
283    {
284      useStar = 1;
285    }
286  }
287  int ppl = printlevel-voice+2;
288  // for a word, encoded by v
289  // produces a string for it
290  v = skip0(v);
291  if (v==0) { return(string(""));}
292  number cf = leadcoef(v[1]);
293  int s = size(v);
294  string vs,vv,vp,err;
295  int i,j,p,q;
296  for (i=1; i<=s-1; i++)
297  {
298    p     = isVar(v[i+1]);
299    if (p==0)
300    {
301      err = "Error: monomial expected at nonzero position " + string(i+1);
302      ERROR(err+" in vct2str");
303      //      dbprint(ppl,err);
304      //      return("_");
305    }
306    if (p==1)
307    {
308      if (useStar && (size(vs) >0))       {   vs = vs + "*"; }
309        vs = vs + string(v[i+1]);
310    }
311    else //power
312    {
313      vv = string(v[i+1]);
314      q = find(vv,"^");
315      if (q==0)
316      {
317        q = find(vv,string(p));
318        if (q==0)
319        {
320          err = "error in find for string "+vv;
321          dbprint(ppl,err);
322          return("_");
323        }
324      }
325      // q>0
326      vp = vv[1..q-1];
327      for(j=1;j<=p;j++)
328      {
329         if (useStar && (size(vs) >0))       {   vs = vs + "*"; }
330         vs = vs + vp;
331      }
332    }
333  }
334  string scf;
335  if (cf == -1)
336  {
337    scf = "-";
338  }
339  else
340  {
341    scf = string(cf);
342    if ( (cf == 1) && (size(vs)>0) )
343    {
344      scf = "";
345    }
346  }
347  if (useStar && (size(scf) >0) && (scf!="-") )       {   scf = scf + "*"; }
348  vs = scf + vs;
349  return(vs);
350}
351example
352{
353  "EXAMPLE:"; echo = 2;
354  ring r = (0,a),(x,y3,z(1)),dp;
355  vector v = [-7,x,y3^4,x2,z(1)^3];
356  vct2str(v);
357  vct2str(v,1);
358  vector w = [-7a^5+6a,x,y3,y3,x,z(1),z(1)];
359  vct2str(w);
360  vct2str(w,1);
361}
362
363proc isVar(poly p)
364"USAGE:  isVar(p);  poly p
365RETURN:  int
366PURPOSE: check, whether leading monomial of p is a power of a single variable
367@* from the basering. Returns the exponent or 0 if p is multivariate.
368EXAMPLE: example isVar; shows examples
369"
370{
371  // checks whether p is a variable indeed
372  // if it's a power of a variable, returns the power
373  if (p==0) {  return(0); } //"p=0";
374  poly q   = leadmonom(p);
375  if ( (p-lead(p)) !=0 ) { return(0); } // "p-lm(p)>0";
376  intvec v = leadexp(p);
377  int s = size(v);
378  int i=1;
379  int cnt = 0;
380  int pwr = 0;
381  for (i=1; i<=s; i++)
382  {
383    if (v[i] != 0)
384    {
385      cnt++;
386      pwr = v[i];
387    }
388  }
389  //  "cnt:";  cnt;
390  if (cnt==1) { return(pwr); }
391  else { return(0); }
392}
393example
394{
395  "EXAMPLE:"; echo = 2;
396  ring r = 0,(x,y),dp;
397  poly f = xy+1;
398  isVar(f);
399  poly g = y^3;
400  isVar(g);
401  poly h = 7*x^3;
402  isVar(h);
403  poly i = 1;
404  isVar(i);
405}
406
407// new conversion routines
408
409static proc id2words(ideal I, int d)
410{
411  // NOT FINISHED
412  // input: ideal I of polys in letter-place notation
413  // in the ring with d real vars
414  // output: the list of strings: associative words
415  // extract names of vars
416  int i,m,n; string s; string place = "(1)";
417  list lv;
418  for(i=1; i<=d; i++)
419  {
420    s = string(var(i));
421    // get rid of place
422    n = find(s, place);
423    if (n>0)
424    {
425      s = s[1..n-1];
426    }
427    lv[i] = s;
428  }
429  poly p,q;
430  for (i=1; i<=ncols(I); i++)
431  {
432    if (I[i] != 0)
433    {
434      p = I[i];
435      while (p!=0)
436      {
437         q = leadmonom(p);
438      }
439    }
440  }
441
442  return(lv);
443}
444example
445{
446  "EXAMPLE:"; echo = 2;
447  ring r = 0,(x(1),y(1),z(1),x(2),y(2),z(2)),dp;
448  ideal I = x(1)*y(2) -z(1)*x(2);
449  id2words(I,3);
450}
451
452static proc mono2word(poly p, int d)
453{
454}
455
456// given the element -7xy^2x, it is represented as [-7,x,y^2,x] or as [-7,x,y,y,x]
457// use the orig ord on (x,y,z) and expand it blockwise to (x(i),y(i),z(i))
458
459// the correspondences:
460// monomial in K<x,y,z>    <<--->> vector in R
461// polynomial in K<x,y,z>  <<--->> list of vectors (matrix/module) in R
462// ideal in K<x,y,z>       <<--->> list of matrices/modules in R
463
464
465// 1. form a new ring
466// 2. NOP
467// 3. compute GB -> with the kernel stuff
468// 4. skip shifted elts (check that no such exist?)
469// 5. go back to orig vars, produce strings/modules
470// 6. return the result
471
472proc freeGBasis(list LM, int d)
473"USAGE:  freeGBasis(L, d);  L a list of modules, d an integer
474RETURN:  ring
475PURPOSE: compute the two-sided Groebner basis of an ideal, encoded by L in
476the free associative algebra, up to degree d
477EXAMPLE: example freeGBasis; shows examples
478"
479{
480  // d = up to degree, will be shifted to d+1
481  if (d<1) {"bad d"; return(0);}
482
483  int ppl = printlevel-voice+2;
484  string err = "";
485
486  int i,j,s;
487  def save = basering;
488  // determine max no of places in the input
489  int slm = size(LM); // numbers of polys in the ideal
490  int sm;
491  intvec iv;
492  module M;
493  for (i=1; i<=slm; i++)
494  {
495    // modules, e.g. free polynomials
496    M  = LM[i];
497    sm = ncols(M);
498    for (j=1; j<=sm; j++)
499    {
500      //vectors, e.g. free monomials
501      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
502    }
503  }
504  int D = Max(iv); // max size of input words
505  if (d<D) {"bad d"; return(LM);}
506  D = D + d-1;
507  //  D = d;
508  list LR  = ringlist(save);
509  list L, tmp;
510  L[1] = LR[1]; // ground field
511  L[4] = LR[4]; // quotient ideal
512  tmp  = LR[2]; // varnames
513  s = size(LR[2]);
514  for (i=1; i<=D; i++)
515  {
516    for (j=1; j<=s; j++)
517    {
518      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
519    }
520  }
521  for (i=1; i<=s; i++)
522  {
523    tmp[i] = string(tmp[i])+"("+string(1)+")";
524  }
525  L[2] = tmp;
526  list OrigNames = LR[2];
527  // ordering: d blocks of the ord on r
528  // try to get whether the ord on r is blockord itself
529  s = size(LR[3]);
530  if (s==2)
531  {
532    // not a blockord, 1 block + module ord
533    tmp = LR[3][s]; // module ord
534    for (i=1; i<=D; i++)
535    {
536      LR[3][s-1+i] = LR[3][1];
537    }
538    LR[3][s+D] = tmp;
539  }
540  if (s>2)
541  {
542    // there are s-1 blocks
543    int nb = s-1;
544    tmp = LR[3][s]; // module ord
545    for (i=1; i<=D; i++)
546    {
547      for (j=1; j<=nb; j++)
548      {
549        LR[3][i*nb+j] = LR[3][j];
550      }
551    }
552    //    size(LR[3]);
553    LR[3][nb*(D+1)+1] = tmp;
554  }
555  L[3] = LR[3];
556  def @R = ring(L);
557  setring @R;
558  ideal I;
559  poly @p;
560  s = size(OrigNames);
561  //  "s:";s;
562  // convert LM to canonical vectors (no powers)
563  setring save;
564  kill M; // M was defined earlier
565  module M;
566  slm = size(LM); // numbers of polys in the ideal
567  int sv,k,l;
568  vector v;
569  //  poly p;
570  string sp;
571  setring @R;
572  poly @@p=0;
573  setring save;
574  for (l=1; l<=slm; l++)
575  {
576    // modules, e.g. free polynomials
577    M  = LM[l];
578    sm = ncols(M); // in intvec iv the sizes are stored
579    // modules, e.g. free polynomials
580    for (j=1; j<=sm; j++)
581    {
582      //vectors, e.g. free monomials
583      v  = M[j];
584      sv = size(v);
585      //        "sv:";sv;
586      sp = "@@p = @@p + ";
587      for (k=2; k<=sv; k++)
588      {
589        sp = sp + string(v[k])+"("+string(k-1)+")*";
590      }
591      sp = sp + string(v[1])+";"; // coef;
592      setring @R;
593      execute(sp);
594      setring save;
595    }
596    setring @R;
597    //      "@@p:"; @@p;
598    I = I,@@p;
599    @@p = 0;
600    setring save;
601  }
602  kill sp;
603  // 3. compute GB
604  setring @R;
605  dbprint(ppl,"computing GB");
606  ideal J = system("freegb",I,d,nvars(save));
607  //  ideal J = slimgb(I);
608  dbprint(ppl,J);
609  // 4. skip shifted elts
610  ideal K = select1(J,1..s); // s = size(OrigNames)
611  dbprint(ppl,K);
612  dbprint(ppl, "done with GB");
613  // K contains vars x(1),...z(1) = images of originals
614  // 5. go back to orig vars, produce strings/modules
615  if (K[1] == 0)
616  {
617    "no reasonable output, GB gives 0";
618    return(0);
619  }
620  int sk = size(K);
621  int sp, sx, a, b;
622  intvec x;
623  poly p,q;
624  poly pn;
625  // vars in 'save'
626  setring save;
627  module N;
628  list LN;
629  vector V;
630  poly pn;
631  // test and skip exponents >=2
632  setring @R;
633  for(i=1; i<=sk; i++)
634  {
635    p  = K[i];
636    while (p!=0)
637    {
638      q  = lead(p);
639      //      "processing q:";q;
640      x  = leadexp(q);
641      sx = size(x);
642      for(k=1; k<=sx; k++)
643      {
644        if ( x[k] >= 2 )
645        {
646          err = "skip: the value x[k] is " + string(x[k]);
647          dbprint(ppl,err);
648          //            return(0);
649          K[i] = 0;
650          p    = 0;
651          q    = 0;
652          break;
653        }
654      }
655      p  = p - q;
656    }
657  }
658  K  = simplify(K,2);
659  sk = size(K);
660  for(i=1; i<=sk; i++)
661  {
662    //    setring save;
663    //    V  = 0;
664    setring @R;
665    p  = K[i];
666    while (p!=0)
667    {
668      q  = lead(p);
669      err =  "processing q:" + string(q);
670      dbprint(ppl,err);
671      x  = leadexp(q);
672      sx = size(x);
673      pn = leadcoef(q);
674      setring save;
675      pn = imap(@R,pn);
676      V  = V + leadcoef(pn)*gen(1);
677      for(k=1; k<=sx; k++)
678      {
679        if (x[k] ==1)
680        {
681          a = k / s; // block number=a+1, a!=0
682          b = k % s; // remainder
683          //          printf("a: %s, b: %s",a,b);
684          if (b == 0)
685          {
686            // that is it's the last var in the block
687            b = s;
688            a = a-1;
689          }
690          V = V + var(b)*gen(a+2);
691        }
692//         else
693//         {
694//           printf("error: the value x[k] is %s", x[k]);
695//           return(0);
696//         }
697      }
698      err = "V: " + string(V);
699      dbprint(ppl,err);
700      //      printf("V: %s", string(V));
701      N = N,V;
702      V  = 0;
703      setring @R;
704      p  = p - q;
705      pn = 0;
706    }
707    setring save;
708    LN[i] = simplify(N,2);
709    N     = 0;
710  }
711  setring save;
712  return(LN);
713}
714example
715{
716  "EXAMPLE:"; echo = 2;
717  ring r = 0,(x,y,z),(dp(1),dp(2));
718  module M = [-1,x,y],[-7,y,y],[3,x,x];
719  module N = [1,x,y,x],[-1,y,x,y];
720  list L; L[1] = M; L[2] = N;
721  lst2str(L);
722  def U = freeGBasis(L,5);
723  lst2str(U);
724}
725
726static proc crs(list LM, int d)
727"USAGE:  crs(L, d);  L a list of modules, d an integer
728RETURN:  ring
729PURPOSE: create a ring and shift the ideal
730EXAMPLE: example crs; shows examples
731"
732{
733  // d = up to degree, will be shifted to d+1
734  if (d<1) {"bad d"; return(0);}
735
736  int ppl = printlevel-voice+2;
737  string err = "";
738
739  int i,j,s;
740  def save = basering;
741  // determine max no of places in the input
742  int slm = size(LM); // numbers of polys in the ideal
743  int sm;
744  intvec iv;
745  module M;
746  for (i=1; i<=slm; i++)
747  {
748    // modules, e.g. free polynomials
749    M  = LM[i];
750    sm = ncols(M);
751    for (j=1; j<=sm; j++)
752    {
753      //vectors, e.g. free monomials
754      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
755    }
756  }
757  int D = Max(iv); // max size of input words
758  if (d<D) {"bad d"; return(LM);}
759  D = D + d-1;
760  //  D = d;
761  list LR  = ringlist(save);
762  list L, tmp;
763  L[1] = LR[1]; // ground field
764  L[4] = LR[4]; // quotient ideal
765  tmp  = LR[2]; // varnames
766  s = size(LR[2]);
767  for (i=1; i<=D; i++)
768  {
769    for (j=1; j<=s; j++)
770    {
771      tmp[i*s+j] = string(tmp[j])+"("+string(i)+")";
772    }
773  }
774  for (i=1; i<=s; i++)
775  {
776    tmp[i] = string(tmp[i])+"("+string(0)+")";
777  }
778  L[2] = tmp;
779  list OrigNames = LR[2];
780  // ordering: d blocks of the ord on r
781  // try to get whether the ord on r is blockord itself
782  s = size(LR[3]);
783  if (s==2)
784  {
785    // not a blockord, 1 block + module ord
786    tmp = LR[3][s]; // module ord
787    for (i=1; i<=D; i++)
788    {
789      LR[3][s-1+i] = LR[3][1];
790    }
791    LR[3][s+D] = tmp;
792  }
793  if (s>2)
794  {
795    // there are s-1 blocks
796    int nb = s-1;
797    tmp = LR[3][s]; // module ord
798    for (i=1; i<=D; i++)
799    {
800      for (j=1; j<=nb; j++)
801      {
802        LR[3][i*nb+j] = LR[3][j];
803      }
804    }
805    //    size(LR[3]);
806    LR[3][nb*(D+1)+1] = tmp;
807  }
808  L[3] = LR[3];
809  def @R = ring(L);
810  setring @R;
811  ideal I;
812  poly @p;
813  s = size(OrigNames);
814  //  "s:";s;
815  // convert LM to canonical vectors (no powers)
816  setring save;
817  kill M; // M was defined earlier
818  module M;
819  slm = size(LM); // numbers of polys in the ideal
820  int sv,k,l;
821  vector v;
822  //  poly p;
823  string sp;
824  setring @R;
825  poly @@p=0;
826  setring save;
827  for (l=1; l<=slm; l++)
828  {
829    // modules, e.g. free polynomials
830    M  = LM[l];
831    sm = ncols(M); // in intvec iv the sizes are stored
832    for (i=0; i<=d-iv[l]; i++)
833    {
834      // modules, e.g. free polynomials
835      for (j=1; j<=sm; j++)
836      {
837        //vectors, e.g. free monomials
838        v  = M[j];
839        sv = size(v);
840        //        "sv:";sv;
841        sp = "@@p = @@p + ";
842        for (k=2; k<=sv; k++)
843        {
844          sp = sp + string(v[k])+"("+string(k-2+i)+")*";
845        }
846        sp = sp + string(v[1])+";"; // coef;
847        setring @R;
848        execute(sp);
849        setring save;
850      }
851      setring @R;
852      //      "@@p:"; @@p;
853      I = I,@@p;
854      @@p = 0;
855      setring save;
856    }
857  }
858  setring @R;
859  export I;
860  return(@R);
861}
862example
863{
864  "EXAMPLE:"; echo = 2;
865  ring r = 0,(x,y,z),(dp(1),dp(2));
866  module M = [-1,x,y],[-7,y,y],[3,x,x];
867  module N = [1,x,y,x],[-1,y,x,y];
868  list L; L[1] = M; L[2] = N;
869  lst2str(L);
870  def U = crs(L,5);
871  setring U; U;
872  I;
873}
874
875static proc polylen(ideal I)
876{
877  // returns the ideal of length of polys
878  int i;
879  intvec J;
880  number s = 0;
881  for(i=1;i<=ncols(I);i++)
882  {
883    J[i] = size(I[i]);
884    s = s + J[i];
885  }
886  printf("the sum of length %s",s);
887  //  print(s);
888  return(J);
889}
890
891//proc freegbRing(int d)
892proc makeLetterplaceRing(int d)
893"USAGE:  makeLetterplaceRing(d); d an integer
894RETURN:  ring
895PURPOSE: creates a ring with d blocks of shifted original variables
896EXAMPLE: example makeLetterplaceRing; shows examples
897"
898{
899  // d = up to degree, will be shifted to d+1
900  if (d<1) {"bad d"; return(0);}
901
902  int uptodeg = d; int lV = nvars(basering);
903
904  int ppl = printlevel-voice+2;
905  string err = "";
906
907  int i,j,s;
908  def save = basering;
909  int D = d-1;
910  list LR  = ringlist(save);
911  list L, tmp;
912  L[1] = LR[1]; // ground field
913  L[4] = LR[4]; // quotient ideal
914  tmp  = LR[2]; // varnames
915  s = size(LR[2]);
916  for (i=1; i<=D; i++)
917  {
918    for (j=1; j<=s; j++)
919    {
920      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
921    }
922  }
923  for (i=1; i<=s; i++)
924  {
925    tmp[i] = string(tmp[i])+"("+string(1)+")";
926  }
927  L[2] = tmp;
928  list OrigNames = LR[2];
929  // ordering: d blocks of the ord on r
930  // try to get whether the ord on r is blockord itself
931  // TODO: make L(2) ordering! exponent is maximally 2
932  s = size(LR[3]);
933  if (s==2)
934  {
935    // not a blockord, 1 block + module ord
936    tmp = LR[3][s]; // module ord
937    for (i=1; i<=D; i++)
938    {
939      LR[3][s-1+i] = LR[3][1];
940    }
941    LR[3][s+D] = tmp;
942  }
943  if (s>2)
944  {
945    // there are s-1 blocks
946    int nb = s-1;
947    tmp = LR[3][s]; // module ord
948    for (i=1; i<=D; i++)
949    {
950      for (j=1; j<=nb; j++)
951      {
952        LR[3][i*nb+j] = LR[3][j];
953      }
954    }
955    //    size(LR[3]);
956    LR[3][nb*(D+1)+1] = tmp;
957  }
958  L[3] = LR[3];
959  def @R = ring(L);
960  //  setring @R;
961  //  int uptodeg = d; int lV = nvars(basering); // were defined before
962  def @@R = setLetterplaceAttributes(@R,uptodeg,lV);
963  return (@@R);
964}
965example
966{
967  "EXAMPLE:"; echo = 2;
968  ring r = 0,(x,y,z),(dp(1),dp(2));
969  def A = makeLetterplaceRing(2);
970  setring A;
971  A;
972  attrib(A,"isLetterplaceRing");
973  attrib(A,"uptodeg");  // degree bound
974  attrib(A,"lV"); // number of variables in the main block
975}
976
977/* EXAMPLES:
978
979//static proc ex_shift()
980{
981  LIB "freegb.lib";
982  ring r = 0,(x,y,z),(dp(1),dp(2));
983  module M = [-1,x,y],[-7,y,y],[3,x,x];
984  module N = [1,x,y,x],[-1,y,x,y];
985  list L; L[1] = M; L[2] = N;
986  lst2str(L);
987  def U = crs(L,5);
988  setring U; U;
989  I;
990  poly p = I[2]; // I[8];
991  p;
992  system("stest",p,7,7,3); // error -> the world is ok
993  poly q1 = system("stest",p,1,7,3); //ok
994  poly q6 = system("stest",p,6,7,3); //ok
995  system("btest",p,3); //ok
996  system("btest",q1,3); //ok
997  system("btest",q6,3); //ok
998}
999
1000//static proc test_shrink()
1001{
1002  LIB "freegb.lib";
1003  ring r =0,(x,y,z),dp;
1004  int d = 5;
1005  def R = makeLetterplaceRing(d);
1006  setring R;
1007  poly p1 = x(1)*y(2)*z(3);
1008  poly p2 = x(1)*y(4)*z(5);
1009  poly p3 = x(1)*y(1)*z(3);
1010  poly p4 = x(1)*y(2)*z(2);
1011  poly p5 = x(3)*z(5);
1012  poly p6 = x(1)*y(1)*x(3)*z(5);
1013  poly p7 = x(1)*y(2)*x(3)*y(4)*z(5);
1014  poly p8 = p1+p2+p3+p4+p5 + p6 + p7;
1015  p1; system("shrinktest",p1,3);
1016  p2; system("shrinktest",p2,3);
1017  p3; system("shrinktest",p3,3);
1018  p4; system("shrinktest",p4,3);
1019  p5; system("shrinktest",p5,3);
1020  p6; system("shrinktest",p6,3);
1021  p7; system("shrinktest",p7,3);
1022  p8; system("shrinktest",p8,3);
1023  poly p9 = p1 + 2*p2 + 5*p5 + 7*p7;
1024  p9; system("shrinktest",p9,3);
1025}
1026
1027//static proc ex2()
1028{
1029  option(prot);
1030  LIB "freegb.lib";
1031  ring r = 0,(x,y),dp;
1032  module M = [-1,x,y],[3,x,x]; // 3x^2 - xy
1033  def U = freegb(M,7);
1034  lst2str(U);
1035}
1036
1037//static proc ex_nonhomog()
1038{
1039  option(prot);
1040  LIB "freegb.lib";
1041  ring r = 0,(x,y,h),dp;
1042  list L;
1043  module M;
1044  M = [-1,y,y],[1,x,x,x];  // x3-y2
1045  L[1] = M;
1046  M = [1,x,h],[-1,h,x];  // xh-hx
1047  L[2] = M;
1048  M = [1,y,h],[-1,h,y];  // yh-hy
1049  L[3] = M;
1050  def U = freegb(L,4);
1051  lst2str(U);
1052  // strange elements in the basis
1053}
1054
1055//static proc ex_nonhomog_comm()
1056{
1057  option(prot);
1058  LIB "freegb.lib";
1059  ring r = 0,(x,y),dp;
1060  module M = [-1,y,y],[1,x,x,x];
1061  def U = freegb(M,5);
1062  lst2str(U);
1063}
1064
1065//static proc ex_nonhomog_h()
1066{
1067  option(prot);
1068  LIB "freegb.lib";
1069  ring r = 0,(x,y,h),(a(1,1),dp);
1070  module M = [-1,y,y,h],[1,x,x,x]; // x3 - y2h
1071  def U = freegb(M,6);
1072  lst2str(U);
1073}
1074
1075//static proc ex_nonhomog_h2()
1076{
1077  option(prot);
1078  LIB "freegb.lib";
1079  ring r = 0,(x,y,h),(dp);
1080  list L;
1081  module M;
1082  M = [-1,y,y,h],[1,x,x,x]; // x3 - y2h
1083  L[1] = M;
1084  M = [1,x,h],[-1,h,x]; // xh - hx
1085  L[2] = M;
1086  M = [1,y,h],[-1,h,y]; // yh - hy
1087  L[3] = M;
1088  def U = freeGBasis(L,3);
1089  lst2str(U);
1090  // strange answer CHECK
1091}
1092
1093
1094//static proc ex_nonhomog_3()
1095{
1096  option(prot);
1097  LIB "./freegb.lib";
1098  ring r = 0,(x,y,z),(dp);
1099  list L;
1100  module M;
1101  M = [1,z,y],[-1,x]; // zy - x
1102  L[1] = M;
1103  M = [1,z,x],[-1,y]; // zx - y
1104  L[2] = M;
1105  M = [1,y,x],[-1,z]; // yx - z
1106  L[3] = M;
1107  lst2str(L);
1108  list U = freegb(L,4);
1109  lst2str(U);
1110  // strange answer CHECK
1111}
1112
1113//static proc ex_densep_2()
1114{
1115  option(prot);
1116  LIB "freegb.lib";
1117  ring r = (0,a,b,c),(x,y),(Dp); // deglex
1118  module M = [1,x,x], [a,x,y], [b,y,x], [c,y,y];
1119  lst2str(M);
1120  list U = freegb(M,5);
1121  lst2str(U);
1122  // a=b is important -> finite basis!!!
1123  module M = [1,x,x], [a,x,y], [a,y,x], [c,y,y];
1124  lst2str(M);
1125  list U = freegb(M,5);
1126  lst2str(U);
1127}
1128
1129// END COMMENTED EXAMPLES
1130
1131*/
1132
1133// 1. form a new ring
1134// 2. produce shifted generators
1135// 3. compute GB
1136// 4. skip shifted elts
1137// 5. go back to orig vars, produce strings/modules
1138// 6. return the result
1139
1140static proc freegbold(list LM, int d)
1141"USAGE:  freegbold(L, d);  L a list of modules, d an integer
1142RETURN:  ring
1143PURPOSE: compute the two-sided Groebner basis of an ideal, encoded by L in
1144the free associative algebra, up to degree d
1145EXAMPLE: example freegbold; shows examples
1146"
1147{
1148  // d = up to degree, will be shifted to d+1
1149  if (d<1) {"bad d"; return(0);}
1150
1151  int ppl = printlevel-voice+2;
1152  string err = "";
1153
1154  int i,j,s;
1155  def save = basering;
1156  // determine max no of places in the input
1157  int slm = size(LM); // numbers of polys in the ideal
1158  int sm;
1159  intvec iv;
1160  module M;
1161  for (i=1; i<=slm; i++)
1162  {
1163    // modules, e.g. free polynomials
1164    M  = LM[i];
1165    sm = ncols(M);
1166    for (j=1; j<=sm; j++)
1167    {
1168      //vectors, e.g. free monomials
1169      iv = iv, size(M[j])-1; // 1 place is reserved by the coeff
1170    }
1171  }
1172  int D = Max(iv); // max size of input words
1173  if (d<D) {"bad d"; return(LM);}
1174  D = D + d-1;
1175  //  D = d;
1176  list LR  = ringlist(save);
1177  list L, tmp;
1178  L[1] = LR[1]; // ground field
1179  L[4] = LR[4]; // quotient ideal
1180  tmp  = LR[2]; // varnames
1181  s = size(LR[2]);
1182  for (i=1; i<=D; i++)
1183  {
1184    for (j=1; j<=s; j++)
1185    {
1186      tmp[i*s+j] = string(tmp[j])+"("+string(i+1)+")";
1187    }
1188  }
1189  for (i=1; i<=s; i++)
1190  {
1191    tmp[i] = string(tmp[i])+"("+string(1)+")";
1192  }
1193  L[2] = tmp;
1194  list OrigNames = LR[2];
1195  // ordering: d blocks of the ord on r
1196  // try to get whether the ord on r is blockord itself
1197  // TODO: make L(2) ordering! exponent is maximally 2
1198  s = size(LR[3]);
1199  if (s==2)
1200  {
1201    // not a blockord, 1 block + module ord
1202    tmp = LR[3][s]; // module ord
1203    for (i=1; i<=D; i++)
1204    {
1205      LR[3][s-1+i] = LR[3][1];
1206    }
1207    LR[3][s+D] = tmp;
1208  }
1209  if (s>2)
1210  {
1211    // there are s-1 blocks
1212    int nb = s-1;
1213    tmp = LR[3][s]; // module ord
1214    for (i=1; i<=D; i++)
1215    {
1216      for (j=1; j<=nb; j++)
1217      {
1218        LR[3][i*nb+j] = LR[3][j];
1219      }
1220    }
1221    //    size(LR[3]);
1222    LR[3][nb*(D+1)+1] = tmp;
1223  }
1224  L[3] = LR[3];
1225  def @R = ring(L);
1226  setring @R;
1227  ideal I;
1228  poly @p;
1229  s = size(OrigNames);
1230  //  "s:";s;
1231  // convert LM to canonical vectors (no powers)
1232  setring save;
1233  kill M; // M was defined earlier
1234  module M;
1235  slm = size(LM); // numbers of polys in the ideal
1236  int sv,k,l;
1237  vector v;
1238  //  poly p;
1239  string sp;
1240  setring @R;
1241  poly @@p=0;
1242  setring save;
1243  for (l=1; l<=slm; l++)
1244  {
1245    // modules, e.g. free polynomials
1246    M  = LM[l];
1247    sm = ncols(M); // in intvec iv the sizes are stored
1248    for (i=0; i<=d-iv[l]; i++)
1249    {
1250      // modules, e.g. free polynomials
1251      for (j=1; j<=sm; j++)
1252      {
1253        //vectors, e.g. free monomials
1254        v  = M[j];
1255        sv = size(v);
1256        //        "sv:";sv;
1257        sp = "@@p = @@p + ";
1258        for (k=2; k<=sv; k++)
1259        {
1260          sp = sp + string(v[k])+"("+string(k-1+i)+")*";
1261        }
1262        sp = sp + string(v[1])+";"; // coef;
1263        setring @R;
1264        execute(sp);
1265        setring save;
1266      }
1267      setring @R;
1268      //      "@@p:"; @@p;
1269      I = I,@@p;
1270      @@p = 0;
1271      setring save;
1272    }
1273  }
1274  kill sp;
1275  // 3. compute GB
1276  setring @R;
1277  dbprint(ppl,"computing GB");
1278  //  ideal J = groebner(I);
1279  ideal J = slimgb(I);
1280  dbprint(ppl,J);
1281  // 4. skip shifted elts
1282  ideal K = select1(J,1..s); // s = size(OrigNames)
1283  dbprint(ppl,K);
1284  dbprint(ppl, "done with GB");
1285  // K contains vars x(1),...z(1) = images of originals
1286  // 5. go back to orig vars, produce strings/modules
1287  if (K[1] == 0)
1288  {
1289    "no reasonable output, GB gives 0";
1290    return(0);
1291  }
1292  int sk = size(K);
1293  int sp, sx, a, b;
1294  intvec x;
1295  poly p,q;
1296  poly pn;
1297  // vars in 'save'
1298  setring save;
1299  module N;
1300  list LN;
1301  vector V;
1302  poly pn;
1303  // test and skip exponents >=2
1304  setring @R;
1305  for(i=1; i<=sk; i++)
1306  {
1307    p  = K[i];
1308    while (p!=0)
1309    {
1310      q  = lead(p);
1311      //      "processing q:";q;
1312      x  = leadexp(q);
1313      sx = size(x);
1314      for(k=1; k<=sx; k++)
1315      {
1316        if ( x[k] >= 2 )
1317        {
1318          err = "skip: the value x[k] is " + string(x[k]);
1319          dbprint(ppl,err);
1320          //            return(0);
1321          K[i] = 0;
1322          p    = 0;
1323          q    = 0;
1324          break;
1325        }
1326      }
1327      p  = p - q;
1328    }
1329  }
1330  K  = simplify(K,2);
1331  sk = size(K);
1332  for(i=1; i<=sk; i++)
1333  {
1334    //    setring save;
1335    //    V  = 0;
1336    setring @R;
1337    p  = K[i];
1338    while (p!=0)
1339    {
1340      q  = lead(p);
1341      err =  "processing q:" + string(q);
1342      dbprint(ppl,err);
1343      x  = leadexp(q);
1344      sx = size(x);
1345      pn = leadcoef(q);
1346      setring save;
1347      pn = imap(@R,pn);
1348      V  = V + leadcoef(pn)*gen(1);
1349      for(k=1; k<=sx; k++)
1350      {
1351        if (x[k] ==1)
1352        {
1353          a = k / s; // block number=a+1, a!=0
1354          b = k % s; // remainder
1355          //          printf("a: %s, b: %s",a,b);
1356          if (b == 0)
1357          {
1358            // that is it's the last var in the block
1359            b = s;
1360            a = a-1;
1361          }
1362          V = V + var(b)*gen(a+2);
1363        }
1364//         else
1365//         {
1366//           printf("error: the value x[k] is %s", x[k]);
1367//           return(0);
1368//         }
1369      }
1370      err = "V: " + string(V);
1371      dbprint(ppl,err);
1372      //      printf("V: %s", string(V));
1373      N = N,V;
1374      V  = 0;
1375      setring @R;
1376      p  = p - q;
1377      pn = 0;
1378    }
1379    setring save;
1380    LN[i] = simplify(N,2);
1381    N     = 0;
1382  }
1383  setring save;
1384  return(LN);
1385}
1386example
1387{
1388  "EXAMPLE:"; echo = 2;
1389  ring r = 0,(x,y,z),(dp(1),dp(2));
1390  module M = [-1,x,y],[-7,y,y],[3,x,x];
1391  module N = [1,x,y,x],[-1,y,x,y];
1392  list L; L[1] = M; L[2] = N;
1393  lst2str(L);
1394  def U = freegbold(L,5);
1395  lst2str(U);
1396}
1397
1398/* begin older procs and tests
1399
1400static proc sgb(ideal I, int d)
1401{
1402  // new code
1403  // map x_i to x_i(1) via map()
1404  //LIB "freegb.lib";
1405  def save = basering;
1406  //int d =7;// degree
1407  int nv = nvars(save);
1408  def R = makeLetterplaceRing(d);
1409  setring R;
1410  int i;
1411  ideal Imap;
1412  for (i=1; i<=nv; i++)
1413  {
1414    Imap[i] = var(i);
1415  }
1416  //ideal I = x(1)*y(2), y(1)*x(2)+z(1)*z(2);
1417  ideal I = x(1)*x(2),x(1)*y(2) + z(1)*x(2);
1418  option(prot);
1419  //option(teach);
1420  ideal J = system("freegb",I,d,nv);
1421}
1422
1423static proc checkCeq()
1424{
1425  ring r = 0,(x,y),Dp;
1426  def A = makeLetterplaceRing(4);
1427  setring A;
1428  A;
1429  // I = x2-xy
1430  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);
1431  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);
1432  ideal K = I,C;
1433  groebner(K);
1434}
1435
1436static proc exHom1()
1437{
1438  // we start with
1439  // z*y - x, z*x - y, y*x - z
1440  LIB "freegb.lib";
1441  LIB "elim.lib";
1442  ring r = 0,(x,y,z,h),dp;
1443  list L;
1444  module M;
1445  M = [1,z,y],[-1,x,h]; // zy - xh
1446  L[1] = M;
1447  M = [1,z,x],[-1,y,h]; // zx - yh
1448  L[2] = M;
1449  M = [1,y,x],[-1,z,h]; // yx - zh
1450  L[3] = M;
1451  lst2str(L);
1452  def U = crs(L,4);
1453  setring U;
1454  I = I,
1455    y(2)*h(3)+z(2)*x(3),     y(3)*h(4)+z(3)*x(4),
1456    y(2)*x(3)-z(2)*h(3),     y(3)*x(4)-z(3)*h(4);
1457  I = simplify(I,2);
1458  ring r2 = 0,(x(0..4),y(0..4),z(0..4),h(0..4)),dp;
1459  ideal J = imap(U,I);
1460  //  ideal K = homog(J,h);
1461  option(redSB);
1462  option(redTail);
1463  ideal L = groebner(J); //(K);
1464  ideal LL = sat(L,ideal(h))[1];
1465  ideal M = subst(LL,h,1);
1466  M = simplify(M,2);
1467  setring U;
1468  ideal M = imap(r2,M);
1469  lst2str(U);
1470}
1471
1472static proc test1()
1473{
1474  LIB "freegb.lib";
1475  ring r = 0,(x,y),Dp;
1476  int d = 10; // degree
1477  def R = makeLetterplaceRing(d);
1478  setring R;
1479  ideal I = x(1)*x(2) - y(1)*y(2);
1480  option(prot);
1481  option(teach);
1482  ideal J = system("freegb",I,d,2);
1483  J;
1484}
1485
1486static proc test2()
1487{
1488  LIB "freegb.lib";
1489  ring r = 0,(x,y),Dp;
1490  int d = 10; // degree
1491  def R = makeLetterplaceRing(d);
1492  setring R;
1493  ideal I = x(1)*x(2) - x(1)*y(2);
1494  option(prot);
1495  option(teach);
1496  ideal J = system("freegb",I,d,2);
1497  J;
1498}
1499
1500static proc test3()
1501{
1502  LIB "freegb.lib";
1503  ring r = 0,(x,y,z),dp;
1504  int d =5; // degree
1505  def R = makeLetterplaceRing(d);
1506  setring R;
1507  ideal I = x(1)*y(2), y(1)*x(2)+z(1)*z(2);
1508  option(prot);
1509  option(teach);
1510  ideal J = system("freegb",I,d,3);
1511}
1512
1513static proc schur2-3()
1514{
1515  // nonhomog:
1516  //  h^4-10*h^2+9,f*e-e*f+h, h*2-e*h-2*e,h*f-f*h+2*f
1517  // homogenized with t
1518  //  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,
1519  // t*h - h*t, t*f - f*t, t*e - e*t
1520}
1521
1522end older procs and tests */
1523
1524proc ademRelations(int i, int j)
1525"USAGE:  ademRelations(i,j); i,j int
1526RETURN:  ring (and exports ideal)
1527ASSUME: there are at least i+j variables in the basering
1528PURPOSE: compute the ideal of Adem relations for i<2j in characteristic 0
1529@*  the ideal is exported under the name AdemRel in the output ring
1530EXAMPLE: example ademRelations; shows examples
1531"
1532{
1533  // produces Adem relations for i<2j in char 0
1534  // assume: 0<i<2j
1535  // requires presence of vars up to i+j
1536  if ( (i<0) || (i >= 2*j) )
1537  {
1538    ERROR("arguments out of range"); return(0);
1539  }
1540  ring @r = 0,(s(i+j..0)),lp;
1541  poly p,q;
1542  number n;
1543  int ii = i div 2; int k;
1544  // k=0 => s(0)=1
1545  n = binomial(j-1,i);
1546  q = n*s(i+j)*s(0);
1547  //  printf("k=0, term=%s",q);
1548  p = p + q;
1549  for (k=1; k<= ii; k++)
1550  {
1551    n = binomial(j-k-1,i-2*k);
1552    q = n*s(i+j-k)*s(k);;
1553    //    printf("k=%s, term=%s",k,q);
1554    p = p + q;
1555  }
1556  poly AdemRel = p;
1557  export AdemRel;
1558  return(@r);
1559}
1560example
1561{
1562  "EXAMPLE:"; echo = 2;
1563  def A = ademRelations(2,5);
1564  setring A;
1565  AdemRel;
1566}
1567
1568/*
15691,1: 0
15701,2: s(3)*s(0) == s(3) -> def for s(3):=s(1)s(2)
15712,1: adm
15722,2: s(3)*s(1) == s(1)s(2)s(1)
15731,3: 0 ( since 2*s(4)*s(0) = 0 mod 2)
15743,1: adm
15752,3: s(5)*s(0)+s(4)*s(1) == s(5)+s(4)*s(1)
15763,2: 0
15773,3: s(5)*s(1)
15781,4: 3*s(5)*s(0) == s(5)  -> def for s(5):=s(1)*s(4)
15794,1: adm
15802,4: 3*s(6)*s(0)+s(5)*s(1) == s(6) + s(5)*s(1) == s(6) + s(1)*s(4)*s(1)
15814,2: adm
15824,3: s(5)*s(2)
15833,4: s(7)*s(0)+2*s(6)*s(1) == s(7) -> def for s(7):=s(3)*s(4)
15844,4: s(7)*s(1)+s(6)*s(2)
1585*/
1586
1587/* s1,s2:
1588s1*s1 =0, s2*s2 = s1*s2*s1
1589*/
1590
1591/*
1592try char 0:
1593s1,s2:
1594s1*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)
1595hence 2==0! only in char 2
1596 */
1597
1598  // Adem rels modulo 2 are interesting
1599
1600static proc stringpoly2lplace(string s)
1601{
1602  // decomposes sentence into terms
1603  s = replace(s,newline,""); // get rid of newlines
1604  s = replace(s," ",""); // get rid of empties
1605  //arith symbols: +,-
1606  // decompose into words with coeffs
1607  list LS;
1608  int i,j,ie,je,k,cnt;
1609  // s[1]="-" situation
1610  if (s[1]=="-")
1611  {
1612    LS = stringpoly2lplace(string(s[2..size(s)]));
1613    LS[1] = string("-"+string(LS[1]));
1614    return(LS);
1615  }
1616  i = find(s,"-",2);
1617  // i==1 might happen if the 1st symbol coeff is negative
1618  j = find(s,"+");
1619  list LL;
1620  if (i==j)
1621  {
1622    "return a monomial";
1623    // that is both are 0 -> s is a monomial
1624    LS[1] = s;
1625    return(LS);
1626  }
1627  if (i==0)
1628  {
1629    "i==0 situation";
1630    // no minuses at all => pluses only
1631    cnt++;
1632    LS[cnt] = string(s[1..j-1]);
1633    s = s[j+1..size(s)];
1634    while (s!= "")
1635    {
1636      j = find(s,"+");
1637      cnt++;
1638      if (j==0)
1639      {
1640        LS[cnt] = string(s);
1641        s = "";
1642      }
1643      else
1644      {
1645        LS[cnt] = string(s[1..j-1]);
1646        s = s[j+1..size(s)];
1647      }
1648    }
1649    return(LS);
1650  }
1651  if (j==0)
1652  {
1653    "j==0 situation";
1654    // no pluses at all except the lead coef => the rest are minuses only
1655    cnt++;
1656    LS[cnt] = string(s[1..i-1]);
1657    s = s[i..size(s)];
1658    while (s!= "")
1659    {
1660      i = find(s,"-",2);
1661      cnt++;
1662      if (i==0)
1663      {
1664        LS[cnt] = string(s);
1665        s = "";
1666      }
1667      else
1668      {
1669        LS[cnt] = string(s[1..i-1]);
1670        s = s[i..size(s)];
1671      }
1672    }
1673    return(LS);
1674  }
1675  // now i, j are nonzero
1676  if (i>j)
1677  {
1678    "i>j situation";
1679    // + comes first, at place j
1680    cnt++;
1681    //    "cnt:"; cnt; "j:"; j;
1682    LS[cnt] = string(s[1..j-1]);
1683    s = s[j+1..size(s)];
1684    LL = stringpoly2lplace(s);
1685    LS = LS + LL;
1686    kill LL;
1687    return(LS);
1688  }
1689  else
1690  {
1691    "j>i situation";
1692    // - might come first, at place i
1693    if (i>1)
1694    {
1695      cnt++;
1696      LS[cnt] = string(s[1..i-1]);
1697      s = s[i..size(s)];
1698    }
1699    else
1700    {
1701      // i==1->  minus at leadcoef
1702      ie = find(s,"-",i+1);
1703      je = find(s,"+",i+1);
1704      if (je == ie)
1705      {
1706         "ie=je situation";
1707        //monomial
1708        cnt++;
1709        LS[cnt] = s;
1710        return(LS);
1711      }
1712      if (je < ie)
1713      {
1714         "je<ie situation";
1715        // + comes first
1716        cnt++;
1717        LS[cnt] = s[1..je-1];
1718        s = s[je+1..size(s)];
1719      }
1720      else
1721      {
1722        // ie < je
1723         "ie<je situation";
1724        cnt++;
1725        LS[cnt] = s[1..ie-1];
1726        s = s[ie..size(s)];
1727      }
1728    }
1729    "going into recursion with "+s;
1730    LL = stringpoly2lplace(s);
1731    LS = LS + LL;
1732    return(LS);
1733  }
1734}
1735example
1736{
1737  "EXAMPLE:"; echo = 2;
1738  string s = "x*y+y*z+z*t"; // + only
1739  stringpoly2lplace(s);
1740  string s2 = "x*y - y*z-z*t*w*w"; // +1, - only
1741  stringpoly2lplace(s2);
1742  string s3 = "-x*y + y - 2*x +7*w*w*w";
1743  stringpoly2lplace(s3);
1744}
1745
1746static proc addplaces(list L)
1747{
1748  // adds places to the list of strings
1749  // according to their order in the list
1750  int s = size(L);
1751  int i;
1752  for (i=1; i<=s; i++)
1753  {
1754    if (typeof(L[i]) == "string")
1755    {
1756      L[i] = L[i] + "(" + string(i) + ")";
1757    }
1758    else
1759    {
1760      ERROR("entry of type string expected");
1761      return(0);
1762    }
1763  }
1764  return(L);
1765}
1766example
1767{
1768  "EXAMPLE:"; echo = 2;
1769  string a = "f1";   string b = "f2";
1770  list L = a,b,a;
1771  addplaces(L);
1772}
1773
1774static proc sent2lplace(string s)
1775{
1776  // SENTence of words TO LetterPLACE
1777  list L =   stringpoly2lplace(s);
1778  int i; int ss = size(L);
1779  for(i=1; i<=ss; i++)
1780  {
1781    L[i] = str2lplace(L[i]);
1782  }
1783  return(L);
1784}
1785example
1786{
1787  "EXAMPLE:"; echo = 2;
1788  ring r = 0,(f2,f1),dp;
1789  string s = "f2*f1*f1 - 2*f1*f2*f1+ f1*f1*f2";
1790  sent2lplace(s);
1791}
1792
1793static proc testnumber(string s)
1794{
1795  string t;
1796  if (s[1]=="-")
1797  {
1798    // two situations: either there's a negative number
1799    t = s[2..size(s)];
1800    if (testnumber(t))
1801    {
1802      //a negative number
1803    }
1804    else
1805    {
1806      // a variable times -1
1807    }
1808    // or just a "-" for -1
1809  }
1810  t = "ring @r=(";
1811  t = t + charstr(basering)+"),";
1812  t = t + string(var(1))+",dp;";
1813  //  write(":w tstnum.tst",t);
1814  t = t+ "number @@Nn = " + s + ";"+"$";
1815  write(":w tstnum.tst",t);
1816  string runsing = system("Singular");
1817  int k;
1818  t = runsing+ " -teq <tstnum.tst >tstnum.out";
1819  k = system("sh",t);
1820  if (k!=0)
1821  {
1822    ERROR("Problems running Singular");
1823  }
1824  int i = system("sh", "grep error tstnum.out > /dev/NULL");
1825  if (i!=0)
1826  {
1827    // no error: s is a number
1828    i = 1;
1829  }
1830  k = system("sh","rm tstnum.tst tstnum.out > /dev/NULL");
1831  return(i);
1832}
1833example
1834{
1835  "EXAMPLE:"; echo = 2;
1836  ring r = (0,a),x,dp;
1837  string s = "a^2+7*a-2";
1838  testnumber(s);
1839  s = "b+a";
1840  testnumber(s);
1841}
1842
1843static proc str2lplace(string s)
1844{
1845  // converts a word (monomial) with coeff into letter-place
1846  // string: coef*var1^exp1*var2^exp2*...varN^expN
1847  s = strpower2rep(s); // expand powers
1848  if (size(s)==0) { return(0); }
1849  int i,j,k,insC;
1850  string a,b,c,d,t;
1851  // 1. get coeff
1852  i = find(s,"*");
1853  if (i==0) { return(s); }
1854  list VN;
1855  c = s[1..i-1]; // incl. the case like (-a^2+1)
1856  int tn = testnumber(c);
1857  if (tn == 0)
1858  {
1859    // failed test
1860    if (c[1]=="-")
1861    {
1862      // two situations: either there's a negative number
1863      t = c[2..size(c)];
1864      if (testnumber(t))
1865      {
1866         //a negative number
1867        // nop here
1868      }
1869      else
1870      {
1871         // a variable times -1
1872          c = "-1";
1873          j++; VN[j] = t; //string(c[2..size(c)]);
1874          insC = 1;
1875      }
1876    }
1877    else
1878    {
1879      // just a variable with coeff 1
1880          j++; VN[j] = string(c);
1881          c = "1";
1882          insC = 1;
1883    }
1884  }
1885 // get vars
1886  t = s;
1887  //  t = s[i+1..size(s)];
1888  k = size(t); //j = 0;
1889  while (k>0)
1890  {
1891    t = t[i+1..size(t)]; //next part
1892    i = find(t,"*"); // next *
1893    if (i==0)
1894    {
1895      // last monomial
1896      j++;
1897      VN[j] = t;
1898      k = size(t);
1899      break;
1900    }
1901    b = t[1..i-1];
1902    //    print(b);
1903    j++;
1904    VN[j] = b;
1905    k = size(t);
1906  }
1907  VN = addplaces(VN);
1908  VN[size(VN)+1] = string(c);
1909  return(VN);
1910}
1911example
1912{
1913  "EXAMPLE:"; echo = 2;
1914  ring r = (0,a),(f2,f1),dp;
1915  str2lplace("-2*f2^2*f1^2*f2");
1916  str2lplace("-f1*f2");
1917  str2lplace("(-a^2+7a)*f1*f2");
1918}
1919
1920static proc strpower2rep(string s)
1921{
1922  // makes x*x*x*x out of x^4 ., rep statys for repetitions
1923  // looks for "-" problem
1924  // exception: "-" as coeff
1925  string ex,t;
1926  int i,j,k;
1927
1928  i = find(s,"^"); // first ^
1929  if (i==0) { return(s); } // no ^ signs
1930
1931  if (s[1] == "-")
1932  {
1933    // either -coef or -1
1934    // got the coeff:
1935    i = find(s,"*");
1936    if (i==0)
1937    {
1938      // no *'s   => coef == -1 or s == -23
1939      i = size(s)+1;
1940    }
1941    t = string(s[2..i-1]); // without "-"
1942    if ( testnumber(t) )
1943    {
1944      // a good number
1945      t = strpower2rep(string(s[2..size(s)]));
1946      t = "-"+t;
1947      return(t);
1948    }
1949    else
1950    {
1951      // a variable
1952      t = strpower2rep(string(s[2..size(s)]));
1953      t = "-1*"+ t;
1954      return(t);
1955    }
1956  }
1957  // the case when leadcoef is a number in ()
1958  if (s[1] == "(")
1959  {
1960    i = find(s,")",2);    // must be nonzero
1961    t = s[2..i-1];
1962    if ( testnumber(t) )
1963    {
1964      // a good number
1965    }
1966    else {"strpower2rep: bad number as coef";}
1967    ex = string(s[i+2..size(s)]); // 2 because of *
1968    ex =  strpower2rep(ex);
1969    t = "("+t+")*"+ex;
1970    return(t);
1971  }
1972
1973  i = find(s,"^"); // first ^
1974  j = find(s,"*",i+1); // next * == end of ^
1975  if (j==0)
1976  {
1977    ex = s[i+1..size(s)];
1978  }
1979  else
1980  {
1981    ex = s[i+1..j-1];
1982  }
1983  execute("int @exp = " + ex + ";"); //@exp = exponent
1984  // got varname
1985  for (k=i-1; k>0; k--)
1986  {
1987    if (s[k] == "*") break;
1988  }
1989  string varn = s[k+1..i-1];
1990  //  "varn:";  varn;
1991  string pref;
1992  if (k>0)
1993  {
1994    pref = s[1..k]; // with * on the k-th place
1995  }
1996  //  "pref:";  pref;
1997  string suf;
1998  if ( (j>0) && (j+1 <= size(s)) )
1999  {
2000    suf = s[j+1..size(s)]; // without * on the 1st place
2001  }
2002  //  "suf:"; suf;
2003  string toins;
2004  for (k=1; k<=@exp; k++)
2005  {
2006    toins = toins + varn+"*";
2007  }
2008  //  "toins: ";  toins;
2009  if (size(suf) == 0)
2010  {
2011    toins = toins[1..size(toins)-1]; // get rid of trailing *
2012  }
2013  else
2014  {
2015    suf = strpower2rep(suf);
2016  }
2017  ex = pref + toins + suf;
2018  return(ex);
2019  //  return(strpower2rep(ex));
2020}
2021example
2022{
2023  "EXAMPLE:"; echo = 2;
2024  ring r = (0,a),(x,y,z,t),dp;
2025  strpower2rep("-x^4");
2026  strpower2rep("-2*x^4*y^3*z*t^2");
2027  strpower2rep("-a^2*x^4");
2028}
2029
2030proc lieBracket(poly a, poly b, list #)
2031"USAGE:  lieBracket(a,b[,N]); a,b letterplace polynomials, N an optional integer
2032RETURN:  poly
2033ASSUME: basering has a letterplace ring structure
2034PURPOSE: compute the Lie bracket [a,b] = ab - ba between letterplace polynomials
2035NOTE: if N>1 is specified, then the left normed bracket [a,[...[a,b]]]] is computed.
2036EXAMPLE: example lieBracket; shows examples
2037"
2038{
2039  if (lpAssumeViolation())
2040  {
2041    //    ERROR("Either 'uptodeg' or 'lV' global variables are not set!");
2042    ERROR("Incomplete Letterplace structure on the basering!");
2043  }
2044  // alias ppLiebr;
2045  //if int N is given compute [a,[...[a,b]]]] left normed bracket
2046  poly q;
2047  int N=1;
2048  if (size(#)>0)
2049  {
2050    if (typeof(#[1])=="int")
2051    {
2052      N = int(#[1]);
2053    }
2054  }
2055  if (N<=0) { return(q); }
2056  while (b!=0)
2057  {
2058    q = q + pmLiebr(a,lead(b));
2059    b = b - lead(b);
2060  }
2061  int i;
2062  if (N >1)
2063  {
2064    for(i=1; i<=N; i++)
2065    {
2066      q = lieBracket(a,q);
2067    }
2068  }
2069  return(q);
2070}
2071example
2072{
2073  "EXAMPLE:"; echo = 2;
2074  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
2075  def R = setLetterplaceAttributes(r,4,2); // supply R with letterplace structure
2076  setring R;
2077  poly a = x(1)*y(2); poly b = y(1);
2078  lieBracket(a,b);
2079  lieBracket(x(1),y(1),2);
2080}
2081
2082static proc pmLiebr(poly a, poly b)
2083{
2084  //  a poly, b mono
2085  poly s;
2086  while (a!=0)
2087  {
2088    s = s + mmLiebr(lead(a),lead(b));
2089    a = a - lead(a);
2090  }
2091  return(s);
2092}
2093
2094proc shiftPoly(poly a, int i)
2095"USAGE:  shiftPoly(p,i); p letterplace poly, i int
2096RETURN: poly
2097ASSUME: basering has letterplace ring structure
2098PURPOSE: compute the i-th shift of letterplace polynomial p
2099EXAMPLE: example shiftPoly; shows examples
2100"
2101{
2102  // shifts a monomial a by i
2103  // calls pLPshift(p,sh,uptodeg,lVblock);
2104  if (lpAssumeViolation())
2105  {
2106    ERROR("Incomplete Letterplace structure on the basering!");
2107  }
2108  int uptodeg = attrib(basering,"uptodeg");
2109  int lV = attrib(basering,"lV");
2110  if (deg(a) + i > uptodeg)
2111  {
2112    ERROR("degree bound violated by the shift!");
2113  }
2114  return(system("stest",a,i,uptodeg,lV));
2115}
2116example
2117{
2118  "EXAMPLE:"; echo = 2;
2119  ring r = 0,(x,y,z),dp;
2120  int uptodeg = 5; int lV = 3;
2121  def R = makeLetterplaceRing(uptodeg);
2122  setring R;
2123  poly f = x(1)*z(2)*y(3) - 2*z(1)*y(2) + 3*x(1);
2124  shiftPoly(f,1);
2125  shiftPoly(f,2);
2126}
2127
2128
2129static proc mmLiebr(poly a, poly b)
2130{
2131  // a,b, monomials
2132  a = lead(a);
2133  b = lead(b);
2134  int sa = deg(a);
2135  int sb = deg(b);
2136  poly v = a*shiftPoly(b,sa) - b*shiftPoly(a,sb);
2137  return(v);
2138}
2139
2140static proc test_shift()
2141{
2142  LIB "freegb.lib";
2143  ring r = 0,(a,b),dp;
2144  int d =5;
2145  def R = makeLetterplaceRing(d);
2146  setring R;
2147  int uptodeg = d;
2148  int lV = 2;
2149  def R = setLetterplaceAttributes(r,uptodeg,2); // supply R with letterplace structure
2150  setring R;
2151  poly p = mmLiebr(a(1),b(1));
2152  poly p = lieBracket(a(1),b(1));
2153}
2154
2155proc serreRelations(intmat A, int zu)
2156"USAGE:  serreRelations(A,z); A an intmat, z an int
2157RETURN:  ideal
2158ASSUME: basering has a letterplace ring structure and
2159@*          A is a generalized Cartan matrix with integer entries
2160PURPOSE: compute the ideal of Serre's relations associated to A
2161EXAMPLE: example serreRelations; shows examples
2162"
2163{
2164  // zu = 1 -> with commutators [f_i,f_j]; zu == 0 without them
2165  // suppose that A is cartan matrix
2166  // then Serre's relations are
2167  // (ad f_j)^{1-A_{ij}} ( f_i)
2168  int ppl = printlevel-voice+2;
2169  int n = ncols(A); // hence n variables
2170  int i,j,k,el;
2171  poly p,q;
2172  ideal I;
2173  for (i=1; i<=n; i++)
2174  {
2175    for (j=1; j<=n; j++)
2176    {
2177      el = 1 - A[i,j];
2178      //     printf("i:%s, j: %s, l: %s",i,j,l);
2179      dbprint(ppl,"i, j, l: ",i,j,el);
2180      //      if ((i!=j) && (l >0))
2181      //      if ( (i!=j) &&  ( ((zu ==0) &&  (l >=2)) || ((zu ==1) &&  (l >=1)) ) )
2182      if ((i!=j) && (el >0))
2183      {
2184        q = lieBracket(var(j),var(i));
2185        dbprint(ppl,"first bracket: ",q);
2186        //        if (l >=2)
2187        //        {
2188          for (k=1; k<=el-1; k++)
2189          {
2190            q = lieBracket(var(j),q);
2191            dbprint(ppl,"further bracket:",q);
2192          }
2193          //        }
2194      }
2195      if (q!=0) { I = I,q; q=0;}
2196    }
2197  }
2198  I = simplify(I,2);
2199  return(I);
2200}
2201example
2202{
2203  "EXAMPLE:"; echo = 2;
2204  intmat A[3][3] =
2205    2, -1, 0,
2206    -1, 2, -3,
2207    0, -1, 2; // G^1_2 Cartan matrix
2208  ring r = 0,(f1,f2,f3),dp;
2209  int uptodeg = 5;
2210  def R = makeLetterplaceRing(uptodeg);
2211  setring R;
2212  ideal I = serreRelations(A,1); I = simplify(I,1+2+8);
2213  I;
2214}
2215
2216/* setup for older example:
2217  intmat A[2][2] = 2, -1, -1, 2; // sl_3 == A_2
2218  ring r = 0,(f1,f2),dp;
2219  int uptodeg = 5; int lV = 2;
2220*/
2221
2222proc lp2lstr(ideal K, def save)
2223"USAGE:  lp2lstr(K,s); K an ideal, s a ring
2224RETURN:  nothing (exports object @LN into s)
2225ASSUME: basering has a letterplace ring structure
2226PURPOSE: converts letterplace ideal to list of modules
2227NOTE: useful as preprocessing to 'lst2str'
2228EXAMPLE: example lp2lstr; shows examples
2229"
2230{
2231  def @R = basering;
2232  string err;
2233  int s = nvars(save);
2234  int i,j,k;
2235    // K contains vars x(1),...z(1) = images of originals
2236  // 5. go back to orig vars, produce strings/modules
2237  int sk = size(K);
2238  int sp, sx, a, b;
2239  intvec x;
2240  poly p,q;
2241  poly pn;
2242  // vars in 'save'
2243  setring save;
2244  module N;
2245  list LN;
2246  vector V;
2247  poly pn;
2248  // test and skip exponents >=2
2249  setring @R;
2250  for(i=1; i<=sk; i++)
2251  {
2252    p  = K[i];
2253    while (p!=0)
2254    {
2255      q  = lead(p);
2256      //      "processing q:";q;
2257      x  = leadexp(q);
2258      sx = size(x);
2259      for(k=1; k<=sx; k++)
2260      {
2261        if ( x[k] >= 2 )
2262        {
2263          err = "skip: the value x[k] is " + string(x[k]);
2264          dbprint(ppl,err);
2265          //            return(0);
2266          K[i] = 0;
2267          p    = 0;
2268          q    = 0;
2269          break;
2270        }
2271      }
2272      p  = p - q;
2273    }
2274  }
2275  K  = simplify(K,2);
2276  sk = size(K);
2277  for(i=1; i<=sk; i++)
2278  {
2279    //    setring save;
2280    //    V  = 0;
2281    setring @R;
2282    p  = K[i];
2283    while (p!=0)
2284    {
2285      q  = lead(p);
2286      err =  "processing q:" + string(q);
2287      dbprint(ppl,err);
2288      x  = leadexp(q);
2289      sx = size(x);
2290      pn = leadcoef(q);
2291      setring save;
2292      pn = imap(@R,pn);
2293      V  = V + leadcoef(pn)*gen(1);
2294      for(k=1; k<=sx; k++)
2295      {
2296        if (x[k] ==1)
2297        {
2298          a = k / s; // block number=a+1, a!=0
2299          b = k % s; // remainder
2300          //          printf("a: %s, b: %s",a,b);
2301          if (b == 0)
2302          {
2303            // that is it's the last var in the block
2304            b = s;
2305            a = a-1;
2306          }
2307          V = V + var(b)*gen(a+2);
2308        }
2309      }
2310      err = "V: " + string(V);
2311      dbprint(ppl,err);
2312      //      printf("V: %s", string(V));
2313      N = N,V;
2314      V  = 0;
2315      setring @R;
2316      p  = p - q;
2317      pn = 0;
2318    }
2319    setring save;
2320    LN[i] = simplify(N,2);
2321    N     = 0;
2322  }
2323  setring save;
2324  list @LN = LN;
2325  export @LN;
2326  //  return(LN);
2327}
2328example
2329{
2330  "EXAMPLE:"; echo = 2;
2331  intmat A[2][2] = 2, -1, -1, 2; // sl_3 == A_2
2332  ring r = 0,(f1,f2),dp;
2333  def R = makeLetterplaceRing(3);
2334  setring R;
2335  ideal I = serreRelations(A,1);
2336  lp2lstr(I,r);
2337  setring r;
2338  lst2str(@LN,1);
2339}
2340
2341static proc strList2poly(list L)
2342{
2343  //  list L comes from sent2lplace (which takes a poly on the input)
2344  // each entry of L is a sublist with the coef on the last place
2345  int s = size(L); int t;
2346  int i,j;
2347  list M;
2348  poly p,q;
2349  string Q;
2350  for(i=1; i<=s; i++)
2351  {
2352    M = L[i];
2353    t = size(M);
2354    //    q = M[t]; // a constant
2355    Q = string(M[t]);
2356    for(j=1; j<t; j++)
2357    {
2358      //      q = q*M[j];
2359      Q = Q+"*"+string(M[j]);
2360    }
2361    execute("q="+Q+";");
2362    //    q;
2363    p = p + q;
2364  }
2365  kill Q;
2366  return(p);
2367}
2368example
2369{
2370  "EXAMPLE:"; echo = 2;
2371  ring r =0,(x,y,z,t),Dp;
2372  def A = makeLetterplaceRing(4);
2373  setring A;
2374  string t = "-2*y*z*y*z + y*t*z*z - z*x*x*y  + 2*z*y*z*y";
2375  list L = sent2lplace(t);
2376  L;
2377  poly p = strList2poly(L);
2378  p;
2379}
2380
2381static proc file2lplace(string fname)
2382"USAGE:  file2lplace(fnm);  fnm a string
2383RETURN:  ideal
2384PURPOSE: convert the contents of the file fnm into ideal of polynomials in free algebra
2385EXAMPLE: example file2lplace; shows examples
2386"
2387{
2388  // format: from the usual string to letterplace
2389  string s = read(fname);
2390  // assume: file is a comma-sep list of polys
2391  // the vars are declared before
2392  // the file ends with ";"
2393  string t; int i;
2394  ideal I;
2395  list tst;
2396  while (s!="")
2397  {
2398    i = find(s,",");
2399    "i"; i;
2400    if (i==0)
2401    {
2402      i = find(s,";");
2403      if (i==0)
2404      {
2405        // no ; ??
2406         "no colon or semicolon found anymore";
2407         return(I);
2408      }
2409      // no "," but ";" on the i-th place
2410      t = s[1..i-1];
2411      s = "";
2412      "processing: "; t;
2413      tst = sent2lplace(t);
2414      tst;
2415      I = I, strList2poly(tst);
2416      return(I);
2417    }
2418    // here i !=0
2419    t = s[1..i-1];
2420    s = s[i+1..size(s)];
2421    "processing: "; t;
2422    tst = sent2lplace(t);
2423    tst;
2424    I = I, strList2poly(tst);
2425  }
2426  return(I);
2427}
2428example
2429{
2430  "EXAMPLE:"; echo = 2;
2431  ring r =0,(x,y,z,t),dp;
2432  def A = makeLetterplaceRing(4);
2433  setring A;
2434  string fn = "myfile";
2435  string s1 = "z*y*y*y - 3*y*z*x*y  + 3*y*y*z*y - y*x*y*z,";
2436  string s2 = "-2*y*x*y*z + y*y*z*z - z*z*y*y + 2*z*y*z*y,";
2437  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;";
2438  write(":w "+fn,s1);  write(":a "+fn,s2);   write(":a "+fn,s3);
2439  read(fn);
2440  ideal I = file2lplace(fn);
2441  I;
2442}
2443
2444/* EXAMPLES AGAIN:
2445//static proc get_ls3nilp()
2446{
2447//first app of file2lplace
2448  ring r =0,(x,y,z,t),dp;
2449  int d = 10;
2450  def A = makeLetterplaceRing(d);
2451  setring A;
2452  ideal I = file2lplace("./ls3nilp.bg");
2453  // and now test the correctness: go back from lplace to strings
2454  lp2lstr(I,r);
2455  setring r;
2456  lst2str(@LN,1); // agree!
2457}
2458
2459//static proc doc_example()
2460{
2461  LIB "freegb.lib";
2462  ring r = 0,(x,y,z),dp;
2463  int d =4; // degree bound
2464  def R = makeLetterplaceRing(d);
2465  setring R;
2466  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);
2467  option(redSB);option(redTail);
2468  ideal J = system("freegb",I,d,nvars(r));
2469  J;
2470  // visualization:
2471  lp2lstr(J,r); // export an object called @LN to the ring r
2472  setring r;  // change to the ring r
2473  lst2str(@LN,1); // output the strings
2474}
2475
2476*/
2477
2478// TODO:
2479// multiply two letterplace polynomials, lpMult
2480// reduction/ Normalform? needs kernel stuff
2481
2482proc lpMult(poly f, poly g)
2483"USAGE:  lpMult(f,g); f,g letterplace polynomials
2484RETURN:  poly
2485ASSUME: basering has a letterplace ring structure
2486PURPOSE: compute the letterplace form of f*g
2487EXAMPLE: example lpMult; shows examples
2488"
2489{
2490  if (lpAssumeViolation())
2491  {
2492    ERROR("Incomplete Letterplace structure on the basering!");
2493  }
2494  int sf = deg(f);
2495  int sg = deg(g);
2496  int uptodeg = attrib(basering, "uptodeg");
2497  if (sf+sg > uptodeg)
2498  {
2499    ERROR("degree bound violated by the product!");
2500  }
2501  //  if (sf>1) { sf = sf -1; }
2502  poly v = f*shiftPoly(g,sf);
2503  return(v);
2504}
2505example
2506{
2507  "EXAMPLE:"; echo = 2;
2508  // define a ring in letterplace form as follows:
2509  ring r = 0,(x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)),dp;
2510  poly a = x(1)*y(2); poly b = y(1);
2511  def R = setLetterplaceAttributes(r,4,2); // supply R with letterplace structure
2512  setring R;
2513  lpMult(b,a);
2514  lpMult(a,b);
2515}
2516
2517static proc lpAssumeViolation()
2518{
2519  // checks whether the global vars
2520  // uptodeg and lV are defined
2521  // returns Boolean : yes/no [for assume violation]
2522  def lpring = attrib(basering,"isLetterplaceRing");
2523  if ( typeof(lpring)!="int" )
2524  {
2525    //  if ( typeof(lpring)=="string" ) ??
2526    // basering is NOT lp Ring
2527
2528    return(1);
2529  }
2530  def uptodeg = attrib(basering,"uptodeg");
2531  if ( typeof(uptodeg)!="int" )
2532  {
2533    return(1);
2534  }
2535  def lV = attrib(basering,"lV");
2536  if ( typeof(lV)!="int" )
2537  {
2538    return(1);
2539  }
2540  //  int i = ( defined(uptodeg) && (defined(lV)) );
2541  //  return ( !i );
2542  return(0);
2543}
2544
2545// alias libs for compatibility with older examples
2546proc freegbRing(int d)
2547{
2548  return(makeLetterplaceRing(d));
2549}
2550
2551proc freegbasis( list L, int n)
2552{
2553  return(freeGBasis(L, n));
2554}
Note: See TracBrowser for help on using the repository browser.