source: git/kernel/combinatorics/hdegree.cc @ 14fd84

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