source: git/Singular/LIB/freegb.lib @ 334c21f

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