source: git/kernel/combinatorics/hdegree.cc @ b347d6

spielwiese
Last change on this file since b347d6 was b347d6, checked in by Hans Schoenemann <hannes@…>, 23 months ago
opt: hdegree.cc: hIndep, hCheckIndep
  • Property mode set to 100644
File size: 47.9 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/*
5*  ABSTRACT -  dimension, multiplicity, HC, kbase
6*/
7
8#include "kernel/mod2.h"
9
10#include "misc/intvec.h"
11#include "coeffs/numbers.h"
12
13#include "kernel/structs.h"
14#include "kernel/ideals.h"
15#include "kernel/polys.h"
16
17#include "kernel/combinatorics/hutil.h"
18#include "kernel/combinatorics/hilb.h"
19#include "kernel/combinatorics/stairc.h"
20#include "reporter/reporter.h"
21
22#ifdef HAVE_SHIFTBBA
23#include <vector>
24#include "misc/options.h"
25#endif
26
27VAR int  hCo, hMu, hMu2;
28VAR omBin indlist_bin = omGetSpecBin(sizeof(indlist));
29
30/*0 implementation*/
31
32// dimension
33
34void hDimSolve(scmon pure, int Npure, scfmon rad, int Nrad,
35 varset var, int Nvar)
36{
37  int  dn, iv, rad0, b, c, x;
38  scmon pn;
39  scfmon rn;
40  if (Nrad < 2)
41  {
42    dn = Npure + Nrad;
43    if (dn < hCo)
44      hCo = dn;
45    return;
46  }
47  if (Npure+1 >= hCo)
48    return;
49  iv = Nvar;
50  while(pure[var[iv]]) iv--;
51  hStepR(rad, Nrad, var, iv, &rad0);
52  if (rad0!=0)
53  {
54    iv--;
55    if (rad0 < Nrad)
56    {
57      pn = hGetpure(pure);
58      rn = hGetmem(Nrad, rad, radmem[iv]);
59      hDimSolve(pn, Npure + 1, rn, rad0, var, iv);
60      b = rad0;
61      c = Nrad;
62      hElimR(rn, &rad0, b, c, var, iv);
63      hPure(rn, b, &c, var, iv, pn, &x);
64      hLex2R(rn, rad0, b, c, var, iv, hwork);
65      rad0 += (c - b);
66      hDimSolve(pn, Npure + x, rn, rad0, var, iv);
67    }
68    else
69    {
70      hDimSolve(pure, Npure, rad, Nrad, var, iv);
71    }
72  }
73  else
74    hCo = Npure + 1;
75}
76
77int  scDimInt(ideal S, ideal Q)
78{
79  id_Test(S, currRing);
80  if( Q!=NULL ) id_Test(Q, currRing);
81
82  int  mc;
83  hexist = hInit(S, Q, &hNexist);
84  if (!hNexist)
85    return (currRing->N);
86  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
87  hvar = (varset)omAlloc(((currRing->N) + 1) * sizeof(int));
88  hpure = (scmon)omAlloc((1 + ((currRing->N) * (currRing->N))) * sizeof(int));
89  mc = hisModule;
90  if (!mc)
91  {
92    hrad = hexist;
93    hNrad = hNexist;
94  }
95  else
96    hrad = (scfmon)omAlloc(hNexist * sizeof(scmon));
97  radmem = hCreate((currRing->N) - 1);
98  hCo = (currRing->N) + 1;
99  loop
100  {
101    if (mc)
102      hComp(hexist, hNexist, mc, hrad, &hNrad);
103    if (hNrad)
104    {
105      hNvar = (currRing->N);
106      hRadical(hrad, &hNrad, hNvar);
107      hSupp(hrad, hNrad, hvar, &hNvar);
108      if (hNvar)
109      {
110        memset(hpure, 0, ((currRing->N) + 1) * sizeof(int));
111        hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
112        hLexR(hrad, hNrad, hvar, hNvar);
113        hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
114      }
115    }
116    else
117    {
118      hCo = 0;
119      break;
120    }
121    mc--;
122    if (mc <= 0)
123      break;
124  }
125  hKill(radmem, (currRing->N) - 1);
126  omFreeSize((ADDRESS)hpure, (1 + ((currRing->N) * (currRing->N))) * sizeof(int));
127  omFreeSize((ADDRESS)hvar, ((currRing->N) + 1) * sizeof(int));
128  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
129  hDelete(hexist, hNexist);
130  if (hisModule)
131    omFreeSize((ADDRESS)hrad, hNexist * sizeof(scmon));
132  return (currRing->N) - hCo;
133}
134
135int  scDimIntRing(ideal vid, ideal Q)
136{
137#ifdef HAVE_RINGS
138  if (rField_is_Ring(currRing))
139  {
140    int i = idPosConstant(vid);
141    if ((i != -1) && (n_IsUnit(pGetCoeff(vid->m[i]),currRing->cf)))
142    { /* ideal v contains unit; dim = -1 */
143      return(-1);
144    }
145    ideal vv = id_Head(vid,currRing);
146    idSkipZeroes(vv);
147    i = idPosConstant(vid);
148    int d;
149    if(i == -1)
150    {
151      d = scDimInt(vv, Q);
152      if(rField_is_Z(currRing))
153        d++;
154    }
155    else
156    {
157      if(n_IsUnit(pGetCoeff(vv->m[i]),currRing->cf))
158        d = -1;
159      else
160        d = scDimInt(vv, Q);
161    }
162    //Anne's Idea for std(4,2x) = 0 bug
163    int dcurr = d;
164    for(unsigned ii=0;ii<(unsigned)IDELEMS(vv);ii++)
165    {
166      if(vv->m[ii] != NULL && !n_IsUnit(pGetCoeff(vv->m[ii]),currRing->cf))
167      {
168        ideal vc = idCopy(vv);
169        poly c = pInit();
170        pSetCoeff0(c,nCopy(pGetCoeff(vv->m[ii])));
171        idInsertPoly(vc,c);
172        idSkipZeroes(vc);
173        for(unsigned jj = 0;jj<(unsigned)IDELEMS(vc)-1;jj++)
174        {
175          if((vc->m[jj]!=NULL)
176          && (n_DivBy(pGetCoeff(vc->m[jj]),pGetCoeff(c),currRing->cf)))
177          {
178            pDelete(&vc->m[jj]);
179          }
180        }
181        idSkipZeroes(vc);
182        i = idPosConstant(vc);
183        if (i != -1) pDelete(&vc->m[i]);
184        dcurr = scDimInt(vc, Q);
185        // the following assumes the ground rings to be either zero- or one-dimensional
186        if((i==-1) && rField_is_Z(currRing))
187        {
188          // should also be activated for other euclidean domains as groundfield
189          dcurr++;
190        }
191        idDelete(&vc);
192      }
193      if(dcurr > d)
194          d = dcurr;
195    }
196    idDelete(&vv);
197    return d;
198  }
199#endif
200  return scDimInt(vid,Q);
201}
202
203// independent set
204STATIC_VAR scmon hInd;
205
206static void hIndSolve(scmon pure, int Npure, scfmon rad, int Nrad,
207 varset var, int Nvar)
208{
209  int  dn, iv, rad0, b, c, x;
210  scmon pn;
211  scfmon rn;
212  if (Nrad < 2)
213  {
214    dn = Npure + Nrad;
215    if (dn < hCo)
216    {
217      hCo = dn;
218      for (iv=(currRing->N); iv; iv--)
219      {
220        if (pure[iv])
221          hInd[iv] = 0;
222        else
223          hInd[iv] = 1;
224      }
225      if (Nrad)
226      {
227        pn = *rad;
228        iv = Nvar;
229        loop
230        {
231          x = var[iv];
232          if (pn[x])
233          {
234            hInd[x] = 0;
235            break;
236          }
237          iv--;
238        }
239      }
240    }
241    return;
242  }
243  if (Npure+1 >= hCo)
244    return;
245  iv = Nvar;
246  while(pure[var[iv]]) iv--;
247  hStepR(rad, Nrad, var, iv, &rad0);
248  if (rad0)
249  {
250    iv--;
251    if (rad0 < Nrad)
252    {
253      pn = hGetpure(pure);
254      rn = hGetmem(Nrad, rad, radmem[iv]);
255      pn[var[iv + 1]] = 1;
256      hIndSolve(pn, Npure + 1, rn, rad0, var, iv);
257      pn[var[iv + 1]] = 0;
258      b = rad0;
259      c = Nrad;
260      hElimR(rn, &rad0, b, c, var, iv);
261      hPure(rn, b, &c, var, iv, pn, &x);
262      hLex2R(rn, rad0, b, c, var, iv, hwork);
263      rad0 += (c - b);
264      hIndSolve(pn, Npure + x, rn, rad0, var, iv);
265    }
266    else
267    {
268      hIndSolve(pure, Npure, rad, Nrad, var, iv);
269    }
270  }
271  else
272  {
273    hCo = Npure + 1;
274    for (x=(currRing->N); x; x--)
275    {
276      if (pure[x])
277        hInd[x] = 0;
278      else
279        hInd[x] = 1;
280    }
281    hInd[var[iv]] = 0;
282  }
283}
284
285intvec * scIndIntvec(ideal S, ideal Q)
286{
287  id_Test(S, currRing);
288  if( Q!=NULL ) id_Test(Q, currRing);
289
290  intvec *Set=new intvec((currRing->N));
291  int  mc,i;
292  hexist = hInit(S, Q, &hNexist);
293  if (hNexist==0)
294  {
295    for(i=0; i<(currRing->N); i++)
296      (*Set)[i]=1;
297    return Set;
298  }
299  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
300  hvar = (varset)omAlloc(((currRing->N) + 1) * sizeof(int));
301  hpure = (scmon)omAlloc((1 + ((currRing->N) * (currRing->N))) * sizeof(int));
302  hInd = (scmon)omAlloc0((1 + (currRing->N)) * sizeof(int));
303  mc = hisModule;
304  if (mc==0)
305  {
306    hrad = hexist;
307    hNrad = hNexist;
308  }
309  else
310    hrad = (scfmon)omAlloc(hNexist * sizeof(scmon));
311  radmem = hCreate((currRing->N) - 1);
312  hCo = (currRing->N) + 1;
313  loop
314  {
315    if (mc!=0)
316      hComp(hexist, hNexist, mc, hrad, &hNrad);
317    if (hNrad!=0)
318    {
319      hNvar = (currRing->N);
320      hRadical(hrad, &hNrad, hNvar);
321      hSupp(hrad, hNrad, hvar, &hNvar);
322      if (hNvar!=0)
323      {
324        memset(hpure, 0, ((currRing->N) + 1) * sizeof(int));
325        hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
326        hLexR(hrad, hNrad, hvar, hNvar);
327        hIndSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
328      }
329    }
330    else
331    {
332      hCo = 0;
333      break;
334    }
335    mc--;
336    if (mc <= 0)
337      break;
338  }
339  for(i=0; i<(currRing->N); i++)
340    (*Set)[i] = hInd[i+1];
341  hKill(radmem, (currRing->N) - 1);
342  omFreeSize((ADDRESS)hpure, (1 + ((currRing->N) * (currRing->N))) * sizeof(int));
343  omFreeSize((ADDRESS)hInd, (1 + (currRing->N)) * sizeof(int));
344  omFreeSize((ADDRESS)hvar, ((currRing->N) + 1) * sizeof(int));
345  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
346  hDelete(hexist, hNexist);
347  if (hisModule)
348    omFreeSize((ADDRESS)hrad, hNexist * sizeof(scmon));
349  return Set;
350}
351
352VAR indset ISet, JSet;
353
354static BOOLEAN hNotZero(scfmon rad, int Nrad, varset var, int Nvar)
355{
356  int  k1, i;
357  k1 = var[Nvar];
358  i = 0;
359  loop
360  {
361    if (rad[i][k1]==0)
362      return FALSE;
363    i++;
364    if (i == Nrad)
365      return TRUE;
366  }
367}
368
369static void hIndep(scmon pure)
370{
371  int iv;
372  intvec *Set;
373
374  Set = ISet->set = new intvec((currRing->N));
375  for (iv=(currRing->N); iv!=0 ; iv--)
376  {
377    (*Set)[iv-1] = (pure[iv]==0);
378  }
379  ISet = ISet->nx = (indset)omAlloc0Bin(indlist_bin);
380  hMu++;
381}
382
383void hIndMult(scmon pure, int Npure, scfmon rad, int Nrad,
384 varset var, int Nvar)
385{
386  int  dn, iv, rad0, b, c, x;
387  scmon pn;
388  scfmon rn;
389  if (Nrad < 2)
390  {
391    dn = Npure + Nrad;
392    if (dn == hCo)
393    {
394      if (Nrad==0)
395        hIndep(pure);
396      else
397      {
398        pn = *rad;
399        for (iv = Nvar; iv!=0; iv--)
400        {
401          x = var[iv];
402          if (pn[x])
403          {
404            pure[x] = 1;
405            hIndep(pure);
406            pure[x] = 0;
407          }
408        }
409      }
410    }
411    return;
412  }
413  iv = Nvar;
414  dn = Npure+1;
415  if (dn >= hCo)
416  {
417    if (dn > hCo)
418      return;
419    loop
420    {
421      if(!pure[var[iv]])
422      {
423        if(hNotZero(rad, Nrad, var, iv))
424        {
425          pure[var[iv]] = 1;
426          hIndep(pure);
427          pure[var[iv]] = 0;
428        }
429      }
430      iv--;
431      if (!iv)
432        return;
433    }
434  }
435  while(pure[var[iv]]) iv--;
436  hStepR(rad, Nrad, var, iv, &rad0);
437  iv--;
438  if (rad0 < Nrad)
439  {
440    pn = hGetpure(pure);
441    rn = hGetmem(Nrad, rad, radmem[iv]);
442    pn[var[iv + 1]] = 1;
443    hIndMult(pn, Npure + 1, rn, rad0, var, iv);
444    pn[var[iv + 1]] = 0;
445    b = rad0;
446    c = Nrad;
447    hElimR(rn, &rad0, b, c, var, iv);
448    hPure(rn, b, &c, var, iv, pn, &x);
449    hLex2R(rn, rad0, b, c, var, iv, hwork);
450    rad0 += (c - b);
451    hIndMult(pn, Npure + x, rn, rad0, var, iv);
452  }
453  else
454  {
455    hIndMult(pure, Npure, rad, Nrad, var, iv);
456  }
457}
458
459/*3
460* consider indset x := !pure
461* (for all i) (if(sm(i) > x) return FALSE)
462* else return TRUE
463*/
464static BOOLEAN hCheck1(indset sm, scmon pure)
465{
466  int iv;
467  intvec *Set;
468  while (sm->nx != NULL)
469  {
470    Set = sm->set;
471    iv=(currRing->N);
472    loop
473    {
474      if (((*Set)[iv-1] == 0) && (pure[iv] == 0))
475        break;
476      iv--;
477      if (iv == 0)
478        return FALSE;
479    }
480    sm = sm->nx;
481  }
482  return TRUE;
483}
484
485/*3
486* consider indset x := !pure
487* (for all i) if(x > sm(i)) delete sm(i))
488* return (place for x)
489*/
490static indset hCheck2(indset sm, scmon pure)
491{
492  int iv;
493  intvec *Set;
494  indset be, a1 = NULL;
495  while (sm->nx != NULL)
496  {
497    Set = sm->set;
498    iv=(currRing->N);
499    loop
500    {
501      if ((pure[iv] == 1) && ((*Set)[iv-1] == 1))
502        break;
503      iv--;
504      if (iv == 0)
505      {
506        if (a1 == NULL)
507        {
508          a1 = sm;
509        }
510        else
511        {
512          hMu2--;
513          be->nx = sm->nx;
514          delete Set;
515          omFreeBin((ADDRESS)sm, indlist_bin);
516          sm = be;
517        }
518        break;
519      }
520    }
521    be = sm;
522    sm = sm->nx;
523  }
524  if (a1 != NULL)
525  {
526    return a1;
527  }
528  else
529  {
530    hMu2++;
531    sm->set = new intvec((currRing->N));
532    sm->nx = (indset)omAlloc0Bin(indlist_bin);
533    return sm;
534  }
535}
536
537/*2
538*  definition x >= y
539*      x(i) == 0 => y(i) == 0
540*      > ex. j with x(j) == 1 and y(j) == 0
541*/
542static void hCheckIndep(scmon pure)
543{
544  intvec *Set;
545  indset res;
546  int iv;
547  if (hCheck1(ISet, pure))
548  {
549    if (hCheck1(JSet, pure))
550    {
551      res = hCheck2(JSet,pure);
552      if (res == NULL)
553        return;
554      Set = res->set;
555      for (iv=(currRing->N); iv; iv--)
556      {
557        (*Set)[iv-1] = (pure[iv]==0);
558      }
559    }
560  }
561}
562
563void hIndAllMult(scmon pure, int Npure, scfmon rad, int Nrad,
564 varset var, int Nvar)
565{
566  int  dn, iv, rad0, b, c, x;
567  scmon pn;
568  scfmon rn;
569  if (Nrad < 2)
570  {
571    dn = Npure + Nrad;
572    if (dn > hCo)
573    {
574      if (!Nrad)
575        hCheckIndep(pure);
576      else
577      {
578        pn = *rad;
579        for (iv = Nvar; iv; iv--)
580        {
581          x = var[iv];
582          if (pn[x])
583          {
584            pure[x] = 1;
585            hCheckIndep(pure);
586            pure[x] = 0;
587          }
588        }
589      }
590    }
591    return;
592  }
593  iv = Nvar;
594  while(pure[var[iv]]) iv--;
595  hStepR(rad, Nrad, var, iv, &rad0);
596  iv--;
597  if (rad0 < Nrad)
598  {
599    pn = hGetpure(pure);
600    rn = hGetmem(Nrad, rad, radmem[iv]);
601    pn[var[iv + 1]] = 1;
602    hIndAllMult(pn, Npure + 1, rn, rad0, var, iv);
603    pn[var[iv + 1]] = 0;
604    b = rad0;
605    c = Nrad;
606    hElimR(rn, &rad0, b, c, var, iv);
607    hPure(rn, b, &c, var, iv, pn, &x);
608    hLex2R(rn, rad0, b, c, var, iv, hwork);
609    rad0 += (c - b);
610    hIndAllMult(pn, Npure + x, rn, rad0, var, iv);
611  }
612  else
613  {
614    hIndAllMult(pure, Npure, rad, Nrad, var, iv);
615  }
616}
617
618// multiplicity
619
620static int hZeroMult(scmon pure, scfmon stc, int Nstc, varset var, int Nvar)
621{
622  int  iv = Nvar -1, sum, a, a0, a1, b, i;
623  int  x, x0;
624  scmon pn;
625  scfmon sn;
626  if (!iv)
627    return pure[var[1]];
628  else if (!Nstc)
629  {
630    sum = 1;
631    for (i = Nvar; i; i--)
632      sum *= pure[var[i]];
633    return sum;
634  }
635  x = a = 0;
636  pn = hGetpure(pure);
637  sn = hGetmem(Nstc, stc, stcmem[iv]);
638  hStepS(sn, Nstc, var, Nvar, &a, &x);
639  int64 t=hZeroMult(pn, sn, a, var, iv);
640  if (a == Nstc)
641  {
642    t *= pure[var[Nvar]];
643    if ((t>=INT_MIN)&&(t<=INT_MAX)) sum=t;
644    else if (!errorreported) WerrorS("int overflow in vdim 3");
645    return sum;
646    /*return pure[var[Nvar]] * hZeroMult(pn, sn, a, var, iv);*/
647  }
648  else
649  {
650    t *= x;
651    if ((t>=INT_MIN)&&(t<=INT_MAX)) sum=t;
652    else if (!errorreported) WerrorS("int overflow in vdim 4");
653    /*sum = x * hZeroMult(pn, sn, a, var, iv);*/
654  }
655  b = a;
656  loop
657  {
658    a0 = a;
659    x0 = x;
660    hStepS(sn, Nstc, var, Nvar, &a, &x);
661    hElimS(sn, &b, a0, a, var, iv);
662    a1 = a;
663    hPure(sn, a0, &a1, var, iv, pn, &i);
664    hLex2S(sn, b, a0, a1, var, iv, hwork);
665    b += (a1 - a0);
666    if (a < Nstc)
667    {
668      int64 t=hZeroMult(pn, sn, b, var, iv);
669      t *= (x-x0);
670      t += sum;
671      if ((t>=INT_MIN)&&(t<=INT_MAX)) sum=t;
672      else if (!errorreported) WerrorS("int overflow in vdim 1");
673      /*sum += (x - x0) * hZeroMult(pn, sn, b, var, iv);*/
674    }
675    else
676    {
677      int64 t=hZeroMult(pn, sn, b, var, iv);
678      t *= (pure[var[Nvar]]-x0);
679      t += sum;
680      if ((t>=INT_MIN)&&(t<=INT_MAX)) sum=t;
681      else if (!errorreported) WerrorS("int overflow in vdim 2");
682      /*sum += (pure[var[Nvar]] - x0) * hZeroMult(pn, sn, b, var, iv);*/
683      return sum;
684    }
685  }
686}
687
688static void hProject(scmon pure, varset sel)
689{
690  int  i, i0, k;
691  i0 = 0;
692  for (i = 1; i <= (currRing->N); i++)
693  {
694    if (pure[i])
695    {
696      i0++;
697      sel[i0] = i;
698    }
699  }
700  i = hNstc;
701  memcpy(hwork, hstc, i * sizeof(scmon));
702  hStaircase(hwork, &i, sel, i0);
703  if ((i0 > 2) && (i > 10))
704    hOrdSupp(hwork, i, sel, i0);
705  memset(hpur0, 0, ((currRing->N) + 1) * sizeof(int));
706  hPure(hwork, 0, &i, sel, i0, hpur0, &k);
707  hLexS(hwork, i, sel, i0);
708  hMu += hZeroMult(hpur0, hwork, i, sel, i0);
709}
710
711static void hDimMult(scmon pure, int Npure, scfmon rad, int Nrad,
712 varset var, int Nvar)
713{
714  int  dn, iv, rad0, b, c, x;
715  scmon pn;
716  scfmon rn;
717  if (Nrad < 2)
718  {
719    dn = Npure + Nrad;
720    if (dn == hCo)
721    {
722      if (!Nrad)
723        hProject(pure, hsel);
724      else
725      {
726        pn = *rad;
727        for (iv = Nvar; iv; iv--)
728        {
729          x = var[iv];
730          if (pn[x])
731          {
732            pure[x] = 1;
733            hProject(pure, hsel);
734            pure[x] = 0;
735          }
736        }
737      }
738    }
739    return;
740  }
741  iv = Nvar;
742  dn = Npure+1;
743  if (dn >= hCo)
744  {
745    if (dn > hCo)
746      return;
747    loop
748    {
749      if(!pure[var[iv]])
750      {
751        if(hNotZero(rad, Nrad, var, iv))
752        {
753          pure[var[iv]] = 1;
754          hProject(pure, hsel);
755          pure[var[iv]] = 0;
756        }
757      }
758      iv--;
759      if (!iv)
760        return;
761    }
762  }
763  while(pure[var[iv]]) iv--;
764  hStepR(rad, Nrad, var, iv, &rad0);
765  iv--;
766  if (rad0 < Nrad)
767  {
768    pn = hGetpure(pure);
769    rn = hGetmem(Nrad, rad, radmem[iv]);
770    pn[var[iv + 1]] = 1;
771    hDimMult(pn, Npure + 1, rn, rad0, var, iv);
772    pn[var[iv + 1]] = 0;
773    b = rad0;
774    c = Nrad;
775    hElimR(rn, &rad0, b, c, var, iv);
776    hPure(rn, b, &c, var, iv, pn, &x);
777    hLex2R(rn, rad0, b, c, var, iv, hwork);
778    rad0 += (c - b);
779    hDimMult(pn, Npure + x, rn, rad0, var, iv);
780  }
781  else
782  {
783    hDimMult(pure, Npure, rad, Nrad, var, iv);
784  }
785}
786
787static void hDegree(ideal S, ideal Q)
788{
789  id_Test(S, currRing);
790  if( Q!=NULL ) id_Test(Q, currRing);
791
792  int  di;
793  int  mc;
794  hexist = hInit(S, Q, &hNexist);
795  if (!hNexist)
796  {
797    hCo = 0;
798    hMu = 1;
799    return;
800  }
801  //hWeight();
802  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
803  hvar = (varset)omAlloc(((currRing->N) + 1) * sizeof(int));
804  hsel = (varset)omAlloc(((currRing->N) + 1) * sizeof(int));
805  hpure = (scmon)omAlloc((1 + ((currRing->N) * (currRing->N))) * sizeof(int));
806  hpur0 = (scmon)omAlloc((1 + ((currRing->N) * (currRing->N))) * sizeof(int));
807  mc = hisModule;
808  hrad = (scfmon)omAlloc(hNexist * sizeof(scmon));
809  if (!mc)
810  {
811    memcpy(hrad, hexist, hNexist * sizeof(scmon));
812    hstc = hexist;
813    hNrad = hNstc = hNexist;
814  }
815  else
816    hstc = (scfmon)omAlloc(hNexist * sizeof(scmon));
817  radmem = hCreate((currRing->N) - 1);
818  stcmem = hCreate((currRing->N) - 1);
819  hCo = (currRing->N) + 1;
820  di = hCo + 1;
821  loop
822  {
823    if (mc)
824    {
825      hComp(hexist, hNexist, mc, hrad, &hNrad);
826      hNstc = hNrad;
827      memcpy(hstc, hrad, hNrad * sizeof(scmon));
828    }
829    if (hNrad)
830    {
831      hNvar = (currRing->N);
832      hRadical(hrad, &hNrad, hNvar);
833      hSupp(hrad, hNrad, hvar, &hNvar);
834      if (hNvar)
835      {
836        hCo = hNvar;
837        memset(hpure, 0, ((currRing->N) + 1) * sizeof(int));
838        hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
839        hLexR(hrad, hNrad, hvar, hNvar);
840        hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
841      }
842    }
843    else
844    {
845      hNvar = 1;
846      hCo = 0;
847    }
848    if (hCo < di)
849    {
850      di = hCo;
851      hMu = 0;
852    }
853    if (hNvar && (hCo == di))
854    {
855      if (di && (di < (currRing->N)))
856        hDimMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
857      else if (!di)
858        hMu++;
859      else
860      {
861        hStaircase(hstc, &hNstc, hvar, hNvar);
862        if ((hNvar > 2) && (hNstc > 10))
863          hOrdSupp(hstc, hNstc, hvar, hNvar);
864        memset(hpur0, 0, ((currRing->N) + 1) * sizeof(int));
865        hPure(hstc, 0, &hNstc, hvar, hNvar, hpur0, &hNpure);
866        hLexS(hstc, hNstc, hvar, hNvar);
867        hMu += hZeroMult(hpur0, hstc, hNstc, hvar, hNvar);
868      }
869    }
870    mc--;
871    if (mc <= 0)
872      break;
873  }
874  hCo = di;
875  hKill(stcmem, (currRing->N) - 1);
876  hKill(radmem, (currRing->N) - 1);
877  omFreeSize((ADDRESS)hpur0, (1 + ((currRing->N) * (currRing->N))) * sizeof(int));
878  omFreeSize((ADDRESS)hpure, (1 + ((currRing->N) * (currRing->N))) * sizeof(int));
879  omFreeSize((ADDRESS)hsel, ((currRing->N) + 1) * sizeof(int));
880  omFreeSize((ADDRESS)hvar, ((currRing->N) + 1) * sizeof(int));
881  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
882  omFreeSize((ADDRESS)hrad, hNexist * sizeof(scmon));
883  hDelete(hexist, hNexist);
884  if (hisModule)
885    omFreeSize((ADDRESS)hstc, hNexist * sizeof(scmon));
886}
887
888int  scMultInt(ideal S, ideal Q)
889{
890  id_Test(S, currRing);
891  if( Q!=NULL ) id_Test(Q, currRing);
892
893  hDegree(S, Q);
894  return hMu;
895}
896
897void scPrintDegree(int co, int mu)
898{
899  int di = (currRing->N)-co;
900  if (currRing->OrdSgn == 1)
901  {
902    if (di>0)
903      Print("// dimension (proj.)  = %d\n// degree (proj.)   = %d\n", di-1, mu);
904    else
905      Print("// dimension (affine) = 0\n// degree (affine)  = %d\n",       mu);
906  }
907  else
908    Print("// dimension (local)   = %d\n// multiplicity = %d\n", di, mu);
909}
910
911void scDegree(ideal S, intvec *modulweight, ideal Q)
912{
913  id_Test(S, currRing);
914  if( Q!=NULL ) id_Test(Q, currRing);
915
916  int co, mu, l;
917  intvec *hseries2;
918  intvec *hseries1 = hFirstSeries(S, modulweight, Q);
919  if (errorreported) return;
920  l = hseries1->length()-1;
921  if (l > 1)
922    hseries2 = hSecondSeries(hseries1);
923  else
924    hseries2 = hseries1;
925  hDegreeSeries(hseries1, hseries2, &co, &mu);
926  if ((l == 1) &&(mu == 0))
927    scPrintDegree((currRing->N)+1, 0);
928  else
929    scPrintDegree(co, mu);
930  if (l>1)
931    delete hseries1;
932  delete hseries2;
933}
934
935int  scMult0Int(ideal S, ideal Q)
936{
937  id_LmTest(S, currRing);
938  if (Q!=NULL) id_LmTest(Q, currRing);
939
940  int  mc;
941  hexist = hInit(S, Q, &hNexist);
942  if (!hNexist)
943  {
944    hMu = -1;
945    return -1;
946  }
947  else
948    hMu = 0;
949
950  const ring r = currRing;
951
952  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
953  hvar = (varset)omAlloc(((r->N) + 1) * sizeof(int));
954  hpur0 = (scmon)omAlloc((1 + ((r->N) * (r->N))) * sizeof(int));
955  mc = hisModule;
956  if (!mc)
957  {
958    hstc = hexist;
959    hNstc = hNexist;
960  }
961  else
962    hstc = (scfmon)omAlloc(hNexist * sizeof(scmon));
963  stcmem = hCreate((r->N) - 1);
964  loop
965  {
966    if (mc)
967    {
968      hComp(hexist, hNexist, mc, hstc, &hNstc);
969      if (!hNstc)
970      {
971        hMu = -1;
972        break;
973      }
974    }
975    hNvar = (r->N);
976    for (int i = hNvar; i; i--)
977      hvar[i] = i;
978    hStaircase(hstc, &hNstc, hvar, hNvar);
979    hSupp(hstc, hNstc, hvar, &hNvar);
980    if ((hNvar == (r->N)) && (hNstc >= (r->N)))
981    {
982      if ((hNvar > 2) && (hNstc > 10))
983        hOrdSupp(hstc, hNstc, hvar, hNvar);
984      memset(hpur0, 0, ((r->N) + 1) * sizeof(int));
985      hPure(hstc, 0, &hNstc, hvar, hNvar, hpur0, &hNpure);
986      if (hNpure == hNvar)
987      {
988        hLexS(hstc, hNstc, hvar, hNvar);
989        hMu += hZeroMult(hpur0, hstc, hNstc, hvar, hNvar);
990      }
991      else
992        hMu = -1;
993    }
994    else if (hNvar)
995      hMu = -1;
996    mc--;
997    if (mc <= 0 || hMu < 0)
998      break;
999  }
1000  hKill(stcmem, (r->N) - 1);
1001  omFreeSize((ADDRESS)hpur0, (1 + ((r->N) * (r->N))) * sizeof(int));
1002  omFreeSize((ADDRESS)hvar, ((r->N) + 1) * sizeof(int));
1003  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1004  hDelete(hexist, hNexist);
1005  if (hisModule)
1006    omFreeSize((ADDRESS)hstc, hNexist * sizeof(scmon));
1007  return hMu;
1008}
1009
1010// HC
1011
1012STATIC_VAR poly pWork;
1013
1014static void hHedge(poly hEdge)
1015{
1016  pSetm(pWork);
1017  if (pLmCmp(pWork, hEdge) == currRing->OrdSgn)
1018  {
1019    for (int i = hNvar; i>0; i--)
1020      pSetExp(hEdge,i, pGetExp(pWork,i));
1021    pSetm(hEdge);
1022  }
1023}
1024
1025
1026static void hHedgeStep(scmon pure, scfmon stc,
1027                       int Nstc, varset var, int Nvar,poly hEdge)
1028{
1029  int  iv = Nvar -1, k = var[Nvar], a, a0, a1, b, i;
1030  int  x/*, x0*/;
1031  scmon pn;
1032  scfmon sn;
1033  if (iv==0)
1034  {
1035    pSetExp(pWork, k, pure[k]);
1036    hHedge(hEdge);
1037    return;
1038  }
1039  else if (Nstc==0)
1040  {
1041    for (i = Nvar; i>0; i--)
1042      pSetExp(pWork, var[i], pure[var[i]]);
1043    hHedge(hEdge);
1044    return;
1045  }
1046  x = a = 0;
1047  pn = hGetpure(pure);
1048  sn = hGetmem(Nstc, stc, stcmem[iv]);
1049  hStepS(sn, Nstc, var, Nvar, &a, &x);
1050  if (a == Nstc)
1051  {
1052    pSetExp(pWork, k, pure[k]);
1053    hHedgeStep(pn, sn, a, var, iv,hEdge);
1054    return;
1055  }
1056  else
1057  {
1058    pSetExp(pWork, k, x);
1059    hHedgeStep(pn, sn, a, var, iv,hEdge);
1060  }
1061  b = a;
1062  loop
1063  {
1064    a0 = a;
1065    // x0 = x;
1066    hStepS(sn, Nstc, var, Nvar, &a, &x);
1067    hElimS(sn, &b, a0, a, var, iv);
1068    a1 = a;
1069    hPure(sn, a0, &a1, var, iv, pn, &i);
1070    hLex2S(sn, b, a0, a1, var, iv, hwork);
1071    b += (a1 - a0);
1072    if (a < Nstc)
1073    {
1074      pSetExp(pWork, k, x);
1075      hHedgeStep(pn, sn, b, var, iv,hEdge);
1076    }
1077    else
1078    {
1079      pSetExp(pWork, k, pure[k]);
1080      hHedgeStep(pn, sn, b, var, iv,hEdge);
1081      return;
1082    }
1083  }
1084}
1085
1086void scComputeHC(ideal S, ideal Q, int ak, poly &hEdge)
1087{
1088  id_LmTest(S, currRing);
1089  if (Q!=NULL) id_LmTest(Q, currRing);
1090
1091  int  i;
1092  int  k = ak;
1093  #ifdef HAVE_RINGS
1094  if (rField_is_Ring(currRing) && (currRing->OrdSgn == -1))
1095  {
1096    //consider just monic generators (over rings with zero-divisors)
1097    ideal SS=id_Head(S,currRing);
1098    for(i=0;i<=idElem(S);i++)
1099    {
1100      if((SS->m[i]!=NULL)
1101      && ((p_IsPurePower(SS->m[i],currRing)==0)
1102        ||(!n_IsUnit(pGetCoeff(SS->m[i]), currRing->cf))))
1103      {
1104        p_Delete(&SS->m[i],currRing);
1105      }
1106    }
1107    S=id_Copy(SS,currRing);
1108    idSkipZeroes(S);
1109  }
1110  #if 0
1111  printf("\nThis is HC:\n");
1112  for(int ii=0;ii<=idElem(S);ii++)
1113  {
1114    pWrite(S->m[ii]);
1115  }
1116  //getchar();
1117  #endif
1118  #endif
1119  if(idElem(S) == 0)
1120    return;
1121  hNvar = (currRing->N);
1122  hexist = hInit(S, Q, &hNexist);
1123  if (k!=0)
1124    hComp(hexist, hNexist, k, hexist, &hNstc);
1125  else
1126    hNstc = hNexist;
1127  assume(hNexist > 0);
1128  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
1129  hvar = (varset)omAlloc((hNvar + 1) * sizeof(int));
1130  hpure = (scmon)omAlloc((1 + (hNvar * hNvar)) * sizeof(int));
1131  stcmem = hCreate(hNvar - 1);
1132  for (i = hNvar; i>0; i--)
1133    hvar[i] = i;
1134  hStaircase(hexist, &hNstc, hvar, hNvar);
1135  if ((hNvar > 2) && (hNstc > 10))
1136    hOrdSupp(hexist, hNstc, hvar, hNvar);
1137  memset(hpure, 0, (hNvar + 1) * sizeof(int));
1138  hPure(hexist, 0, &hNstc, hvar, hNvar, hpure, &hNpure);
1139  hLexS(hexist, hNstc, hvar, hNvar);
1140  if (hEdge!=NULL)
1141    pLmFree(hEdge);
1142  hEdge = pInit();
1143  pWork = pInit();
1144  hHedgeStep(hpure, hexist, hNstc, hvar, hNvar,hEdge);
1145  pSetComp(hEdge,ak);
1146  hKill(stcmem, hNvar - 1);
1147  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1148  omFreeSize((ADDRESS)hvar, (hNvar + 1) * sizeof(int));
1149  omFreeSize((ADDRESS)hpure, (1 + (hNvar * hNvar)) * sizeof(int));
1150  hDelete(hexist, hNexist);
1151  pLmFree(pWork);
1152}
1153
1154
1155
1156//  kbase
1157
1158STATIC_VAR poly last;
1159STATIC_VAR scmon act;
1160
1161static void scElKbase()
1162{
1163  poly q = pInit();
1164  pSetCoeff0(q,nInit(1));
1165  pSetExpV(q,act);
1166  pNext(q) = NULL;
1167  last = pNext(last) = q;
1168}
1169
1170static int scMax( int i, scfmon stc, int Nvar)
1171{
1172  int x, y=stc[0][Nvar];
1173  for (; i;)
1174  {
1175    i--;
1176    x = stc[i][Nvar];
1177    if (x > y) y = x;
1178  }
1179  return y;
1180}
1181
1182static int scMin( int i, scfmon stc, int Nvar)
1183{
1184  int x, y=stc[0][Nvar];
1185  for (; i;)
1186  {
1187    i--;
1188    x = stc[i][Nvar];
1189    if (x < y) y = x;
1190  }
1191  return y;
1192}
1193
1194static int scRestrict( int &Nstc, scfmon stc, int Nvar)
1195{
1196  int x, y;
1197  int i, j, Istc = Nstc;
1198
1199  y = MAX_INT_VAL;
1200  for (i=Nstc-1; i>=0; i--)
1201  {
1202    j = Nvar-1;
1203    loop
1204    {
1205      if(stc[i][j] != 0) break;
1206      j--;
1207      if (j == 0)
1208      {
1209        Istc--;
1210        x = stc[i][Nvar];
1211        if (x < y) y = x;
1212        stc[i] = NULL;
1213        break;
1214      }
1215    }
1216  }
1217  if (Istc < Nstc)
1218  {
1219    for (i=Nstc-1; i>=0; i--)
1220    {
1221      if (stc[i] && (stc[i][Nvar] >= y))
1222      {
1223        Istc--;
1224        stc[i] = NULL;
1225      }
1226    }
1227    j = 0;
1228    while (stc[j]) j++;
1229    i = j+1;
1230    for(; i<Nstc; i++)
1231    {
1232      if (stc[i])
1233      {
1234        stc[j] = stc[i];
1235        j++;
1236      }
1237    }
1238    Nstc = Istc;
1239    return y;
1240  }
1241  else
1242    return -1;
1243}
1244
1245static void scAll( int Nvar, int deg)
1246{
1247  int i;
1248  int d = deg;
1249  if (d == 0)
1250  {
1251    for (i=Nvar; i; i--) act[i] = 0;
1252    scElKbase();
1253    return;
1254  }
1255  if (Nvar == 1)
1256  {
1257    act[1] = d;
1258    scElKbase();
1259    return;
1260  }
1261  do
1262  {
1263    act[Nvar] = d;
1264    scAll(Nvar-1, deg-d);
1265    d--;
1266  } while (d >= 0);
1267}
1268
1269static void scAllKbase( int Nvar, int ideg, int deg)
1270{
1271  do
1272  {
1273    act[Nvar] = ideg;
1274    scAll(Nvar-1, deg-ideg);
1275    ideg--;
1276  } while (ideg >= 0);
1277}
1278
1279static void scDegKbase( scfmon stc, int Nstc, int Nvar, int deg)
1280{
1281  int  Ivar, Istc, i, j;
1282  scfmon sn;
1283  int x, ideg;
1284
1285  if (deg == 0)
1286  {
1287    for (i=Nstc-1; i>=0; i--)
1288    {
1289      for (j=Nvar;j;j--){ if(stc[i][j]) break; }
1290      if (j==0){return;}
1291    }
1292    for (i=Nvar; i; i--) act[i] = 0;
1293    scElKbase();
1294    return;
1295  }
1296  if (Nvar == 1)
1297  {
1298    for (i=Nstc-1; i>=0; i--) if(deg >= stc[i][1]) return;
1299    act[1] = deg;
1300    scElKbase();
1301    return;
1302  }
1303  Ivar = Nvar-1;
1304  sn = hGetmem(Nstc, stc, stcmem[Ivar]);
1305  x = scRestrict(Nstc, sn, Nvar);
1306  if (x <= 0)
1307  {
1308    if (x == 0) return;
1309    ideg = deg;
1310  }
1311  else
1312  {
1313    if (deg < x) ideg = deg;
1314    else ideg = x-1;
1315    if (Nstc == 0)
1316    {
1317      scAllKbase(Nvar, ideg, deg);
1318      return;
1319    }
1320  }
1321  loop
1322  {
1323    x = scMax(Nstc, sn, Nvar);
1324    while (ideg >= x)
1325    {
1326      act[Nvar] = ideg;
1327      scDegKbase(sn, Nstc, Ivar, deg-ideg);
1328      ideg--;
1329    }
1330    if (ideg < 0) return;
1331    Istc = Nstc;
1332    for (i=Nstc-1; i>=0; i--)
1333    {
1334      if (ideg < sn[i][Nvar])
1335      {
1336        Istc--;
1337        sn[i] = NULL;
1338      }
1339    }
1340    if (Istc == 0)
1341    {
1342      scAllKbase(Nvar, ideg, deg);
1343      return;
1344    }
1345    j = 0;
1346    while (sn[j]) j++;
1347    i = j+1;
1348    for (; i<Nstc; i++)
1349    {
1350      if (sn[i])
1351      {
1352        sn[j] = sn[i];
1353        j++;
1354      }
1355    }
1356    Nstc = Istc;
1357  }
1358}
1359
1360static void scInKbase( scfmon stc, int Nstc, int Nvar)
1361{
1362  int  Ivar, Istc, i, j;
1363  scfmon sn;
1364  int x, ideg;
1365
1366  if (Nvar == 1)
1367  {
1368    ideg = scMin(Nstc, stc, 1);
1369    while (ideg > 0)
1370    {
1371      ideg--;
1372      act[1] = ideg;
1373      scElKbase();
1374    }
1375    return;
1376  }
1377  Ivar = Nvar-1;
1378  sn = hGetmem(Nstc, stc, stcmem[Ivar]);
1379  x = scRestrict(Nstc, sn, Nvar);
1380  if (x == 0) return;
1381  ideg = x-1;
1382  loop
1383  {
1384    x = scMax(Nstc, sn, Nvar);
1385    while (ideg >= x)
1386    {
1387      act[Nvar] = ideg;
1388      scInKbase(sn, Nstc, Ivar);
1389      ideg--;
1390    }
1391    if (ideg < 0) return;
1392    Istc = Nstc;
1393    for (i=Nstc-1; i>=0; i--)
1394    {
1395      if (ideg < sn[i][Nvar])
1396      {
1397        Istc--;
1398        sn[i] = NULL;
1399      }
1400    }
1401    j = 0;
1402    while (sn[j]) j++;
1403    i = j+1;
1404    for (; i<Nstc; i++)
1405    {
1406      if (sn[i])
1407      {
1408        sn[j] = sn[i];
1409        j++;
1410      }
1411    }
1412    Nstc = Istc;
1413  }
1414}
1415
1416static ideal scIdKbase(poly q, const int rank)
1417{
1418  ideal res = idInit(pLength(q), rank);
1419  polyset mm = res->m;
1420  do
1421  {
1422    *mm = q; ++mm;
1423
1424    const poly p = pNext(q);
1425    pNext(q) = NULL;
1426    q = p;
1427
1428  } while (q!=NULL);
1429
1430  id_Test(res, currRing);   // WRONG RANK!!!???
1431  return res;
1432}
1433
1434ideal scKBase(int deg, ideal s, ideal Q, intvec * mv)
1435{
1436  if( Q!=NULL) id_Test(Q, currRing);
1437
1438  int  i, di;
1439  poly p;
1440
1441  if (deg < 0)
1442  {
1443    di = scDimInt(s, Q);
1444    if (di != 0)
1445    {
1446      //Werror("KBase not finite");
1447      return idInit(1,s->rank);
1448    }
1449  }
1450  stcmem = hCreate((currRing->N) - 1);
1451  hexist = hInit(s, Q, &hNexist);
1452  p = last = pInit();
1453  /*pNext(p) = NULL;*/
1454  act = (scmon)omAlloc(((currRing->N) + 1) * sizeof(int));
1455  *act = 0;
1456  if (!hNexist)
1457  {
1458    scAll((currRing->N), deg);
1459    goto ende;
1460  }
1461  if (!hisModule)
1462  {
1463    if (deg < 0) scInKbase(hexist, hNexist, (currRing->N));
1464    else scDegKbase(hexist, hNexist, (currRing->N), deg);
1465  }
1466  else
1467  {
1468    hstc = (scfmon)omAlloc(hNexist * sizeof(scmon));
1469    for (i = 1; i <= hisModule; i++)
1470    {
1471      *act = i;
1472      hComp(hexist, hNexist, i, hstc, &hNstc);
1473      int deg_ei=deg;
1474      if (mv!=NULL) deg_ei -= (*mv)[i-1];
1475      if ((deg < 0) || (deg_ei>=0))
1476      {
1477        if (hNstc)
1478        {
1479          if (deg < 0) scInKbase(hstc, hNstc, (currRing->N));
1480          else scDegKbase(hstc, hNstc, (currRing->N), deg_ei);
1481        }
1482        else
1483          scAll((currRing->N), deg_ei);
1484      }
1485    }
1486    omFreeSize((ADDRESS)hstc, hNexist * sizeof(scmon));
1487  }
1488ende:
1489  hDelete(hexist, hNexist);
1490  omFreeSize((ADDRESS)act, ((currRing->N) + 1) * sizeof(int));
1491  hKill(stcmem, (currRing->N) - 1);
1492  pLmFree(&p);
1493  if (p == NULL)
1494    return idInit(1,s->rank);
1495
1496  last = p;
1497  return scIdKbase(p, s->rank);
1498}
1499
1500#if 0 //-- alternative implementation of scComputeHC
1501/*
1502void scComputeHCw(ideal ss, ideal Q, int ak, poly &hEdge)
1503{
1504  id_LmTest(ss, currRing);
1505  if (Q!=NULL) id_LmTest(Q, currRing);
1506
1507  int  i, di;
1508  poly p;
1509
1510  if (hEdge!=NULL)
1511    pLmFree(hEdge);
1512
1513  ideal s=idInit(IDELEMS(ss),ak);
1514  for(i=IDELEMS(ss)-1;i>=0;i--)
1515  {
1516    if (ss->m[i]!=NULL) s->m[i]=pHead(ss->m[i]);
1517  }
1518  di = scDimInt(s, Q);
1519  stcmem = hCreate((currRing->N) - 1);
1520  hexist = hInit(s, Q, &hNexist);
1521  p = last = pInit();
1522  // pNext(p) = NULL;
1523  act = (scmon)omAlloc(((currRing->N) + 1) * sizeof(int));
1524  *act = 0;
1525  if (!hNexist)
1526  {
1527    scAll((currRing->N), -1);
1528    goto ende;
1529  }
1530  if (!hisModule)
1531  {
1532    scInKbase(hexist, hNexist, (currRing->N));
1533  }
1534  else
1535  {
1536    hstc = (scfmon)omAlloc(hNexist * sizeof(scmon));
1537    for (i = 1; i <= hisModule; i++)
1538    {
1539      *act = i;
1540      hComp(hexist, hNexist, i, hstc, &hNstc);
1541      if (hNstc)
1542      {
1543        scInKbase(hstc, hNstc, (currRing->N));
1544      }
1545      else
1546        scAll((currRing->N), -1);
1547    }
1548    omFreeSize((ADDRESS)hstc, hNexist * sizeof(scmon));
1549  }
1550ende:
1551  hDelete(hexist, hNexist);
1552  omFreeSize((ADDRESS)act, ((currRing->N) + 1) * sizeof(int));
1553  hKill(stcmem, (currRing->N) - 1);
1554  pDeleteLm(&p);
1555  idDelete(&s);
1556  if (p == NULL)
1557  {
1558    return; // no HEdge
1559  }
1560  else
1561  {
1562    last = p;
1563    ideal res=scIdKbase(p, ss->rank);
1564    poly p_ind=res->m[0]; int ind=0;
1565    for(i=IDELEMS(res)-1;i>0;i--)
1566    {
1567      if (pCmp(res->m[i],p_ind)==-1) { p_ind=res->m[i]; ind=i; }
1568    }
1569    assume(p_ind!=NULL);
1570    assume(res->m[ind]==p_ind);
1571    hEdge=p_ind;
1572    res->m[ind]=NULL;
1573    nDelete(&pGetCoeff(hEdge));
1574    pGetCoeff(hEdge)=NULL;
1575    for(i=(currRing->N);i>0;i--)
1576      pIncrExp(hEdge,i);
1577    pSetm(hEdge);
1578
1579    idDelete(&res);
1580    return;
1581  }
1582}
1583 */
1584#endif
1585
1586#ifdef HAVE_SHIFTBBA
1587
1588/*
1589 * Computation of the Gel'fand-Kirillov Dimension
1590 */
1591
1592#include "polys/shiftop.h"
1593#include <vector>
1594
1595static std::vector<int> countCycles(const intvec* _G, int v, std::vector<int> path, std::vector<BOOLEAN> visited, std::vector<BOOLEAN> cyclic, std::vector<int> cache)
1596{
1597  intvec* G = ivCopy(_G); // modifications must be local
1598
1599  if (cache[v] != -2) return cache; // value is already cached
1600
1601  visited[v] = TRUE;
1602  path.push_back(v);
1603
1604  int cycles = 0;
1605  for (int w = 0; w < G->cols(); w++)
1606  {
1607    if (IMATELEM(*G, v + 1, w + 1)) // edge v -> w exists in G
1608    {
1609      if (!visited[w])
1610      { // continue with w
1611        cache = countCycles(G, w, path, visited, cyclic, cache);
1612        if (cache[w] == -1)
1613        {
1614          cache[v] = -1;
1615          return cache;
1616        }
1617        cycles = si_max(cycles, cache[w]);
1618      }
1619      else
1620      { // found new cycle
1621        int pathIndexOfW = -1;
1622        for (int i = path.size() - 1; i >= 0; i--) {
1623          if (cyclic[path[i]] == 1) { // found an already cyclic vertex
1624            cache[v] = -1;
1625            return cache;
1626          }
1627          cyclic[path[i]] = TRUE;
1628
1629          if (path[i] == w) { // end of the cycle
1630            assume(IMATELEM(*G, v + 1, w + 1) != 0);
1631            IMATELEM(*G, v + 1, w + 1) = 0; // remove edge v -> w
1632            pathIndexOfW = i;
1633            break;
1634          } else {
1635            assume(IMATELEM(*G, path[i - 1] + 1, path[i] + 1) != 0);
1636            IMATELEM(*G, path[i - 1] + 1, path[i] + 1) = 0; // remove edge vi-1 -> vi
1637          }
1638        }
1639        assume(pathIndexOfW != -1); // should never happen
1640        for (int i = path.size() - 1; i >= pathIndexOfW; i--) {
1641          cache = countCycles(G, path[i], path, visited, cyclic, cache);
1642          if (cache[path[i]] == -1)
1643          {
1644            cache[v] = -1;
1645            return cache;
1646          }
1647          cycles = si_max(cycles, cache[path[i]] + 1);
1648        }
1649      }
1650    }
1651  }
1652  cache[v] = cycles;
1653
1654  delete G;
1655  return cache;
1656}
1657
1658// -1 is infinity
1659static int graphGrowth(const intvec* G)
1660{
1661  // init
1662  int n = G->cols();
1663  std::vector<int> path;
1664  std::vector<BOOLEAN> visited;
1665  std::vector<BOOLEAN> cyclic;
1666  std::vector<int> cache;
1667  visited.resize(n, FALSE);
1668  cyclic.resize(n, FALSE);
1669  cache.resize(n, -2);
1670
1671  // get max number of cycles
1672  int cycles = 0;
1673  for (int v = 0; v < n; v++)
1674  {
1675    cache = countCycles(G, v, path, visited, cyclic, cache);
1676    if (cache[v] == -1)
1677      return -1;
1678    cycles = si_max(cycles, cache[v]);
1679  }
1680  return cycles;
1681}
1682
1683// ATTENTION:
1684//  - `words` contains the words normal modulo M of length n
1685//  - `numberOfNormalWords` contains the number of words normal modulo M of length 0 ... n
1686static void _lp_computeNormalWords(ideal words, int& numberOfNormalWords, int length, ideal M, int minDeg, int& last)
1687{
1688  if (length <= 0){
1689    poly one = pOne();
1690    if (p_LPDivisibleBy(M, one, currRing)) // 1 \in M => no normal words at all
1691    {
1692      pDelete(&one);
1693      last = -1;
1694      numberOfNormalWords = 0;
1695    }
1696    else
1697    {
1698      words->m[0] = one;
1699      last = 0;
1700      numberOfNormalWords = 1;
1701    }
1702    return;
1703  }
1704
1705  _lp_computeNormalWords(words, numberOfNormalWords, length - 1, M, minDeg, last);
1706
1707  int nVars = currRing->isLPring - currRing->LPncGenCount;
1708  int numberOfNewNormalWords = 0;
1709
1710  for (int j = nVars - 1; j >= 0; j--)
1711  {
1712    for (int i = last; i >= 0; i--)
1713    {
1714      int index = (j * (last + 1)) + i;
1715
1716      if (words->m[i] != NULL)
1717      {
1718        if (j > 0) {
1719          words->m[index] = pCopy(words->m[i]);
1720        }
1721
1722        int varOffset = ((length - 1) * currRing->isLPring) + 1;
1723        pSetExp(words->m[index], varOffset + j, 1);
1724        pSetm(words->m[index]);
1725        pTest(words->m[index]);
1726
1727        if (length >= minDeg && p_LPDivisibleBy(M, words->m[index], currRing))
1728        {
1729          pDelete(&words->m[index]);
1730          words->m[index] = NULL;
1731        }
1732        else
1733        {
1734          numberOfNewNormalWords++;
1735        }
1736      }
1737    }
1738  }
1739
1740  last = nVars * last + nVars - 1;
1741
1742  numberOfNormalWords += numberOfNewNormalWords;
1743}
1744
1745static ideal lp_computeNormalWords(int length, ideal M)
1746{
1747  long minDeg = IDELEMS(M) > 0 ? pTotaldegree(M->m[0]) : 0;
1748  for (int i = 1; i < IDELEMS(M); i++)
1749  {
1750    minDeg = si_min(minDeg, pTotaldegree(M->m[i]));
1751  }
1752
1753  int nVars = currRing->isLPring - currRing->LPncGenCount;
1754
1755  int maxElems = 1;
1756  for (int i = 0; i < length; i++) // maxElems = nVars^n
1757    maxElems *= nVars;
1758  ideal words = idInit(maxElems);
1759  int last, numberOfNormalWords;
1760  _lp_computeNormalWords(words, numberOfNormalWords, length, M, minDeg, last);
1761  idSkipZeroes(words);
1762  return words;
1763}
1764
1765static int lp_countNormalWords(int upToLength, ideal M)
1766{
1767  long minDeg = IDELEMS(M) > 0 ? pTotaldegree(M->m[0]) : 0;
1768  for (int i = 1; i < IDELEMS(M); i++)
1769  {
1770    minDeg = si_min(minDeg, pTotaldegree(M->m[i]));
1771  }
1772
1773  int nVars = currRing->isLPring - currRing->LPncGenCount;
1774
1775  int maxElems = 1;
1776  for (int i = 0; i < upToLength; i++) // maxElems = nVars^n
1777    maxElems *= nVars;
1778  ideal words = idInit(maxElems);
1779  int last, numberOfNormalWords;
1780  _lp_computeNormalWords(words, numberOfNormalWords, upToLength, M, minDeg, last);
1781  idDelete(&words);
1782  return numberOfNormalWords;
1783}
1784
1785// NULL if graph is undefined
1786intvec* lp_ufnarovskiGraph(ideal G, ideal &standardWords)
1787{
1788  long l = 0;
1789  for (int i = 0; i < IDELEMS(G); i++)
1790    l = si_max(pTotaldegree(G->m[i]), l);
1791  l--;
1792  if (l <= 0)
1793  {
1794    WerrorS("Ufnarovski graph not implemented for l <= 0");
1795    return NULL;
1796  }
1797  int lV = currRing->isLPring;
1798
1799  standardWords = lp_computeNormalWords(l, G);
1800
1801  int n = IDELEMS(standardWords);
1802  intvec* UG = new intvec(n, n, 0);
1803  for (int i = 0; i < n; i++)
1804  {
1805    for (int j = 0; j < n; j++)
1806    {
1807      poly v = standardWords->m[i];
1808      poly w = standardWords->m[j];
1809
1810      // check whether v*x1 = x2*w (overlap)
1811      bool overlap = true;
1812      for (int k = 1; k <= (l - 1) * lV; k++)
1813      {
1814        if (pGetExp(v, k + lV) != pGetExp(w, k)) {
1815          overlap = false;
1816          break;
1817        }
1818      }
1819
1820      if (overlap)
1821      {
1822        // create the overlap
1823        poly p = pMult(pCopy(v), p_LPVarAt(w, l, currRing));
1824
1825        // check whether the overlap is normal
1826        bool normal = true;
1827        for (int k = 0; k < IDELEMS(G); k++)
1828        {
1829          if (p_LPDivisibleBy(G->m[k], p, currRing))
1830          {
1831            normal = false;
1832            break;
1833          }
1834        }
1835
1836        if (normal)
1837        {
1838          IMATELEM(*UG, i + 1, j + 1) = 1;
1839        }
1840      }
1841    }
1842  }
1843  return UG;
1844}
1845
1846// -1 is infinity, -2 is error
1847int lp_gkDim(const ideal _G)
1848{
1849  id_Test(_G, currRing);
1850
1851  if (rField_is_Ring(currRing)) {
1852      WerrorS("GK-Dim not implemented for rings");
1853      return -2;
1854  }
1855
1856  for (int i=IDELEMS(_G)-1;i>=0; i--)
1857  {
1858    if (_G->m[i] != NULL)
1859    {
1860      if (pGetComp(_G->m[i]) != 0)
1861      {
1862        WerrorS("GK-Dim not implemented for modules");
1863        return -2;
1864      }
1865      if (pGetNCGen(_G->m[i]) != 0)
1866      {
1867        WerrorS("GK-Dim not implemented for bi-modules");
1868        return -2;
1869      }
1870    }
1871  }
1872
1873  ideal G = id_Head(_G, currRing); // G = LM(G) (and copy)
1874  idSkipZeroes(G); // remove zeros
1875  id_DelLmEquals(G, currRing); // remove duplicates
1876
1877  // check if G is the zero ideal
1878  if (IDELEMS(G) == 1 && G->m[0] == NULL)
1879  {
1880    // NOTE: this is needed because if the ideal is <0>, then idSkipZeroes keeps this element, and IDELEMS is still 1!
1881    int lV = currRing->isLPring;
1882    int ncGenCount = currRing->LPncGenCount;
1883    if (lV - ncGenCount == 0)
1884    {
1885      idDelete(&G);
1886      return 0;
1887    }
1888    if (lV - ncGenCount == 1)
1889    {
1890      idDelete(&G);
1891      return 1;
1892    }
1893    if (lV - ncGenCount >= 2)
1894    {
1895      idDelete(&G);
1896      return -1;
1897    }
1898  }
1899
1900  // get the max deg
1901  long maxDeg = 0;
1902  for (int i = 0; i < IDELEMS(G); i++)
1903  {
1904    maxDeg = si_max(maxDeg, pTotaldegree(G->m[i]));
1905
1906    // also check whether G = <1>
1907    if (pIsConstantComp(G->m[i]))
1908    {
1909      WerrorS("GK-Dim not defined for 0-ring");
1910      idDelete(&G);
1911      return -2;
1912    }
1913  }
1914
1915  // early termination if G \subset X
1916  if (maxDeg <= 1)
1917  {
1918    int lV = currRing->isLPring;
1919    int ncGenCount = currRing->LPncGenCount;
1920    if (IDELEMS(G) == lV - ncGenCount) // V = {1} no edges
1921    {
1922      idDelete(&G);
1923      return 0;
1924    }
1925    if (IDELEMS(G) == lV - ncGenCount - 1) // V = {1} with loop
1926    {
1927      idDelete(&G);
1928      return 1;
1929    }
1930    if (IDELEMS(G) <= lV - ncGenCount - 2) // V = {1} with more than one loop
1931    {
1932      idDelete(&G);
1933      return -1;
1934    }
1935  }
1936
1937  ideal standardWords;
1938  intvec* UG = lp_ufnarovskiGraph(G, standardWords);
1939  if (UG == NULL)
1940  {
1941    idDelete(&G);
1942    return -2;
1943  }
1944  if (errorreported)
1945  {
1946    delete UG;
1947    idDelete(&G);
1948    return -2;
1949  }
1950  int gkDim = graphGrowth(UG);
1951  delete UG;
1952  idDelete(&G);
1953  return gkDim;
1954}
1955
1956// converts an intvec matrix to a vector<vector<int> >
1957static std::vector<std::vector<int> > iv2vv(intvec* M)
1958{
1959  int rows = M->rows();
1960  int cols = M->cols();
1961
1962  std::vector<std::vector<int> > mat(rows, std::vector<int>(cols));
1963
1964  for (int i = 0; i < rows; i++)
1965  {
1966    for (int j = 0; j < cols; j++)
1967    {
1968      mat[i][j] = IMATELEM(*M, i + 1, j + 1);
1969    }
1970  }
1971
1972  return mat;
1973}
1974
1975static void vvPrint(const std::vector<std::vector<int> >& mat)
1976{
1977  for (int i = 0; i < mat.size(); i++)
1978  {
1979    for (int j = 0; j < mat[i].size(); j++)
1980    {
1981      Print("%d ", mat[i][j]);
1982    }
1983    PrintLn();
1984  }
1985}
1986
1987static void vvTest(const std::vector<std::vector<int> >& mat)
1988{
1989  if (mat.size() > 0)
1990  {
1991    int cols = mat[0].size();
1992    for (int i = 1; i < mat.size(); i++)
1993    {
1994      if (cols != mat[i].size())
1995        WerrorS("number of cols in matrix inconsistent");
1996    }
1997  }
1998}
1999
2000static void vvDeleteRow(std::vector<std::vector<int> >& mat, int row)
2001{
2002  mat.erase(mat.begin() + row);
2003}
2004
2005static void vvDeleteColumn(std::vector<std::vector<int> >& mat, int col)
2006{
2007  for (int i = 0; i < mat.size(); i++)
2008  {
2009    mat[i].erase(mat[i].begin() + col);
2010  }
2011}
2012
2013static BOOLEAN vvIsRowZero(const std::vector<std::vector<int> >& mat, int row)
2014{
2015  for (int i = 0; i < mat[row].size(); i++)
2016  {
2017    if (mat[row][i] != 0)
2018      return FALSE;
2019  }
2020  return TRUE;
2021}
2022
2023static BOOLEAN vvIsColumnZero(const std::vector<std::vector<int> >& mat, int col)
2024{
2025  for (int i = 0; i < mat.size(); i++)
2026  {
2027    if (mat[i][col] != 0)
2028      return FALSE;
2029  }
2030  return TRUE;
2031}
2032
2033static BOOLEAN vvIsZero(const std::vector<std::vector<int> >& mat)
2034{
2035  for (int i = 0; i < mat.size(); i++)
2036  {
2037    if (!vvIsRowZero(mat, i))
2038      return FALSE;
2039  }
2040  return TRUE;
2041}
2042
2043static std::vector<std::vector<int> > vvMult(const std::vector<std::vector<int> >& a, const std::vector<std::vector<int> >& b)
2044{
2045  int ra = a.size();
2046  int rb = b.size();
2047  int ca = a.size() > 0 ? a[0].size() : 0;
2048  int cb = b.size() > 0 ? b[0].size() : 0;
2049
2050  if (ca != rb)
2051  {
2052    WerrorS("matrix dimensions do not match");
2053    return std::vector<std::vector<int> >();
2054  }
2055
2056  std::vector<std::vector<int> > res(ra, std::vector<int>(cb));
2057  for (int i = 0; i < ra; i++)
2058  {
2059    for (int j = 0; j < cb; j++)
2060    {
2061      int sum = 0;
2062      for (int k = 0; k < ca; k++)
2063        sum += a[i][k] * b[k][j];
2064      res[i][j] = sum;
2065    }
2066  }
2067  return res;
2068}
2069
2070static BOOLEAN isAcyclic(const intvec* G)
2071{
2072  // init
2073  int n = G->cols();
2074  std::vector<int> path;
2075  std::vector<BOOLEAN> visited;
2076  std::vector<BOOLEAN> cyclic;
2077  std::vector<int> cache;
2078  visited.resize(n, FALSE);
2079  cyclic.resize(n, FALSE);
2080  cache.resize(n, -2);
2081
2082  for (int v = 0; v < n; v++)
2083  {
2084    cache = countCycles(G, v, path, visited, cyclic, cache);
2085    // check that there are 0 cycles from v
2086    if (cache[v] != 0)
2087      return FALSE;
2088  }
2089  return TRUE;
2090}
2091
2092/*
2093 * Computation of the K-Dimension
2094 */
2095
2096// -1 is infinity, -2 is error
2097int lp_kDim(const ideal _G)
2098{
2099  if (rField_is_Ring(currRing)) {
2100      WerrorS("K-Dim not implemented for rings");
2101      return -2;
2102  }
2103
2104  for (int i=IDELEMS(_G)-1;i>=0; i--)
2105  {
2106    if (_G->m[i] != NULL)
2107    {
2108      if (pGetComp(_G->m[i]) != 0)
2109      {
2110        WerrorS("K-Dim not implemented for modules");
2111        return -2;
2112      }
2113      if (pGetNCGen(_G->m[i]) != 0)
2114      {
2115        WerrorS("K-Dim not implemented for bi-modules");
2116        return -2;
2117      }
2118    }
2119  }
2120
2121  ideal G = id_Head(_G, currRing); // G = LM(G) (and copy)
2122  if (TEST_OPT_PROT)
2123    Print("%d original generators\n", IDELEMS(G));
2124  idSkipZeroes(G); // remove zeros
2125  id_DelLmEquals(G, currRing); // remove duplicates
2126  if (TEST_OPT_PROT)
2127    Print("%d non-zero unique generators\n", IDELEMS(G));
2128
2129  // check if G is the zero ideal
2130  if (IDELEMS(G) == 1 && G->m[0] == NULL)
2131  {
2132    // NOTE: this is needed because if the ideal is <0>, then idSkipZeroes keeps this element, and IDELEMS is still 1!
2133    int lV = currRing->isLPring;
2134    int ncGenCount = currRing->LPncGenCount;
2135    if (lV - ncGenCount == 0)
2136    {
2137      idDelete(&G);
2138      return 1;
2139    }
2140    if (lV - ncGenCount == 1)
2141    {
2142      idDelete(&G);
2143      return -1;
2144    }
2145    if (lV - ncGenCount >= 2)
2146    {
2147      idDelete(&G);
2148      return -1;
2149    }
2150  }
2151
2152  // get the max deg
2153  long maxDeg = 0;
2154  for (int i = 0; i < IDELEMS(G); i++)
2155  {
2156    maxDeg = si_max(maxDeg, pTotaldegree(G->m[i]));
2157
2158    // also check whether G = <1>
2159    if (pIsConstantComp(G->m[i]))
2160    {
2161      WerrorS("K-Dim not defined for 0-ring"); // TODO is it minus infinity ?
2162      idDelete(&G);
2163      return -2;
2164    }
2165  }
2166  if (TEST_OPT_PROT)
2167    Print("max deg: %ld\n", maxDeg);
2168
2169
2170  // for normal words of length minDeg ... maxDeg-1
2171  // brute-force the normal words
2172  if (TEST_OPT_PROT)
2173    PrintS("Computing normal words normally...\n");
2174  long numberOfNormalWords = lp_countNormalWords(maxDeg - 1, G);
2175
2176  if (TEST_OPT_PROT)
2177    Print("%ld normal words up to length %ld\n", numberOfNormalWords, maxDeg - 1);
2178
2179  // early termination if G \subset X
2180  if (maxDeg <= 1)
2181  {
2182    int lV = currRing->isLPring;
2183    int ncGenCount = currRing->LPncGenCount;
2184    if (IDELEMS(G) == lV - ncGenCount) // V = {1} no edges
2185    {
2186      idDelete(&G);
2187      return numberOfNormalWords;
2188    }
2189    if (IDELEMS(G) == lV - ncGenCount - 1) // V = {1} with loop
2190    {
2191      idDelete(&G);
2192      return -1;
2193    }
2194    if (IDELEMS(G) <= lV - ncGenCount - 2) // V = {1} with more than one loop
2195    {
2196      idDelete(&G);
2197      return -1;
2198    }
2199  }
2200
2201  if (TEST_OPT_PROT)
2202    PrintS("Computing Ufnarovski graph...\n");
2203
2204  ideal standardWords;
2205  intvec* UG = lp_ufnarovskiGraph(G, standardWords);
2206  if (UG == NULL)
2207  {
2208    idDelete(&G);
2209    return -2;
2210  }
2211  if (errorreported)
2212  {
2213    delete UG;
2214    idDelete(&G);
2215    return -2;
2216  }
2217
2218  if (TEST_OPT_PROT)
2219    Print("Ufnarovski graph is %dx%d.\n", UG->rows(), UG->cols());
2220
2221  if (TEST_OPT_PROT)
2222    PrintS("Checking whether Ufnarovski graph is acyclic...\n");
2223
2224  if (!isAcyclic(UG))
2225  {
2226    // in this case we have infinitely many normal words
2227    return -1;
2228  }
2229
2230  std::vector<std::vector<int> > vvUG = iv2vv(UG);
2231  for (int i = 0; i < vvUG.size(); i++)
2232  {
2233    if (vvIsRowZero(vvUG, i) && vvIsColumnZero(vvUG, i)) // i is isolated vertex
2234    {
2235      vvDeleteRow(vvUG, i);
2236      vvDeleteColumn(vvUG, i);
2237      i--;
2238    }
2239  }
2240  if (TEST_OPT_PROT)
2241    Print("Simplified Ufnarovski graph to %dx%d.\n", (int)vvUG.size(), (int)vvUG.size());
2242
2243  // for normal words of length >= maxDeg
2244  // use Ufnarovski graph
2245  if (TEST_OPT_PROT)
2246    PrintS("Computing normal words via Ufnarovski graph...\n");
2247  std::vector<std::vector<int> > UGpower = vvUG;
2248  long nUGpower = 1;
2249  while (!vvIsZero(UGpower))
2250  {
2251    if (TEST_OPT_PROT)
2252      PrintS("Start count graph entries.\n");
2253    for (int i = 0; i < UGpower.size(); i++)
2254    {
2255      for (int j = 0; j < UGpower[i].size(); j++)
2256      {
2257        numberOfNormalWords += UGpower[i][j];
2258      }
2259    }
2260
2261    if (TEST_OPT_PROT)
2262    {
2263      PrintS("Done count graph entries.\n");
2264      Print("%ld normal words up to length %ld\n", numberOfNormalWords, maxDeg - 1 + nUGpower);
2265    }
2266
2267    if (TEST_OPT_PROT)
2268      PrintS("Start mat mult.\n");
2269    UGpower = vvMult(UGpower, vvUG); // TODO: avoid creation of new intvec
2270    if (TEST_OPT_PROT)
2271      PrintS("Done mat mult.\n");
2272    nUGpower++;
2273  }
2274
2275  delete UG;
2276  idDelete(&G);
2277  return numberOfNormalWords;
2278}
2279#endif
Note: See TracBrowser for help on using the repository browser.