source: git/kernel/ideals.cc @ a88046d

spielwiese
Last change on this file since a88046d was f12c611, checked in by Hans Schoenemann <hannes@…>, 13 years ago
tr 315: work-around for PLURAL git-svn-id: file:///usr/local/Singular/svn/trunk@13881 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 88.4 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id$ */
5/*
6* ABSTRACT - all basic methods to manipulate ideals
7*/
8
9/* includes */
10#include <kernel/mod2.h>
11
12#ifndef NDEBUG
13# define MYTEST 0
14#else /* ifndef NDEBUG */
15# define MYTEST 0
16#endif /* ifndef NDEBUG */
17
18#include <kernel/options.h>
19#include <omalloc/omalloc.h>
20#include <kernel/febase.h>
21#include <kernel/numbers.h>
22#include <kernel/longrat.h>
23#include <kernel/polys.h>
24#include <kernel/ring.h>
25#include <kernel/kstd1.h>
26#include <kernel/matpol.h>
27#include <kernel/weight.h>
28#include <kernel/intvec.h>
29#include <kernel/syz.h>
30#include <kernel/sparsmat.h>
31#include <kernel/ideals.h>
32#include <kernel/prCopy.h>
33#include <kernel/gring.h>
34
35
36omBin sip_sideal_bin = omGetSpecBin(sizeof(sip_sideal));
37
38/* #define WITH_OLD_MINOR */
39#define pCopy_noCheck(p) pCopy(p)
40
41static poly * idpower;
42/*collects the monomials in makemonoms, must be allocated befor*/
43static int idpowerpoint;
44/*index of the actual monomial in idpower*/
45static poly * givenideal;
46/*the ideal from which a power is computed*/
47
48/*0 implementation*/
49
50/*2
51* initialise an ideal
52*/
53#ifdef PDEBUG
54ideal idDBInit(int idsize, int rank, const char *f, int l)
55#else
56ideal idInit(int idsize, int rank)
57#endif
58{
59  /*- initialise an ideal -*/
60  ideal hh = (ideal )omAllocBin(sip_sideal_bin);
61  hh->nrows = 1;
62  hh->rank = rank;
63  IDELEMS(hh) = idsize;
64  if (idsize>0)
65  {
66    hh->m = (poly *)omAlloc0(idsize*sizeof(poly));
67  }
68  else
69    hh->m=NULL;
70  return hh;
71}
72
73#ifndef NDEBUG
74// this is only for outputting an ideal within the debugger
75void idShow(const ideal id, const ring lmRing, const ring tailRing, const int debugPrint)
76{
77  assume( debugPrint >= 0 );
78
79  if( id == NULL )
80    PrintS("(NULL)");
81  else
82  {
83    Print("Module of rank %ld,real rank %ld and %d generators.\n",
84          id->rank,idRankFreeModule(id, lmRing, tailRing),IDELEMS(id));
85
86    int j = (id->ncols*id->nrows) - 1;
87    while ((j > 0) && (id->m[j]==NULL)) j--;
88    for (int i = 0; i <= j; i++)
89    {
90      Print("generator %d: ",i); p_DebugPrint(id->m[i], lmRing, tailRing, debugPrint);
91    }
92  }
93}
94#endif
95
96/*2
97* initialise the maximal ideal (at 0)
98*/
99ideal idMaxIdeal (void)
100{
101  int l;
102  ideal hh=NULL;
103
104  hh=idInit(pVariables,1);
105  for (l=0; l<pVariables; l++)
106  {
107    hh->m[l] = pOne();
108    pSetExp(hh->m[l],l+1,1);
109    pSetm(hh->m[l]);
110  }
111  return hh;
112}
113
114/*2
115* deletes an ideal/matrix
116*/
117void id_Delete (ideal * h, ring r)
118{
119  int j,elems;
120  if (*h == NULL)
121    return;
122  elems=j=(*h)->nrows*(*h)->ncols;
123  if (j>0)
124  {
125    do
126    {
127      p_Delete(&((*h)->m[--j]), r);
128    }
129    while (j>0);
130    omFreeSize((ADDRESS)((*h)->m),sizeof(poly)*elems);
131  }
132  omFreeBin((ADDRESS)*h, sip_sideal_bin);
133  *h=NULL;
134}
135
136
137/*2
138* Shallowdeletes an ideal/matrix
139*/
140void id_ShallowDelete (ideal *h, ring r)
141{
142  int j,elems;
143  if (*h == NULL)
144    return;
145  elems=j=(*h)->nrows*(*h)->ncols;
146  if (j>0)
147  {
148    do
149    {
150      p_ShallowDelete(&((*h)->m[--j]), r);
151    }
152    while (j>0);
153    omFreeSize((ADDRESS)((*h)->m),sizeof(poly)*elems);
154  }
155  omFreeBin((ADDRESS)*h, sip_sideal_bin);
156  *h=NULL;
157}
158
159/*2
160*gives an ideal the minimal possible size
161*/
162void idSkipZeroes (ideal ide)
163{
164  int k;
165  int j = -1;
166  BOOLEAN change=FALSE;
167  for (k=0; k<IDELEMS(ide); k++)
168  {
169    if (ide->m[k] != NULL)
170    {
171      j++;
172      if (change)
173      {
174        ide->m[j] = ide->m[k];
175      }
176    }
177    else
178    {
179      change=TRUE;
180    }
181  }
182  if (change)
183  {
184    if (j == -1)
185      j = 0;
186    else
187    {
188      for (k=j+1; k<IDELEMS(ide); k++)
189        ide->m[k] = NULL;
190    }
191    pEnlargeSet(&(ide->m),IDELEMS(ide),j+1-IDELEMS(ide));
192    IDELEMS(ide) = j+1;
193  }
194}
195
196/*2
197* copies the first k (>= 1) entries of the given ideal
198* and returns these as a new ideal
199* (Note that the copied polynomials may be zero.)
200*/
201ideal idCopyFirstK (const ideal ide, const int k)
202{
203  ideal newI = idInit(k, 0);
204  for (int i = 0; i < k; i++)
205    newI->m[i] = pCopy(ide->m[i]);
206  return newI;
207}
208
209/*2
210* ideal id = (id[i])
211* result is leadcoeff(id[i]) = 1
212*/
213void idNorm(ideal id)
214{
215  for (int i=IDELEMS(id)-1; i>=0; i--)
216  {
217    if (id->m[i] != NULL)
218    {
219      pNorm(id->m[i]);
220    }
221  }
222}
223
224/*2
225* ideal id = (id[i]), c any number
226* if id[i] = c*id[j] then id[j] is deleted for j > i
227*/
228void idDelMultiples(ideal id)
229{
230  int i, j;
231  int k = IDELEMS(id)-1;
232  for (i=k; i>=0; i--)
233  {
234    if (id->m[i]!=NULL)
235    {
236      for (j=k; j>i; j--)
237      {
238        if ((id->m[j]!=NULL)
239        && (pComparePolys(id->m[i], id->m[j])))
240        {
241          pDelete(&id->m[j]);
242        }
243      }
244    }
245  }
246}
247
248/*2
249* ideal id = (id[i])
250* if id[i] = id[j] then id[j] is deleted for j > i
251*/
252void idDelEquals(ideal id)
253{
254  int i, j;
255  int k = IDELEMS(id)-1;
256  for (i=k; i>=0; i--)
257  {
258    if (id->m[i]!=NULL)
259    {
260      for (j=k; j>i; j--)
261      {
262        if ((id->m[j]!=NULL)
263        && (pEqualPolys(id->m[i], id->m[j])))
264        {
265          pDelete(&id->m[j]);
266        }
267      }
268    }
269  }
270}
271
272//
273// Delete id[j], if Lm(j) == Lm(i) and j > i
274//
275void idDelLmEquals(ideal id)
276{
277  int i, j;
278  int k = IDELEMS(id)-1;
279  for (i=k; i>=0; i--)
280  {
281    if (id->m[i] != NULL)
282    {
283      for (j=k; j>i; j--)
284      {
285        if ((id->m[j] != NULL)
286        && pLmEqual(id->m[i], id->m[j]))
287        {
288          pDelete(&id->m[j]);
289        }
290      }
291    }
292  }
293}
294
295void idDelDiv(ideal id)
296{
297  int i, j;
298  int k = IDELEMS(id)-1;
299  for (i=k; i>=0; i--)
300  {
301    if (id->m[i] != NULL)
302    {
303      for (j=k; j>i; j--)
304      {
305        if (id->m[j]!=NULL)
306        {
307          if(pDivisibleBy(id->m[i], id->m[j]))
308          {
309            pDelete(&id->m[j]);
310          }
311          else if(pDivisibleBy(id->m[j], id->m[i]))
312          {
313            pDelete(&id->m[i]);
314            break;
315          }
316        }
317      }
318    }
319  }
320}
321
322/*2
323*test if the ideal has only constant polynomials
324*/
325BOOLEAN idIsConstant(ideal id)
326{
327  int k;
328  for (k = IDELEMS(id)-1; k>=0; k--)
329  {
330    if (pIsConstantPoly(id->m[k]) == FALSE)
331      return FALSE;
332  }
333  return TRUE;
334}
335
336/*2
337* copy an ideal
338*/
339#ifdef PDEBUG
340ideal idDBCopy(ideal h1,const char *f,int l)
341{
342  int i;
343  ideal h2;
344
345  idDBTest(h1,PDEBUG,f,l);
346//#ifdef TEST
347  if (h1 == NULL)
348  {
349    h2=idDBInit(1,1,f,l);
350  }
351  else
352//#endif
353  {
354    h2=idDBInit(IDELEMS(h1),h1->rank,f,l);
355    for (i=IDELEMS(h1)-1; i>=0; i--)
356      h2->m[i] = pCopy(h1->m[i]);
357  }
358  return h2;
359}
360#endif
361
362ideal id_Copy (ideal h1, const ring r)
363{
364  int i;
365  ideal h2;
366
367//#ifdef TEST
368  if (h1 == NULL)
369  {
370    h2=idInit(1,1);
371  }
372  else
373//#endif
374  {
375    h2=idInit(IDELEMS(h1),h1->rank);
376    for (i=IDELEMS(h1)-1; i>=0; i--)
377      h2->m[i] = p_Copy(h1->m[i],r);
378  }
379  return h2;
380}
381
382#ifdef PDEBUG
383void idDBTest(ideal h1, int level, const char *f,const int l)
384{
385  int i;
386
387  if (h1 != NULL)
388  {
389    // assume(IDELEMS(h1) > 0); for ideal/module, does not apply to matrix
390    omCheckAddrSize(h1,sizeof(*h1));
391    omdebugAddrSize(h1->m,h1->ncols*h1->nrows*sizeof(poly));
392    /* to be able to test matrices: */
393    for (i=(h1->ncols*h1->nrows)-1; i>=0; i--)
394      _p_Test(h1->m[i], currRing, level);
395    int new_rk=idRankFreeModule(h1);
396    if(new_rk > h1->rank)
397    {
398      dReportError("wrong rank %d (should be %d) in %s:%d\n",
399                   h1->rank, new_rk, f,l);
400      omPrintAddrInfo(stderr, h1, " for ideal");
401      h1->rank=new_rk;
402    }
403  }
404}
405#endif
406
407/*3
408* for idSort: compare a and b revlex inclusive module comp.
409*/
410static int pComp_RevLex(poly a, poly b,BOOLEAN nolex)
411{
412  if (b==NULL) return 1;
413  if (a==NULL) return -1;
414
415  if (nolex) 
416  {
417    int r=pLmCmp(a,b);
418    if (r!=0) return r;
419    number h=nSub(pGetCoeff(a),pGetCoeff(b));
420    r = -1+nIsZero(h)+2*nGreaterZero(h); /* -1: <, 0:==, 1: > */
421    nDelete(&h);
422    return r;
423  }
424  int l=pVariables;
425  while ((l>0) && (pGetExp(a,l)==pGetExp(b,l))) l--;
426  if (l==0)
427  {
428    if (pGetComp(a)==pGetComp(b))
429    {
430      number h=nSub(pGetCoeff(a),pGetCoeff(b));
431      int r = -1+nIsZero(h)+2*nGreaterZero(h); /* -1: <, 0:==, 1: > */
432      nDelete(&h);
433      return r;
434    }
435    if (pGetComp(a)>pGetComp(b)) return 1;
436  }
437  else if (pGetExp(a,l)>pGetExp(b,l))
438    return 1;
439  return -1;
440}
441
442/*2
443*sorts the ideal w.r.t. the actual ringordering
444*uses lex-ordering when nolex = FALSE
445*/
446intvec *idSort(ideal id,BOOLEAN nolex)
447{
448  poly p,q;
449  intvec * result = new intvec(IDELEMS(id));
450  int i, j, actpos=0, newpos, l;
451  int diff, olddiff, lastcomp, newcomp;
452  BOOLEAN notFound;
453
454  for (i=0;i<IDELEMS(id);i++)
455  {
456    if (id->m[i]!=NULL)
457    {
458      notFound = TRUE;
459      newpos = actpos / 2;
460      diff = (actpos+1) / 2;
461      diff = (diff+1) / 2;
462      lastcomp = pComp_RevLex(id->m[i],id->m[(*result)[newpos]],nolex);
463      if (lastcomp<0)
464      {
465        newpos -= diff;
466      }
467      else if (lastcomp>0)
468      {
469        newpos += diff;
470      }
471      else
472      {
473        notFound = FALSE;
474      }
475      //while ((newpos>=0) && (newpos<actpos) && (notFound))
476      while (notFound && (newpos>=0) && (newpos<actpos))
477      {
478        newcomp = pComp_RevLex(id->m[i],id->m[(*result)[newpos]],nolex);
479        olddiff = diff;
480        if (diff>1)
481        {
482          diff = (diff+1) / 2;
483          if ((newcomp==1)
484          && (actpos-newpos>1)
485          && (diff>1)
486          && (newpos+diff>=actpos))
487          {
488            diff = actpos-newpos-1;
489          }
490          else if ((newcomp==-1)
491          && (diff>1)
492          && (newpos<diff))
493          {
494            diff = newpos;
495          }
496        }
497        if (newcomp<0)
498        {
499          if ((olddiff==1) && (lastcomp>0))
500            notFound = FALSE;
501          else
502            newpos -= diff;
503        }
504        else if (newcomp>0)
505        {
506          if ((olddiff==1) && (lastcomp<0))
507          {
508            notFound = FALSE;
509            newpos++;
510          }
511          else
512          {
513            newpos += diff;
514          }
515        }
516        else
517        {
518          notFound = FALSE;
519        }
520        lastcomp = newcomp;
521        if (diff==0) notFound=FALSE; /*hs*/
522      }
523      if (newpos<0) newpos = 0;
524      if (newpos>actpos) newpos = actpos;
525      while ((newpos<actpos) && (pComp_RevLex(id->m[i],id->m[(*result)[newpos]],nolex)==0))
526        newpos++;
527      for (j=actpos;j>newpos;j--)
528      {
529        (*result)[j] = (*result)[j-1];
530      }
531      (*result)[newpos] = i;
532      actpos++;
533    }
534  }
535  for (j=0;j<actpos;j++) (*result)[j]++;
536  return result;
537}
538
539/*2
540* concat the lists h1 and h2 without zeros
541*/
542ideal idSimpleAdd (ideal h1,ideal h2)
543{
544  int i,j,r,l;
545  ideal result;
546
547  if (h1==NULL) return idCopy(h2);
548  if (h2==NULL) return idCopy(h1);
549  j = IDELEMS(h1)-1;
550  while ((j >= 0) && (h1->m[j] == NULL)) j--;
551  i = IDELEMS(h2)-1;
552  while ((i >= 0) && (h2->m[i] == NULL)) i--;
553  r = si_max(h1->rank,h2->rank);
554  if (i+j==(-2))
555    return idInit(1,r);
556  else
557    result=idInit(i+j+2,r);
558  for (l=j; l>=0; l--)
559  {
560    result->m[l] = pCopy(h1->m[l]);
561  }
562  r = i+j+1;
563  for (l=i; l>=0; l--, r--)
564  {
565    result->m[r] = pCopy(h2->m[l]);
566  }
567  return result;
568}
569
570/*2
571* insert h2 into h1 (if h2 is not the zero polynomial)
572* return TRUE iff h2 was indeed inserted
573*/
574BOOLEAN idInsertPoly (ideal h1, poly h2)
575{
576  if (h2==NULL) return FALSE;
577  int j = IDELEMS(h1)-1;
578  while ((j >= 0) && (h1->m[j] == NULL)) j--;
579  j++;
580  if (j==IDELEMS(h1))
581  {
582    pEnlargeSet(&(h1->m),IDELEMS(h1),16);
583    IDELEMS(h1)+=16;
584  }
585  h1->m[j]=h2;
586  return TRUE;
587}
588
589/*2
590* insert h2 into h1 depending on the two boolean parameters:
591* - if zeroOk is true, then h2 will also be inserted when it is zero
592* - if duplicateOk is true, then h2 will also be inserted when it is
593*   already present in h1
594* return TRUE iff h2 was indeed inserted
595*/
596BOOLEAN idInsertPolyWithTests (ideal h1, const int validEntries,
597  const poly h2, const bool zeroOk, const bool duplicateOk)
598{
599  if ((!zeroOk) && (h2 == NULL)) return FALSE;
600  if (!duplicateOk)
601  {
602    bool h2FoundInH1 = false;
603    int i = 0;
604    while ((i < validEntries) && (!h2FoundInH1))
605    {
606      h2FoundInH1 = pEqualPolys(h1->m[i], h2);
607      i++;
608    }
609    if (h2FoundInH1) return FALSE;
610  }
611  if (validEntries == IDELEMS(h1))
612  {
613    pEnlargeSet(&(h1->m), IDELEMS(h1), 16);
614    IDELEMS(h1) += 16;
615  }
616  h1->m[validEntries] = h2;
617  return TRUE;
618}
619
620/*2
621* h1 + h2
622*/
623ideal idAdd (ideal h1,ideal h2)
624{
625  ideal result = idSimpleAdd(h1,h2);
626  idCompactify(result);
627  return result;
628}
629
630/*2
631* h1 * h2
632*/
633ideal  idMult (ideal h1,ideal  h2)
634{
635  int i,j,k;
636  ideal  hh;
637
638  j = IDELEMS(h1);
639  while ((j > 0) && (h1->m[j-1] == NULL)) j--;
640  i = IDELEMS(h2);
641  while ((i > 0) && (h2->m[i-1] == NULL)) i--;
642  j = j * i;
643  if (j == 0)
644    hh = idInit(1,1);
645  else
646    hh=idInit(j,1);
647  if (h1->rank<h2->rank)
648    hh->rank = h2->rank;
649  else
650    hh->rank = h1->rank;
651  if (j==0) return hh;
652  k = 0;
653  for (i=0; i<IDELEMS(h1); i++)
654  {
655    if (h1->m[i] != NULL)
656    {
657      for (j=0; j<IDELEMS(h2); j++)
658      {
659        if (h2->m[j] != NULL)
660        {
661          hh->m[k] = ppMult_qq(h1->m[i],h2->m[j]);
662          k++;
663        }
664      }
665    }
666  }
667  {
668    idCompactify(hh);
669    return hh;
670  }
671}
672
673/*2
674*returns true if h is the zero ideal
675*/
676BOOLEAN idIs0 (ideal h)
677{
678  int i;
679
680  if (h == NULL) return TRUE;
681  i = IDELEMS(h)-1;
682  while ((i >= 0) && (h->m[i] == NULL))
683  {
684    i--;
685  }
686  if (i < 0)
687    return TRUE;
688  else
689    return FALSE;
690}
691
692/*2
693* return the maximal component number found in any polynomial in s
694*/
695long idRankFreeModule (ideal s, ring lmRing, ring tailRing)
696{
697  if (s!=NULL)
698  {
699    int  j=0;
700
701    if (rRing_has_Comp(tailRing) && rRing_has_Comp(lmRing))
702    {
703      int  l=IDELEMS(s);
704      poly *p=s->m;
705      int  k;
706      for (; l != 0; l--)
707      {
708        if (*p!=NULL)
709        {
710          pp_Test(*p, lmRing, tailRing);
711          k = p_MaxComp(*p, lmRing, tailRing);
712          if (k>j) j = k;
713        }
714        p++;
715      }
716    }
717    return j;
718  }
719  return -1;
720}
721
722BOOLEAN idIsModule(ideal id, ring r)
723{
724  if (id != NULL && rRing_has_Comp(r))
725  {
726    int j, l = IDELEMS(id);
727    for (j=0; j<l; j++)
728    {
729      if (id->m[j] != NULL && p_GetComp(id->m[j], r) > 0) return TRUE;
730    }
731  }
732  return FALSE;
733}
734
735
736/*2
737*returns true if id is homogenous with respect to the aktual weights
738*/
739BOOLEAN idHomIdeal (ideal id, ideal Q)
740{
741  int i;
742  BOOLEAN     b;
743  if ((id == NULL) || (IDELEMS(id) == 0)) return TRUE;
744  i = 0;
745  b = TRUE;
746  while ((i < IDELEMS(id)) && b)
747  {
748    b = pIsHomogeneous(id->m[i]);
749    i++;
750  }
751  if ((b) && (Q!=NULL) && (IDELEMS(Q)>0))
752  {
753    i=0;
754    while ((i < IDELEMS(Q)) && b)
755    {
756      b = pIsHomogeneous(Q->m[i]);
757      i++;
758    }
759  }
760  return b;
761}
762
763/*2
764*returns a minimized set of generators of h1
765*/
766ideal idMinBase (ideal h1)
767{
768  ideal h2, h3,h4,e;
769  int j,k;
770  int i,l,ll;
771  intvec * wth;
772  BOOLEAN homog;
773
774  homog = idHomModule(h1,currQuotient,&wth);
775  if (rHasGlobalOrdering_currRing())
776  {
777    if(!homog)
778    {
779      WarnS("minbase applies only to the local or homogeneous case");
780      e=idCopy(h1);
781      return e;
782    }
783    else
784    {
785      ideal re=kMin_std(h1,currQuotient,(tHomog)homog,&wth,h2,NULL,0,3);
786      idDelete(&re);
787      return h2;
788    }
789  }
790  e=idInit(1,h1->rank);
791  if (idIs0(h1))
792  {
793    return e;
794  }
795  pEnlargeSet(&(e->m),IDELEMS(e),15);
796  IDELEMS(e) = 16;
797  h2 = kStd(h1,currQuotient,isNotHomog,NULL);
798  h3 = idMaxIdeal();
799  h4=idMult(h2,h3);
800  idDelete(&h3);
801  h3=kStd(h4,currQuotient,isNotHomog,NULL);
802  k = IDELEMS(h3);
803  while ((k > 0) && (h3->m[k-1] == NULL)) k--;
804  j = -1;
805  l = IDELEMS(h2);
806  while ((l > 0) && (h2->m[l-1] == NULL)) l--;
807  for (i=l-1; i>=0; i--)
808  {
809    if (h2->m[i] != NULL)
810    {
811      ll = 0;
812      while ((ll < k) && ((h3->m[ll] == NULL)
813      || !pDivisibleBy(h3->m[ll],h2->m[i])))
814        ll++;
815      if (ll >= k)
816      {
817        j++;
818        if (j > IDELEMS(e)-1)
819        {
820          pEnlargeSet(&(e->m),IDELEMS(e),16);
821          IDELEMS(e) += 16;
822        }
823        e->m[j] = pCopy(h2->m[i]);
824      }
825    }
826  }
827  idDelete(&h2);
828  idDelete(&h3);
829  idDelete(&h4);
830  if (currQuotient!=NULL)
831  {
832    h3=idInit(1,e->rank);
833    h2=kNF(h3,currQuotient,e);
834    idDelete(&h3);
835    idDelete(&e);
836    e=h2;
837  }
838  idSkipZeroes(e);
839  return e;
840}
841
842/*2
843*the minimal index of used variables - 1
844*/
845int pLowVar (poly p)
846{
847  int k,l,lex;
848
849  if (p == NULL) return -1;
850
851  k = 32000;/*a very large dummy value*/
852  while (p != NULL)
853  {
854    l = 1;
855    lex = pGetExp(p,l);
856    while ((l < pVariables) && (lex == 0))
857    {
858      l++;
859      lex = pGetExp(p,l);
860    }
861    l--;
862    if (l < k) k = l;
863    pIter(p);
864  }
865  return k;
866}
867
868/*3
869*multiplies p with t (!cas) or  (t-1)
870*the index of t is:1, so we have to shift all variables
871*p is NOT in the actual ring, it has no t
872*/
873static poly pMultWithT (poly p,BOOLEAN cas)
874{
875  /*qp is the working pointer in p*/
876  /*result is the result, qresult is the working pointer*/
877  /*pp is p in the actual ring(shifted), qpp the working pointer*/
878  poly result,qp,pp;
879  poly qresult=NULL;
880  poly qpp=NULL;
881  int  i,j,lex;
882  number n;
883
884  pp = NULL;
885  result = NULL;
886  qp = p;
887  while (qp != NULL)
888  {
889    i = 0;
890    if (result == NULL)
891    {/*first monomial*/
892      result = pInit();
893      qresult = result;
894    }
895    else
896    {
897      qresult->next = pInit();
898      pIter(qresult);
899    }
900    for (j=pVariables-1; j>0; j--)
901    {
902      lex = pGetExp(qp,j);
903      pSetExp(qresult,j+1,lex);/*copy all variables*/
904    }
905    lex = pGetComp(qp);
906    pSetComp(qresult,lex);
907    n=nCopy(pGetCoeff(qp));
908    pSetCoeff0(qresult,n);
909    qresult->next = NULL;
910    pSetm(qresult);
911    /*qresult is now qp brought into the actual ring*/
912    if (cas)
913    { /*case: mult with t-1*/
914      pSetExp(qresult,1,0);
915      pSetm(qresult);
916      if (pp == NULL)
917      { /*first monomial*/
918        pp = pCopy(qresult);
919        qpp = pp;
920      }
921      else
922      {
923        qpp->next = pCopy(qresult);
924        pIter(qpp);
925      }
926      pGetCoeff(qpp)=nNeg(pGetCoeff(qpp));
927      /*now qpp contains -1*qp*/
928    }
929    pSetExp(qresult,1,1);/*this is mult. by t*/
930    pSetm(qresult);
931    pIter(qp);
932  }
933  /*
934  *now p is processed:
935  *result contains t*p
936  * if cas: pp contains -1*p (in the new ring)
937  */
938  if (cas)  qresult->next = pp;
939  /*  else      qresult->next = NULL;*/
940  return result;
941}
942
943/*2
944* verschiebt die Indizees der Modulerzeugenden um i
945*/
946void pShift (poly * p,int i)
947{
948  poly qp1 = *p,qp2 = *p;/*working pointers*/
949  int     j = pMaxComp(*p),k = pMinComp(*p);
950
951  if (j+i < 0) return ;
952  while (qp1 != NULL)
953  {
954    if ((pGetComp(qp1)+i > 0) || ((j == -i) && (j == k)))
955    {
956      pAddComp(qp1,i);
957      pSetmComp(qp1);
958      qp2 = qp1;
959      pIter(qp1);
960    }
961    else
962    {
963      if (qp2 == *p)
964      {
965        pIter(*p);
966        pLmDelete(&qp2);
967        qp2 = *p;
968        qp1 = *p;
969      }
970      else
971      {
972        qp2->next = qp1->next;
973        if (qp1!=NULL) pLmDelete(&qp1);
974        qp1 = qp2->next;
975      }
976    }
977  }
978}
979
980/*2
981*initialized a field with r numbers between beg and end for the
982*procedure idNextChoise
983*/
984void idInitChoise (int r,int beg,int end,BOOLEAN  *endch,int * choise)
985{
986  /*returns the first choise of r numbers between beg and end*/
987  int i;
988  for (i=0; i<r; i++)
989  {
990    choise[i] = 0;
991  }
992  if (r <= end-beg+1)
993    for (i=0; i<r; i++)
994    {
995      choise[i] = beg+i;
996    }
997  if (r > end-beg+1)
998    *endch = TRUE;
999  else
1000    *endch = FALSE;
1001}
1002
1003/*2
1004*returns the next choise of r numbers between beg and end
1005*/
1006void idGetNextChoise (int r,int end,BOOLEAN  *endch,int * choise)
1007{
1008  int i = r-1,j;
1009  while ((i >= 0) && (choise[i] == end))
1010  {
1011    i--;
1012    end--;
1013  }
1014  if (i == -1)
1015    *endch = TRUE;
1016  else
1017  {
1018    choise[i]++;
1019    for (j=i+1; j<r; j++)
1020    {
1021      choise[j] = choise[i]+j-i;
1022    }
1023    *endch = FALSE;
1024  }
1025}
1026
1027/*2
1028*takes the field choise of d numbers between beg and end, cancels the t-th
1029*entree and searches for the ordinal number of that d-1 dimensional field
1030* w.r.t. the algorithm of construction
1031*/
1032int idGetNumberOfChoise(int t, int d, int begin, int end, int * choise)
1033{
1034  int * localchoise,i,result=0;
1035  BOOLEAN b=FALSE;
1036
1037  if (d<=1) return 1;
1038  localchoise=(int*)omAlloc((d-1)*sizeof(int));
1039  idInitChoise(d-1,begin,end,&b,localchoise);
1040  while (!b)
1041  {
1042    result++;
1043    i = 0;
1044    while ((i<t) && (localchoise[i]==choise[i])) i++;
1045    if (i>=t)
1046    {
1047      i = t+1;
1048      while ((i<d) && (localchoise[i-1]==choise[i])) i++;
1049      if (i>=d)
1050      {
1051        omFreeSize((ADDRESS)localchoise,(d-1)*sizeof(int));
1052        return result;
1053      }
1054    }
1055    idGetNextChoise(d-1,end,&b,localchoise);
1056  }
1057  omFreeSize((ADDRESS)localchoise,(d-1)*sizeof(int));
1058  return 0;
1059}
1060
1061/*2
1062*computes the binomial coefficient
1063*/
1064int binom (int n,int r)
1065{
1066  int i,result;
1067
1068  if (r==0) return 1;
1069  if (n-r<r) return binom(n,n-r);
1070  result = n-r+1;
1071  for (i=2;i<=r;i++)
1072  {
1073    result *= n-r+i;
1074    if (result<0)
1075    {
1076      WarnS("overflow in binomials");
1077      return 0;
1078    }
1079    result /= i;
1080  }
1081  return result;
1082}
1083
1084/*2
1085*the free module of rank i
1086*/
1087ideal idFreeModule (int i)
1088{
1089  int j;
1090  ideal h;
1091
1092  h=idInit(i,i);
1093  for (j=0; j<i; j++)
1094  {
1095    h->m[j] = pOne();
1096    pSetComp(h->m[j],j+1);
1097    pSetmComp(h->m[j]);
1098  }
1099  return h;
1100}
1101
1102/*2
1103* h3 := h1 intersect h2
1104*/
1105ideal idSect (ideal h1,ideal h2)
1106{
1107  int i,j,k,length;
1108  int flength = idRankFreeModule(h1);
1109  int slength = idRankFreeModule(h2);
1110  int rank=si_min(flength,slength);
1111  if ((idIs0(h1)) || (idIs0(h2)))  return idInit(1,rank);
1112
1113  ideal first,second,temp,temp1,result;
1114  poly p,q;
1115
1116  if (IDELEMS(h1)<IDELEMS(h2))
1117  {
1118    first = h1;
1119    second = h2;
1120  }
1121  else
1122  {
1123    first = h2;
1124    second = h1;
1125    int t=flength; flength=slength; slength=t;
1126  }
1127  length  = si_max(flength,slength);
1128  if (length==0)
1129  {
1130    length = 1;
1131  }
1132  j = IDELEMS(first);
1133
1134  ring orig_ring=currRing;
1135  ring syz_ring=rCurrRingAssure_SyzComp();
1136  rSetSyzComp(length);
1137
1138  while ((j>0) && (first->m[j-1]==NULL)) j--;
1139  temp = idInit(j /*IDELEMS(first)*/+IDELEMS(second),length+j);
1140  k = 0;
1141  for (i=0;i<j;i++)
1142  {
1143    if (first->m[i]!=NULL)
1144    {
1145      if (syz_ring==orig_ring)
1146        temp->m[k] = pCopy(first->m[i]);
1147      else
1148        temp->m[k] = prCopyR(first->m[i], orig_ring);
1149      q = pOne();
1150      pSetComp(q,i+1+length);
1151      pSetmComp(q);
1152      if (flength==0) pShift(&(temp->m[k]),1);
1153      p = temp->m[k];
1154      while (pNext(p)!=NULL) pIter(p);
1155      pNext(p) = q;
1156      k++;
1157    }
1158  }
1159  for (i=0;i<IDELEMS(second);i++)
1160  {
1161    if (second->m[i]!=NULL)
1162    {
1163      if (syz_ring==orig_ring)
1164        temp->m[k] = pCopy(second->m[i]);
1165      else
1166        temp->m[k] = prCopyR(second->m[i], orig_ring);
1167      if (slength==0) pShift(&(temp->m[k]),1);
1168      k++;
1169    }
1170  }
1171  intvec *w=NULL;
1172  temp1 = kStd(temp,currQuotient,testHomog,&w,NULL,length);
1173  if (w!=NULL) delete w;
1174  idDelete(&temp);
1175
1176  if(syz_ring!=orig_ring)
1177    rChangeCurrRing(orig_ring);
1178
1179  result = idInit(IDELEMS(temp1),rank);
1180  j = 0;
1181  for (i=0;i<IDELEMS(temp1);i++)
1182  {
1183    if ((temp1->m[i]!=NULL)
1184    && (p_GetComp(temp1->m[i],syz_ring)>length))
1185    {
1186      if(syz_ring==orig_ring)
1187      {
1188        p = temp1->m[i];
1189      }
1190      else
1191      {
1192        p = prMoveR(temp1->m[i], syz_ring);
1193      }
1194      temp1->m[i]=NULL;
1195      while (p!=NULL)
1196      {
1197        q = pNext(p);
1198        pNext(p) = NULL;
1199        k = pGetComp(p)-1-length;
1200        pSetComp(p,0);
1201        pSetmComp(p);
1202        /* Warning! multiply only from the left! it's very important for Plural */
1203        result->m[j] = pAdd(result->m[j],pMult(p,pCopy(first->m[k])));
1204        p = q;
1205      }
1206      j++;
1207    }
1208  }
1209  if(syz_ring!=orig_ring)
1210  {
1211    rChangeCurrRing(syz_ring);
1212    idDelete(&temp1);
1213    rChangeCurrRing(orig_ring);
1214    rKill(syz_ring);
1215  }
1216  else
1217  {
1218    idDelete(&temp1);
1219  }
1220
1221  idSkipZeroes(result);
1222  if (TEST_OPT_RETURN_SB)
1223  {
1224     w=NULL;
1225     temp1=kStd(result,currQuotient,testHomog,&w);
1226     if (w!=NULL) delete w;
1227     idDelete(&result);
1228     idSkipZeroes(temp1);
1229     return temp1;
1230  }
1231  else //temp1=kInterRed(result,currQuotient);
1232    return result;
1233}
1234
1235/*2
1236* ideal/module intersection for a list of objects
1237* given as 'resolvente'
1238*/
1239ideal idMultSect(resolvente arg, int length)
1240{
1241  int i,j=0,k=0,syzComp,l,maxrk=-1,realrki;
1242  ideal bigmat,tempstd,result;
1243  poly p;
1244  int isIdeal=0;
1245  intvec * w=NULL;
1246
1247  /* find 0-ideals and max rank -----------------------------------*/
1248  for (i=0;i<length;i++)
1249  {
1250    if (!idIs0(arg[i]))
1251    {
1252      realrki=idRankFreeModule(arg[i]);
1253      k++;
1254      j += IDELEMS(arg[i]);
1255      if (realrki>maxrk) maxrk = realrki;
1256    }
1257    else
1258    {
1259      if (arg[i]!=NULL)
1260      {
1261        return idInit(1,arg[i]->rank);
1262      }
1263    }
1264  }
1265  if (maxrk == 0)
1266  {
1267    isIdeal = 1;
1268    maxrk = 1;
1269  }
1270  /* init -----------------------------------------------------------*/
1271  j += maxrk;
1272  syzComp = k*maxrk;
1273
1274  ring orig_ring=currRing;
1275  ring syz_ring=rCurrRingAssure_SyzComp();
1276  rSetSyzComp(syzComp);
1277
1278  bigmat = idInit(j,(k+1)*maxrk);
1279  /* create unit matrices ------------------------------------------*/
1280  for (i=0;i<maxrk;i++)
1281  {
1282    for (j=0;j<=k;j++)
1283    {
1284      p = pOne();
1285      pSetComp(p,i+1+j*maxrk);
1286      pSetmComp(p);
1287      bigmat->m[i] = pAdd(bigmat->m[i],p);
1288    }
1289  }
1290  /* enter given ideals ------------------------------------------*/
1291  i = maxrk;
1292  k = 0;
1293  for (j=0;j<length;j++)
1294  {
1295    if (arg[j]!=NULL)
1296    {
1297      for (l=0;l<IDELEMS(arg[j]);l++)
1298      {
1299        if (arg[j]->m[l]!=NULL)
1300        {
1301          if (syz_ring==orig_ring)
1302            bigmat->m[i] = pCopy(arg[j]->m[l]);
1303          else
1304            bigmat->m[i] = prCopyR(arg[j]->m[l], orig_ring);
1305          pShift(&(bigmat->m[i]),k*maxrk+isIdeal);
1306          i++;
1307        }
1308      }
1309      k++;
1310    }
1311  }
1312  /* std computation --------------------------------------------*/
1313  tempstd = kStd(bigmat,currQuotient,testHomog,&w,NULL,syzComp);
1314  if (w!=NULL) delete w;
1315  idDelete(&bigmat);
1316
1317  if(syz_ring!=orig_ring)
1318    rChangeCurrRing(orig_ring);
1319
1320  /* interprete result ----------------------------------------*/
1321  result = idInit(IDELEMS(tempstd),maxrk);
1322  k = 0;
1323  for (j=0;j<IDELEMS(tempstd);j++)
1324  {
1325    if ((tempstd->m[j]!=NULL) && (p_GetComp(tempstd->m[j],syz_ring)>syzComp))
1326    {
1327      if (syz_ring==orig_ring)
1328        p = pCopy(tempstd->m[j]);
1329      else
1330        p = prCopyR(tempstd->m[j], syz_ring);
1331      pShift(&p,-syzComp-isIdeal);
1332      result->m[k] = p;
1333      k++;
1334    }
1335  }
1336  /* clean up ----------------------------------------------------*/
1337  if(syz_ring!=orig_ring)
1338    rChangeCurrRing(syz_ring);
1339  idDelete(&tempstd);
1340  if(syz_ring!=orig_ring)
1341  {
1342    rChangeCurrRing(orig_ring);
1343    rKill(syz_ring);
1344  }
1345  idSkipZeroes(result);
1346  return result;
1347}
1348
1349/*2
1350*computes syzygies of h1,
1351*if quot != NULL it computes in the quotient ring modulo "quot"
1352*works always in a ring with ringorder_s
1353*/
1354static ideal idPrepare (ideal  h1, tHomog hom, int syzcomp, intvec **w)
1355{
1356  ideal   h2, h3;
1357  int     i;
1358  int     j,jj=0,k;
1359  poly    p,q;
1360
1361  if (idIs0(h1)) return NULL;
1362  k = idRankFreeModule(h1);
1363  h2=idCopy(h1);
1364  i = IDELEMS(h2)-1;
1365  if (k == 0)
1366  {
1367    for (j=0; j<=i; j++) pShift(&(h2->m[j]),1);
1368    k = 1;
1369  }
1370  if (syzcomp<k)
1371  {
1372    Warn("syzcomp too low, should be %d instead of %d",k,syzcomp);
1373    syzcomp = k;
1374    rSetSyzComp(k);
1375  }
1376  h2->rank = syzcomp+i+1;
1377
1378  //if (hom==testHomog)
1379  //{
1380  //  if(idHomIdeal(h1,currQuotient))
1381  //  {
1382  //    hom=TRUE;
1383  //  }
1384  //}
1385
1386#if MYTEST
1387#ifdef RDEBUG
1388  Print("Prepare::h2: ");
1389  idPrint(h2);
1390
1391  for(j=0;j<IDELEMS(h2);j++) pTest(h2->m[j]);
1392
1393#endif
1394#endif
1395
1396  for (j=0; j<=i; j++)
1397  {
1398    p = h2->m[j];
1399    q = pOne();
1400    pSetComp(q,syzcomp+1+j);
1401    pSetmComp(q);
1402    if (p!=NULL)
1403    {
1404      while (pNext(p)) pIter(p);
1405      p->next = q;
1406    }
1407    else
1408      h2->m[j]=q;
1409  }
1410
1411#ifdef PDEBUG
1412  for(j=0;j<IDELEMS(h2);j++) pTest(h2->m[j]);
1413
1414#if MYTEST
1415#ifdef RDEBUG
1416  Print("Prepare::Input: ");
1417  idPrint(h2);
1418
1419  Print("Prepare::currQuotient: ");
1420  idPrint(currQuotient);
1421#endif
1422#endif
1423
1424#endif
1425
1426  idTest(h2);
1427
1428  h3 = kStd(h2,currQuotient,hom,w,NULL,syzcomp);
1429
1430#if MYTEST
1431#ifdef RDEBUG
1432  Print("Prepare::Output: ");
1433  idPrint(h3);
1434  for(j=0;j<IDELEMS(h2);j++) pTest(h3->m[j]);
1435#endif
1436#endif
1437
1438
1439  idDelete(&h2);
1440  return h3;
1441}
1442
1443/*2
1444* compute the syzygies of h1 in R/quot,
1445* weights of components are in w
1446* if setRegularity, return the regularity in deg
1447* do not change h1,  w
1448*/
1449ideal idSyzygies (ideal  h1, tHomog h,intvec **w, BOOLEAN setSyzComp,
1450                  BOOLEAN setRegularity, int *deg)
1451{
1452  ideal s_h1;
1453  poly  p;
1454  int   j, k, length=0,reg;
1455  BOOLEAN isMonomial=TRUE;
1456  int ii, idElemens_h1;
1457
1458  assume(h1 != NULL);
1459
1460  idElemens_h1=IDELEMS(h1);
1461#ifdef PDEBUG
1462  for(ii=0;ii<idElemens_h1 /*IDELEMS(h1)*/;ii++) pTest(h1->m[ii]);
1463#endif
1464  if (idIs0(h1))
1465  {
1466    ideal result=idFreeModule(idElemens_h1/*IDELEMS(h1)*/);
1467    int curr_syz_limit=rGetCurrSyzLimit();
1468    if (curr_syz_limit>0)
1469    for (ii=0;ii<idElemens_h1/*IDELEMS(h1)*/;ii++)
1470    {
1471      if (h1->m[ii]!=NULL)
1472        pShift(&h1->m[ii],curr_syz_limit);
1473    }
1474    return result;
1475  }
1476  int slength=(int)idRankFreeModule(h1);
1477  k=si_max(1,slength /*idRankFreeModule(h1)*/);
1478
1479  assume(currRing != NULL);
1480  ring orig_ring=currRing;
1481  ring syz_ring=rCurrRingAssure_SyzComp();
1482
1483  if (setSyzComp)
1484    rSetSyzComp(k);
1485
1486  if (orig_ring != syz_ring)
1487  {
1488    s_h1=idrCopyR_NoSort(h1,orig_ring);
1489  }
1490  else
1491  {
1492    s_h1 = h1;
1493  }
1494
1495  idTest(s_h1);
1496
1497  ideal s_h3=idPrepare(s_h1,h,k,w); // main (syz) GB computation
1498
1499  if (s_h3==NULL)
1500  {
1501    return idFreeModule( idElemens_h1 /*IDELEMS(h1)*/);
1502  }
1503
1504  if (orig_ring != syz_ring)
1505  {
1506    idDelete(&s_h1);
1507    for (j=0; j<IDELEMS(s_h3); j++)
1508    {
1509      if (s_h3->m[j] != NULL)
1510      {
1511        if (p_MinComp(s_h3->m[j],syz_ring) > k)
1512          pShift(&s_h3->m[j], -k);
1513        else
1514          pDelete(&s_h3->m[j]);
1515      }
1516    }
1517    idSkipZeroes(s_h3);
1518    s_h3->rank -= k;
1519    rChangeCurrRing(orig_ring);
1520    s_h3 = idrMoveR_NoSort(s_h3, syz_ring);
1521    rKill(syz_ring);
1522    #ifdef HAVE_PLURAL
1523    if (rIsPluralRing(currRing))
1524    {
1525      idDelMultiples(s_h3);
1526      idSkipZeroes(s_h3);
1527    }
1528    #endif
1529    idTest(s_h3);
1530    return s_h3;
1531  }
1532
1533  ideal e = idInit(IDELEMS(s_h3), s_h3->rank);
1534
1535  for (j=IDELEMS(s_h3)-1; j>=0; j--)
1536  {
1537    if (s_h3->m[j] != NULL)
1538    {
1539      if (p_MinComp(s_h3->m[j],syz_ring) <= k)
1540      {
1541        e->m[j] = s_h3->m[j];
1542        isMonomial=isMonomial && (pNext(s_h3->m[j])==NULL);
1543        pDelete(&pNext(s_h3->m[j]));
1544        s_h3->m[j] = NULL;
1545      }
1546    }
1547  }
1548
1549  idSkipZeroes(s_h3);
1550  idSkipZeroes(e);
1551
1552  if ((deg != NULL)
1553  && (!isMonomial)
1554  && (!TEST_OPT_NOTREGULARITY)
1555  && (setRegularity)
1556  && (h==isHomog)
1557  && (!rIsPluralRing(currRing))
1558  )
1559  {
1560    ring dp_C_ring = rCurrRingAssure_dp_C();
1561    if (dp_C_ring != syz_ring)
1562      e = idrMoveR_NoSort(e, syz_ring);
1563    resolvente res = sySchreyerResolvente(e,-1,&length,TRUE, TRUE);
1564    intvec * dummy = syBetti(res,length,&reg, *w);
1565    *deg = reg+2;
1566    delete dummy;
1567    for (j=0;j<length;j++)
1568    {
1569      if (res[j]!=NULL) idDelete(&(res[j]));
1570    }
1571    omFreeSize((ADDRESS)res,length*sizeof(ideal));
1572    idDelete(&e);
1573    if (dp_C_ring != syz_ring)
1574    {
1575      rChangeCurrRing(syz_ring);
1576      rKill(dp_C_ring);
1577    }
1578  }
1579  else
1580  {
1581    idDelete(&e);
1582  }
1583  idTest(s_h3);
1584  if (currQuotient != NULL)
1585  {
1586    ideal ts_h3=kStd(s_h3,currQuotient,h,w);
1587    idDelete(&s_h3);
1588    s_h3 = ts_h3;
1589  }
1590  return s_h3;
1591}
1592
1593/*2
1594*/
1595ideal idXXX (ideal  h1, int k)
1596{
1597  ideal s_h1;
1598  int j;
1599  intvec *w=NULL;
1600
1601  assume(currRing != NULL);
1602  ring orig_ring=currRing;
1603  ring syz_ring=rCurrRingAssure_SyzComp();
1604
1605  rSetSyzComp(k);
1606
1607  if (orig_ring != syz_ring)
1608  {
1609    s_h1=idrCopyR_NoSort(h1,orig_ring);
1610  }
1611  else
1612  {
1613    s_h1 = h1;
1614  }
1615
1616  ideal s_h3=kStd(s_h1,NULL,testHomog,&w,NULL,k);
1617
1618  if (s_h3==NULL)
1619  {
1620    return idFreeModule(IDELEMS(h1));
1621  }
1622
1623  if (orig_ring != syz_ring)
1624  {
1625    idDelete(&s_h1);
1626    idSkipZeroes(s_h3);
1627    rChangeCurrRing(orig_ring);
1628    s_h3 = idrMoveR_NoSort(s_h3, syz_ring);
1629    rKill(syz_ring);
1630    idTest(s_h3);
1631    return s_h3;
1632  }
1633
1634  idSkipZeroes(s_h3);
1635  idTest(s_h3);
1636  return s_h3;
1637}
1638
1639/*
1640*computes a standard basis for h1 and stores the transformation matrix
1641* in ma
1642*/
1643ideal idLiftStd (ideal  h1, matrix* ma, tHomog hi, ideal * syz)
1644{
1645  int   i, j, k, t, inputIsIdeal=idRankFreeModule(h1);
1646  poly  p=NULL, q, qq;
1647  intvec *w=NULL;
1648
1649  idDelete((ideal*)ma);
1650  BOOLEAN lift3=FALSE;
1651  if (syz!=NULL) { lift3=TRUE; idDelete(syz); }
1652  if (idIs0(h1))
1653  {
1654    *ma=mpNew(1,0);
1655    if (lift3)
1656    {
1657      *syz=idFreeModule(IDELEMS(h1));
1658      int curr_syz_limit=rGetCurrSyzLimit();
1659      if (curr_syz_limit>0)
1660      for (int ii=0;ii<IDELEMS(h1);ii++)
1661      {
1662        if (h1->m[ii]!=NULL)
1663          pShift(&h1->m[ii],curr_syz_limit);
1664      }
1665    }
1666    return idInit(1,h1->rank);
1667  }
1668
1669  BITSET save_verbose=verbose;
1670
1671  k=si_max(1,(int)idRankFreeModule(h1));
1672
1673  if ((k==1) && (!lift3)) verbose |=Sy_bit(V_IDLIFT);
1674
1675  ring orig_ring = currRing;
1676  ring syz_ring = rCurrRingAssure_SyzComp();
1677  rSetSyzComp(k);
1678
1679  ideal s_h1=h1;
1680
1681  if (orig_ring != syz_ring)
1682    s_h1 = idrCopyR_NoSort(h1,orig_ring);
1683  else
1684    s_h1 = h1;
1685
1686  ideal s_h3=idPrepare(s_h1,hi,k,&w); // main (syz) GB computation
1687
1688  ideal s_h2 = idInit(IDELEMS(s_h3), s_h3->rank);
1689
1690  if (lift3) (*syz)=idInit(IDELEMS(s_h3),IDELEMS(h1));
1691
1692  if (w!=NULL) delete w;
1693  i = 0;
1694
1695  // now sort the result, SB : leave in s_h3
1696  //                      T:  put in s_h2
1697  //                      syz: put in *syz
1698  for (j=0; j<IDELEMS(s_h3); j++)
1699  {
1700    if (s_h3->m[j] != NULL)
1701    {
1702      //if (p_MinComp(s_h3->m[j],syz_ring) <= k)
1703      if (pGetComp(s_h3->m[j]) <= k) // syz_ring == currRing
1704      {
1705        i++;
1706        q = s_h3->m[j];
1707        while (pNext(q) != NULL)
1708        {
1709          if (pGetComp(pNext(q)) > k)
1710          {
1711            s_h2->m[j] = pNext(q);
1712            pNext(q) = NULL;
1713          }
1714          else
1715          {
1716            pIter(q);
1717          }
1718        }
1719        if (!inputIsIdeal) pShift(&(s_h3->m[j]), -1);
1720      }
1721      else
1722      {
1723        // we a syzygy here:
1724        if (lift3)
1725        {
1726          pShift(&s_h3->m[j], -k);
1727          (*syz)->m[j]=s_h3->m[j];
1728          s_h3->m[j]=NULL;
1729        }
1730        else
1731          pDelete(&(s_h3->m[j]));
1732      }
1733    }
1734  }
1735  idSkipZeroes(s_h3);
1736  //extern char * iiStringMatrix(matrix im, int dim,char ch);
1737  //PrintS("SB: ----------------------------------------\n");
1738  //PrintS(iiStringMatrix((matrix)s_h3,k,'\n'));
1739  //PrintLn();
1740  //PrintS("T: ----------------------------------------\n");
1741  //PrintS(iiStringMatrix((matrix)s_h2,h1->rank,'\n'));
1742  //PrintLn();
1743
1744  if (lift3) idSkipZeroes(*syz);
1745
1746  j = IDELEMS(s_h1);
1747
1748
1749  if (syz_ring!=orig_ring)
1750  {
1751    idDelete(&s_h1);
1752    rChangeCurrRing(orig_ring);
1753  }
1754
1755  *ma = mpNew(j,i);
1756
1757  i = 1;
1758  for (j=0; j<IDELEMS(s_h2); j++)
1759  {
1760    if (s_h2->m[j] != NULL)
1761    {
1762      q = prMoveR( s_h2->m[j], syz_ring);
1763      s_h2->m[j] = NULL;
1764
1765      while (q != NULL)
1766      {
1767        p = q;
1768        pIter(q);
1769        pNext(p) = NULL;
1770        t=pGetComp(p);
1771        pSetComp(p,0);
1772        pSetmComp(p);
1773        MATELEM(*ma,t-k,i) = pAdd(MATELEM(*ma,t-k,i),p);
1774      }
1775      i++;
1776    }
1777  }
1778  idDelete(&s_h2);
1779
1780  for (i=0; i<IDELEMS(s_h3); i++)
1781  {
1782    s_h3->m[i] = prMoveR_NoSort(s_h3->m[i], syz_ring);
1783  }
1784  if (lift3)
1785  {
1786    for (i=0; i<IDELEMS(*syz); i++)
1787    {
1788      (*syz)->m[i] = prMoveR_NoSort((*syz)->m[i], syz_ring);
1789    }
1790  }
1791
1792  if (syz_ring!=orig_ring) rKill(syz_ring);
1793  verbose = save_verbose;
1794  return s_h3;
1795}
1796
1797static void idPrepareStd(ideal s_temp, int k)
1798{
1799  int j,rk=idRankFreeModule(s_temp);
1800  poly p,q;
1801
1802  if (rk == 0)
1803  {
1804    for (j=0; j<IDELEMS(s_temp); j++)
1805    {
1806      if (s_temp->m[j]!=NULL) pSetCompP(s_temp->m[j],1);
1807    }
1808    k = si_max(k,1);
1809  }
1810  for (j=0; j<IDELEMS(s_temp); j++)
1811  {
1812    if (s_temp->m[j]!=NULL)
1813    {
1814      p = s_temp->m[j];
1815      q = pOne();
1816      //pGetCoeff(q)=nNeg(pGetCoeff(q));   //set q to -1
1817      pSetComp(q,k+1+j);
1818      pSetmComp(q);
1819      while (pNext(p)) pIter(p);
1820      pNext(p) = q;
1821    }
1822  }
1823}
1824
1825/*2
1826*computes a representation of the generators of submod with respect to those
1827* of mod
1828*/
1829
1830ideal idLift(ideal mod, ideal submod,ideal *rest, BOOLEAN goodShape,
1831             BOOLEAN isSB, BOOLEAN divide, matrix *unit)
1832{
1833  int lsmod =idRankFreeModule(submod), i, j, k;
1834  int comps_to_add=0;
1835  poly p;
1836
1837  if (idIs0(submod))
1838  {
1839    if (unit!=NULL)
1840    {
1841      *unit=mpNew(1,1);
1842      MATELEM(*unit,1,1)=pOne();
1843    }
1844    if (rest!=NULL)
1845    {
1846      *rest=idInit(1,mod->rank);
1847    }
1848    return idInit(1,mod->rank);
1849  }
1850  if (idIs0(mod)) /* and not idIs0(submod) */
1851  {
1852    WerrorS("2nd module does not lie in the first");
1853    #if 0
1854    if (unit!=NULL)
1855    {
1856      i=IDELEMS(submod);
1857      *unit=mpNew(i,i);
1858      for (j=i;j>0;j--)
1859      {
1860        MATELEM(*unit,j,j)=pOne();
1861      }
1862    }
1863    if (rest!=NULL)
1864    {
1865      *rest=idCopy(submod);
1866    }
1867    return idInit(1,mod->rank);
1868    #endif
1869    return idInit(IDELEMS(submod),submod->rank);
1870  }
1871  if (unit!=NULL)
1872  {
1873    comps_to_add = IDELEMS(submod);
1874    while ((comps_to_add>0) && (submod->m[comps_to_add-1]==NULL))
1875      comps_to_add--;
1876  }
1877  k=si_max(idRankFreeModule(mod),idRankFreeModule(submod));
1878  if  ((k!=0) && (lsmod==0)) lsmod=1;
1879  k=si_max(k,(int)mod->rank);
1880  if (k<submod->rank) { WarnS("rk(submod) > rk(mod) ?");k=submod->rank; }
1881
1882  ring orig_ring=currRing;
1883  ring syz_ring=rCurrRingAssure_SyzComp();
1884  rSetSyzComp(k);
1885
1886  ideal s_mod, s_temp;
1887  if (orig_ring != syz_ring)
1888  {
1889    s_mod = idrCopyR_NoSort(mod,orig_ring);
1890    s_temp = idrCopyR_NoSort(submod,orig_ring);
1891  }
1892  else
1893  {
1894    s_mod = mod;
1895    s_temp = idCopy(submod);
1896  }
1897  ideal s_h3;
1898  if (isSB)
1899  {
1900    s_h3 = idCopy(s_mod);
1901    idPrepareStd(s_h3, k+comps_to_add);
1902  }
1903  else
1904  {
1905    s_h3 = idPrepare(s_mod,(tHomog)FALSE,k+comps_to_add,NULL);
1906  }
1907  if (!goodShape)
1908  {
1909    for (j=0;j<IDELEMS(s_h3);j++)
1910    {
1911      if ((s_h3->m[j] != NULL) && (pMinComp(s_h3->m[j]) > k))
1912        pDelete(&(s_h3->m[j]));
1913    }
1914  }
1915  idSkipZeroes(s_h3);
1916  if (lsmod==0)
1917  {
1918    for (j=IDELEMS(s_temp);j>0;j--)
1919    {
1920      if (s_temp->m[j-1]!=NULL)
1921        pShift(&(s_temp->m[j-1]),1);
1922    }
1923  }
1924  if (unit!=NULL)
1925  {
1926    for(j = 0;j<comps_to_add;j++)
1927    {
1928      p = s_temp->m[j];
1929      if (p!=NULL)
1930      {
1931        while (pNext(p)!=NULL) pIter(p);
1932        pNext(p) = pOne();
1933        pIter(p);
1934        pSetComp(p,1+j+k);
1935        pSetmComp(p);
1936        p = pNeg(p);
1937      }
1938    }
1939  }
1940  ideal s_result = kNF(s_h3,currQuotient,s_temp,k);
1941  s_result->rank = s_h3->rank;
1942  ideal s_rest = idInit(IDELEMS(s_result),k);
1943  idDelete(&s_h3);
1944  idDelete(&s_temp);
1945
1946  for (j=0;j<IDELEMS(s_result);j++)
1947  {
1948    if (s_result->m[j]!=NULL)
1949    {
1950      if (pGetComp(s_result->m[j])<=k)
1951      {
1952        if (!divide)
1953        {
1954          if (isSB)
1955          {
1956            WarnS("first module not a standardbasis\n"
1957              "// ** or second not a proper submodule");
1958          }
1959          else
1960            WerrorS("2nd module does not lie in the first");
1961          idDelete(&s_result);
1962          idDelete(&s_rest);
1963          s_result=idInit(IDELEMS(submod),submod->rank);
1964          break;
1965        }
1966        else
1967        {
1968          p = s_rest->m[j] = s_result->m[j];
1969          while ((pNext(p)!=NULL) && (pGetComp(pNext(p))<=k)) pIter(p);
1970          s_result->m[j] = pNext(p);
1971          pNext(p) = NULL;
1972        }
1973      }
1974      pShift(&(s_result->m[j]),-k);
1975      pNeg(s_result->m[j]);
1976    }
1977  }
1978  if ((lsmod==0) && (!idIs0(s_rest)))
1979  {
1980    for (j=IDELEMS(s_rest);j>0;j--)
1981    {
1982      if (s_rest->m[j-1]!=NULL)
1983      {
1984        pShift(&(s_rest->m[j-1]),-1);
1985        s_rest->m[j-1] = s_rest->m[j-1];
1986      }
1987    }
1988  }
1989  if(syz_ring!=orig_ring)
1990  {
1991    idDelete(&s_mod);
1992    rChangeCurrRing(orig_ring);
1993    s_result = idrMoveR_NoSort(s_result, syz_ring);
1994    s_rest = idrMoveR_NoSort(s_rest, syz_ring);
1995    rKill(syz_ring);
1996  }
1997  if (rest!=NULL)
1998    *rest = s_rest;
1999  else
2000    idDelete(&s_rest);
2001//idPrint(s_result);
2002  if (unit!=NULL)
2003  {
2004    *unit=mpNew(comps_to_add,comps_to_add);
2005    int i;
2006    for(i=0;i<IDELEMS(s_result);i++)
2007    {
2008      poly p=s_result->m[i];
2009      poly q=NULL;
2010      while(p!=NULL)
2011      {
2012        if(pGetComp(p)<=comps_to_add)
2013        {
2014          pSetComp(p,0);
2015          if (q!=NULL)
2016          {
2017            pNext(q)=pNext(p);
2018          }
2019          else
2020          {
2021            pIter(s_result->m[i]);
2022          }
2023          pNext(p)=NULL;
2024          MATELEM(*unit,i+1,i+1)=pAdd(MATELEM(*unit,i+1,i+1),p);
2025          if(q!=NULL)   p=pNext(q);
2026          else          p=s_result->m[i];
2027        }
2028        else
2029        {
2030          q=p;
2031          pIter(p);
2032        }
2033      }
2034      pShift(&s_result->m[i],-comps_to_add);
2035    }
2036  }
2037  return s_result;
2038}
2039
2040/*2
2041*computes division of P by Q with remainder up to (w-weighted) degree n
2042*P, Q, and w are not changed
2043*/
2044void idLiftW(ideal P,ideal Q,int n,matrix &T, ideal &R,short *w)
2045{
2046  long N=0;
2047  int i;
2048  for(i=IDELEMS(Q)-1;i>=0;i--)
2049    if(w==NULL)
2050      N=si_max(N,pDeg(Q->m[i]));
2051    else
2052      N=si_max(N,pDegW(Q->m[i],w));
2053  N+=n;
2054
2055  T=mpNew(IDELEMS(Q),IDELEMS(P));
2056  R=idInit(IDELEMS(P),P->rank);
2057
2058  for(i=IDELEMS(P)-1;i>=0;i--)
2059  {
2060    poly p;
2061    if(w==NULL)
2062      p=ppJet(P->m[i],N);
2063    else
2064      p=ppJetW(P->m[i],N,w);
2065
2066    int j=IDELEMS(Q)-1;
2067    while(p!=NULL)
2068    {
2069      if(pDivisibleBy(Q->m[j],p))
2070      {
2071        poly p0=pDivideM(pHead(p),pHead(Q->m[j]));
2072        if(w==NULL)
2073          p=pJet(pSub(p,ppMult_mm(Q->m[j],p0)),N);
2074        else
2075          p=pJetW(pSub(p,ppMult_mm(Q->m[j],p0)),N,w);
2076        pNormalize(p);
2077        if((w==NULL)&&(pDeg(p0)>n)||(w!=NULL)&&(pDegW(p0,w)>n))
2078          pDelete(&p0);
2079        else
2080          MATELEM(T,j+1,i+1)=pAdd(MATELEM(T,j+1,i+1),p0);
2081        j=IDELEMS(Q)-1;
2082      }
2083      else
2084      {
2085        if(j==0)
2086        {
2087          poly p0=p;
2088          pIter(p);
2089          pNext(p0)=NULL;
2090          if(((w==NULL)&&(pDeg(p0)>n))
2091          ||((w!=NULL)&&(pDegW(p0,w)>n)))
2092            pDelete(&p0);
2093          else
2094            R->m[i]=pAdd(R->m[i],p0);
2095          j=IDELEMS(Q)-1;
2096        }
2097        else
2098          j--;
2099      }
2100    }
2101  }
2102}
2103
2104/*2
2105*computes the quotient of h1,h2 : internal routine for idQuot
2106*BEWARE: the returned ideals may contain incorrectly ordered polys !
2107*
2108*/
2109static ideal idInitializeQuot (ideal  h1, ideal h2, BOOLEAN h1IsStb,
2110                               BOOLEAN *addOnlyOne, int *kkmax)
2111{
2112  ideal temph1;
2113  poly     p,q = NULL;
2114  int i,l,ll,k,kkk,kmax;
2115  int j = 0;
2116  int k1 = idRankFreeModule(h1);
2117  int k2 = idRankFreeModule(h2);
2118  tHomog   hom=isNotHomog;
2119
2120  k=si_max(k1,k2);
2121  if (k==0)
2122    k = 1;
2123  if ((k2==0) && (k>1)) *addOnlyOne = FALSE;
2124
2125  intvec * weights;
2126  hom = (tHomog)idHomModule(h1,currQuotient,&weights);
2127  if (/**addOnlyOne &&*/ (!h1IsStb))
2128    temph1 = kStd(h1,currQuotient,hom,&weights,NULL);
2129  else
2130    temph1 = idCopy(h1);
2131  if (weights!=NULL) delete weights;
2132  idTest(temph1);
2133/*--- making a single vector from h2 ---------------------*/
2134  for (i=0; i<IDELEMS(h2); i++)
2135  {
2136    if (h2->m[i] != NULL)
2137    {
2138      p = pCopy(h2->m[i]);
2139      if (k2 == 0)
2140        pShift(&p,j*k+1);
2141      else
2142        pShift(&p,j*k);
2143      q = pAdd(q,p);
2144      j++;
2145    }
2146  }
2147  *kkmax = kmax = j*k+1;
2148/*--- adding a monomial for the result (syzygy) ----------*/
2149  p = q;
2150  while (pNext(p)!=NULL) pIter(p);
2151  pNext(p) = pOne();
2152  pIter(p);
2153  pSetComp(p,kmax);
2154  pSetmComp(p);
2155/*--- constructing the big matrix ------------------------*/
2156  ideal h4 = idInit(16,kmax+k-1);
2157  h4->m[0] = q;
2158  if (k2 == 0)
2159  {
2160    if (k > IDELEMS(h4))
2161    {
2162      pEnlargeSet(&(h4->m),IDELEMS(h4),k-IDELEMS(h4));
2163      IDELEMS(h4) = k;
2164    }
2165    for (i=1; i<k; i++)
2166    {
2167      if (h4->m[i-1]!=NULL)
2168      {
2169        p = pCopy_noCheck(h4->m[i-1]);
2170        pShift(&p,1);
2171        h4->m[i] = p;
2172      }
2173    }
2174  }
2175  idSkipZeroes(h4);
2176  kkk = IDELEMS(h4);
2177  i = IDELEMS(temph1);
2178  for (l=0; l<i; l++)
2179  {
2180    if(temph1->m[l]!=NULL)
2181    {
2182      for (ll=0; ll<j; ll++)
2183      {
2184        p = pCopy(temph1->m[l]);
2185        if (k1 == 0)
2186          pShift(&p,ll*k+1);
2187        else
2188          pShift(&p,ll*k);
2189        if (kkk >= IDELEMS(h4))
2190        {
2191          pEnlargeSet(&(h4->m),IDELEMS(h4),16);
2192          IDELEMS(h4) += 16;
2193        }
2194        h4->m[kkk] = p;
2195        kkk++;
2196      }
2197    }
2198  }
2199/*--- if h2 goes in as single vector - the h1-part is just SB ---*/
2200  if (*addOnlyOne)
2201  {
2202    idSkipZeroes(h4);
2203    p = h4->m[0];
2204    for (i=0;i<IDELEMS(h4)-1;i++)
2205    {
2206      h4->m[i] = h4->m[i+1];
2207    }
2208    h4->m[IDELEMS(h4)-1] = p;
2209    test |= Sy_bit(OPT_SB_1);
2210  }
2211  idDelete(&temph1);
2212  return h4;
2213}
2214/*2
2215*computes the quotient of h1,h2
2216*/
2217ideal idQuot (ideal  h1, ideal h2, BOOLEAN h1IsStb, BOOLEAN resultIsIdeal)
2218{
2219  // first check for special case h1:(0)
2220  if (idIs0(h2))
2221  {
2222    ideal res;
2223    if (resultIsIdeal)
2224    {
2225      res = idInit(1,1);
2226      res->m[0] = pOne();
2227    }
2228    else
2229      res = idFreeModule(h1->rank);
2230    return res;
2231  }
2232  BITSET old_test=test;
2233  int i,l,ll,k,kkk,kmax;
2234  BOOLEAN  addOnlyOne=TRUE;
2235  tHomog   hom=isNotHomog;
2236  intvec * weights1;
2237
2238  ideal s_h4 = idInitializeQuot (h1,h2,h1IsStb,&addOnlyOne,&kmax);
2239
2240  hom = (tHomog)idHomModule(s_h4,currQuotient,&weights1);
2241
2242  ring orig_ring=currRing;
2243  ring syz_ring=rCurrRingAssure_SyzComp();
2244  rSetSyzComp(kmax-1);
2245  if (orig_ring!=syz_ring)
2246  //  s_h4 = idrMoveR_NoSort(s_h4,orig_ring);
2247    s_h4 = idrMoveR(s_h4,orig_ring);
2248  idTest(s_h4);
2249  #if 0
2250  void ipPrint_MA0(matrix m, const char *name);
2251  matrix m=idModule2Matrix(idCopy(s_h4));
2252  PrintS("start:\n");
2253  ipPrint_MA0(m,"Q");
2254  idDelete((ideal *)&m);
2255  PrintS("last elem:");wrp(s_h4->m[IDELEMS(s_h4)-1]);PrintLn();
2256  #endif
2257  ideal s_h3;
2258  if (addOnlyOne)
2259  {
2260    s_h3 = kStd(s_h4,currQuotient,hom,&weights1,NULL,0/*kmax-1*/,IDELEMS(s_h4)-1);
2261  }
2262  else
2263  {
2264    s_h3 = kStd(s_h4,currQuotient,hom,&weights1,NULL,kmax-1);
2265  }
2266  test = old_test;
2267  #if 0
2268  // only together with the above debug stuff
2269  idSkipZeroes(s_h3);
2270  m=idModule2Matrix(idCopy(s_h3));
2271  Print("result, kmax=%d:\n",kmax);
2272  ipPrint_MA0(m,"S");
2273  idDelete((ideal *)&m);
2274  #endif
2275  idTest(s_h3);
2276  if (weights1!=NULL) delete weights1;
2277  idDelete(&s_h4);
2278
2279  for (i=0;i<IDELEMS(s_h3);i++)
2280  {
2281    if ((s_h3->m[i]!=NULL) && (pGetComp(s_h3->m[i])>=kmax))
2282    {
2283      if (resultIsIdeal)
2284        pShift(&s_h3->m[i],-kmax);
2285      else
2286        pShift(&s_h3->m[i],-kmax+1);
2287    }
2288    else
2289      pDelete(&s_h3->m[i]);
2290  }
2291  if (resultIsIdeal)
2292    s_h3->rank = 1;
2293  else
2294    s_h3->rank = h1->rank;
2295  if(syz_ring!=orig_ring)
2296  {
2297    rChangeCurrRing(orig_ring);
2298    s_h3 = idrMoveR_NoSort(s_h3, syz_ring);
2299    rKill(syz_ring);
2300  }
2301  idSkipZeroes(s_h3);
2302  idTest(s_h3);
2303  return s_h3;
2304}
2305
2306/*2
2307*computes recursively all monomials of a certain degree
2308*in every step the actvar-th entry in the exponential
2309*vector is incremented and the other variables are
2310*computed by recursive calls of makemonoms
2311*if the last variable is reached, the difference to the
2312*degree is computed directly
2313*vars is the number variables
2314*actvar is the actual variable to handle
2315*deg is the degree of the monomials to compute
2316*monomdeg is the actual degree of the monomial in consideration
2317*/
2318static void makemonoms(int vars,int actvar,int deg,int monomdeg)
2319{
2320  poly p;
2321  int i=0;
2322
2323  if ((idpowerpoint == 0) && (actvar ==1))
2324  {
2325    idpower[idpowerpoint] = pOne();
2326    monomdeg = 0;
2327  }
2328  while (i<=deg)
2329  {
2330    if (deg == monomdeg)
2331    {
2332      pSetm(idpower[idpowerpoint]);
2333      idpowerpoint++;
2334      return;
2335    }
2336    if (actvar == vars)
2337    {
2338      pSetExp(idpower[idpowerpoint],actvar,deg-monomdeg);
2339      pSetm(idpower[idpowerpoint]);
2340      pTest(idpower[idpowerpoint]);
2341      idpowerpoint++;
2342      return;
2343    }
2344    else
2345    {
2346      p = pCopy(idpower[idpowerpoint]);
2347      makemonoms(vars,actvar+1,deg,monomdeg);
2348      idpower[idpowerpoint] = p;
2349    }
2350    monomdeg++;
2351    pSetExp(idpower[idpowerpoint],actvar,pGetExp(idpower[idpowerpoint],actvar)+1);
2352    pSetm(idpower[idpowerpoint]);
2353    pTest(idpower[idpowerpoint]);
2354    i++;
2355  }
2356}
2357
2358/*2
2359*returns the deg-th power of the maximal ideal of 0
2360*/
2361ideal idMaxIdeal(int deg)
2362{
2363  if (deg < 0)
2364  {
2365    WarnS("maxideal: power must be non-negative");
2366  }
2367  if (deg < 1)
2368  {
2369    ideal I=idInit(1,1);
2370    I->m[0]=pOne();
2371    return I;
2372  }
2373  if (deg == 1)
2374  {
2375    return idMaxIdeal();
2376  }
2377
2378  int vars = currRing->N;
2379  int i = binom(vars+deg-1,deg);
2380  if (i<=0) return idInit(1,1);
2381  ideal id=idInit(i,1);
2382  idpower = id->m;
2383  idpowerpoint = 0;
2384  makemonoms(vars,1,deg,0);
2385  idpower = NULL;
2386  idpowerpoint = 0;
2387  return id;
2388}
2389
2390/*2
2391*computes recursively all generators of a certain degree
2392*of the ideal "givenideal"
2393*elms is the number elements in the given ideal
2394*actelm is the actual element to handle
2395*deg is the degree of the power to compute
2396*gendeg is the actual degree of the generator in consideration
2397*/
2398static void makepotence(int elms,int actelm,int deg,int gendeg)
2399{
2400  poly p;
2401  int i=0;
2402
2403  if ((idpowerpoint == 0) && (actelm ==1))
2404  {
2405    idpower[idpowerpoint] = pOne();
2406    gendeg = 0;
2407  }
2408  while (i<=deg)
2409  {
2410    if (deg == gendeg)
2411    {
2412      idpowerpoint++;
2413      return;
2414    }
2415    if (actelm == elms)
2416    {
2417      p=pPower(pCopy(givenideal[actelm-1]),deg-gendeg);
2418      idpower[idpowerpoint]=pMult(idpower[idpowerpoint],p);
2419      idpowerpoint++;
2420      return;
2421    }
2422    else
2423    {
2424      p = pCopy(idpower[idpowerpoint]);
2425      makepotence(elms,actelm+1,deg,gendeg);
2426      idpower[idpowerpoint] = p;
2427    }
2428    gendeg++;
2429    idpower[idpowerpoint]=pMult(idpower[idpowerpoint],pCopy(givenideal[actelm-1]));
2430    i++;
2431  }
2432}
2433
2434/*2
2435*returns the deg-th power of the ideal gid
2436*/
2437//ideal idPower(ideal gid,int deg)
2438//{
2439//  int i;
2440//  ideal id;
2441//
2442//  if (deg < 1) deg = 1;
2443//  i = binom(IDELEMS(gid)+deg-1,deg);
2444//  id=idInit(i,1);
2445//  idpower = id->m;
2446//  givenideal = gid->m;
2447//  idpowerpoint = 0;
2448//  makepotence(IDELEMS(gid),1,deg,0);
2449//  idpower = NULL;
2450//  givenideal = NULL;
2451//  idpowerpoint = 0;
2452//  return id;
2453//}
2454static void idNextPotence(ideal given, ideal result,
2455  int begin, int end, int deg, int restdeg, poly ap)
2456{
2457  poly p;
2458  int i;
2459
2460  p = pPower(pCopy(given->m[begin]),restdeg);
2461  i = result->nrows;
2462  result->m[i] = pMult(pCopy(ap),p);
2463//PrintS(".");
2464  (result->nrows)++;
2465  if (result->nrows >= IDELEMS(result))
2466  {
2467    pEnlargeSet(&(result->m),IDELEMS(result),16);
2468    IDELEMS(result) += 16;
2469  }
2470  if (begin == end) return;
2471  for (i=restdeg-1;i>0;i--)
2472  {
2473    p = pPower(pCopy(given->m[begin]),i);
2474    p = pMult(pCopy(ap),p);
2475    idNextPotence(given, result, begin+1, end, deg, restdeg-i, p);
2476    pDelete(&p);
2477  }
2478  idNextPotence(given, result, begin+1, end, deg, restdeg, ap);
2479}
2480
2481ideal idPower(ideal given,int exp)
2482{
2483  ideal result,temp;
2484  poly p1;
2485  int i;
2486
2487  if (idIs0(given)) return idInit(1,1);
2488  temp = idCopy(given);
2489  idSkipZeroes(temp);
2490  i = binom(IDELEMS(temp)+exp-1,exp);
2491  result = idInit(i,1);
2492  result->nrows = 0;
2493//Print("ideal contains %d elements\n",i);
2494  p1=pOne();
2495  idNextPotence(temp,result,0,IDELEMS(temp)-1,exp,exp,p1);
2496  pDelete(&p1);
2497  idDelete(&temp);
2498  result->nrows = 1;
2499  idDelEquals(result);
2500  idSkipZeroes(result);
2501  return result;
2502}
2503
2504/*2
2505* eliminate delVar (product of vars) in h1
2506*/
2507ideal idElimination (ideal h1,poly delVar,intvec *hilb)
2508{
2509  int    i,j=0,k,l;
2510  ideal  h,hh, h3;
2511  int    *ord,*block0,*block1;
2512  int    ordersize=2;
2513  int    **wv;
2514  tHomog hom;
2515  intvec * w;
2516  ring tmpR;
2517  ring origR = currRing;
2518
2519  if (delVar==NULL)
2520  {
2521    return idCopy(h1);
2522  }
2523  if ((currQuotient!=NULL) && rIsPluralRing(origR))
2524  {
2525    WerrorS("cannot eliminate in a qring");
2526    return idCopy(h1);
2527  }
2528  if (idIs0(h1)) return idInit(1,h1->rank);
2529#ifdef HAVE_PLURAL
2530  if (rIsPluralRing(origR))
2531    /* in the NC case, we have to check the admissibility of */
2532    /* the subalgebra to be intersected with */
2533  {
2534    if ((ncRingType(origR) != nc_skew) && (ncRingType(origR) != nc_exterior)) /* in (quasi)-commutative algebras every subalgebra is admissible */
2535    {
2536      if (nc_CheckSubalgebra(delVar,origR))
2537      {
2538        WerrorS("no elimination is possible: subalgebra is not admissible");
2539        return idCopy(h1);
2540      }
2541    }
2542  }
2543#endif
2544  hom=(tHomog)idHomModule(h1,NULL,&w); //sets w to weight vector or NULL
2545  h3=idInit(16,h1->rank);
2546  for (k=0;; k++)
2547  {
2548    if (origR->order[k]!=0) ordersize++;
2549    else break;
2550  }
2551#if 0
2552  if (rIsPluralRing(origR)) // we have too keep the odering: it may be needed
2553                            // for G-algebra
2554  {
2555    for (k=0;k<ordersize-1; k++)
2556    {
2557      block0[k+1] = origR->block0[k];
2558      block1[k+1] = origR->block1[k];
2559      ord[k+1] = origR->order[k];
2560      if (origR->wvhdl[k]!=NULL) wv[k+1] = (int*) omMemDup(origR->wvhdl[k]);
2561    }
2562  }
2563  else
2564  {
2565    block0[1] = 1;
2566    block1[1] = pVariables;
2567    if (origR->OrdSgn==1) ord[1] = ringorder_wp;
2568    else                  ord[1] = ringorder_ws;
2569    wv[1]=(int*)omAlloc0(pVariables*sizeof(int));
2570    double wNsqr = (double)2.0 / (double)pVariables;
2571    wFunctional = wFunctionalBuch;
2572    int  *x= (int * )omAlloc(2 * (pVariables + 1) * sizeof(int));
2573    int sl=IDELEMS(h1) - 1;
2574    wCall(h1->m, sl, x, wNsqr);
2575    for (sl = pVariables; sl!=0; sl--)
2576      wv[1][sl-1] = x[sl + pVariables + 1];
2577    omFreeSize((ADDRESS)x, 2 * (pVariables + 1) * sizeof(int));
2578
2579    ord[2]=ringorder_C;
2580    ord[3]=0;
2581  }
2582#else
2583#endif
2584  if ((hom==TRUE) && (origR->OrdSgn==1) && (!rIsPluralRing(origR)))
2585  {
2586    #if 1
2587    // we change to an ordering:
2588    // aa(1,1,1,...,0,0,0),wp(...),C
2589    // this seems to be better than version 2 below,
2590    // according to Tst/../elimiate_[3568].tat (- 17 %)
2591    ord=(int*)omAlloc0(4*sizeof(int));
2592    block0=(int*)omAlloc0(4*sizeof(int));
2593    block1=(int*)omAlloc0(4*sizeof(int));
2594    wv=(int**) omAlloc0(4*sizeof(int**));
2595    block0[0] = block0[1] = 1;
2596    block1[0] = block1[1] = rVar(origR);
2597    wv[0]=(int*)omAlloc0((rVar(origR) + 1)*sizeof(int));
2598    // use this special ordering: like ringorder_a, except that pFDeg, pWeights
2599    // ignore it
2600    ord[0] = ringorder_aa;
2601    for (j=0;j<rVar(origR);j++)
2602      if (pGetExp(delVar,j+1)!=0) wv[0][j]=1;
2603    BOOLEAN wp=FALSE;
2604    for (j=0;j<rVar(origR);j++)
2605      if (pWeight(j+1,origR)!=1) { wp=TRUE;break; }
2606    if (wp)
2607    {
2608      wv[1]=(int*)omAlloc0((rVar(origR) + 1)*sizeof(int));
2609      for (j=0;j<rVar(origR);j++)
2610        wv[1][j]=pWeight(j+1,origR);
2611      ord[1] = ringorder_wp;
2612    }
2613    else
2614      ord[1] = ringorder_dp;
2615    #else
2616    // we change to an ordering:
2617    // a(w1,...wn),wp(1,...0.....),C
2618    ord=(int*)omAlloc0(4*sizeof(int));
2619    block0=(int*)omAlloc0(4*sizeof(int));
2620    block1=(int*)omAlloc0(4*sizeof(int));
2621    wv=(int**) omAlloc0(4*sizeof(int**));
2622    block0[0] = block0[1] = 1;
2623    block1[0] = block1[1] = rVar(origR);
2624    wv[0]=(int*)omAlloc0((rVar(origR) + 1)*sizeof(int));
2625    wv[1]=(int*)omAlloc0((rVar(origR) + 1)*sizeof(int));
2626    ord[0] = ringorder_a;
2627    for (j=0;j<rVar(origR);j++)
2628      wv[0][j]=pWeight(j+1,origR);
2629    ord[1] = ringorder_wp;
2630    for (j=0;j<rVar(origR);j++)
2631      if (pGetExp(delVar,j+1)!=0) wv[1][j]=1;
2632    #endif
2633    ord[2] = ringorder_C;
2634    ord[3] = 0;
2635  }
2636  else
2637  {
2638    // we change to an ordering:
2639    // aa(....),orig_ordering
2640    ord=(int*)omAlloc0(ordersize*sizeof(int));
2641    block0=(int*)omAlloc0(ordersize*sizeof(int));
2642    block1=(int*)omAlloc0(ordersize*sizeof(int));
2643    wv=(int**) omAlloc0(ordersize*sizeof(int**));
2644    for (k=0;k<ordersize-1; k++)
2645    {
2646      block0[k+1] = origR->block0[k];
2647      block1[k+1] = origR->block1[k];
2648      ord[k+1] = origR->order[k];
2649      if (origR->wvhdl[k]!=NULL) wv[k+1] = (int*) omMemDup(origR->wvhdl[k]);
2650    }
2651    block0[0] = 1;
2652    block1[0] = rVar(origR);
2653    wv[0]=(int*)omAlloc0((rVar(origR) + 1)*sizeof(int));
2654    for (j=0;j<rVar(origR);j++)
2655      if (pGetExp(delVar,j+1)!=0) wv[0][j]=1;
2656    // use this special ordering: like ringorder_a, except that pFDeg, pWeights
2657    // ignore it
2658    ord[0] = ringorder_aa;
2659  }
2660  // fill in tmp ring to get back the data later on
2661  tmpR  = rCopy0(origR,FALSE,FALSE); // qring==NULL
2662  //rUnComplete(tmpR);
2663  tmpR->p_Procs=NULL;
2664  tmpR->order = ord;
2665  tmpR->block0 = block0;
2666  tmpR->block1 = block1;
2667  tmpR->wvhdl = wv;
2668  rComplete(tmpR, 1);
2669
2670#ifdef HAVE_PLURAL
2671  /* update nc structure on tmpR */
2672  if (rIsPluralRing(origR))
2673  {
2674    if ( nc_rComplete(origR, tmpR, false) ) // no quotient ideal!
2675    {
2676      Werror("no elimination is possible: ordering condition is violated");
2677      // cleanup
2678      rDelete(tmpR);
2679      if (w!=NULL)
2680        delete w;
2681      return idCopy(h1);
2682    }
2683  }
2684#endif
2685  // change into the new ring
2686  //pChangeRing(pVariables,currRing->OrdSgn,ord,block0,block1,wv);
2687  rChangeCurrRing(tmpR);
2688
2689  //h = idInit(IDELEMS(h1),h1->rank);
2690  // fetch data from the old ring
2691  //for (k=0;k<IDELEMS(h1);k++) h->m[k] = prCopyR( h1->m[k], origR);
2692  h=idrCopyR(h1,origR,currRing);
2693  if (origR->qideal!=NULL)
2694  {
2695    WarnS("eliminate in q-ring: experimental");
2696    ideal q=idrCopyR(origR->qideal,origR,currRing);
2697    ideal s=idSimpleAdd(h,q);
2698    idDelete(&h);
2699    idDelete(&q);
2700    h=s;
2701  }
2702  // compute kStd
2703#if 1
2704  //rWrite(tmpR);PrintLn();
2705  BITSET save=test;
2706  //test |=1;
2707  //Print("h: %d gen, rk=%d\n",IDELEMS(h),h->rank);
2708  //extern char * showOption();
2709  //Print("%s\n",showOption());
2710  hh = kStd(h,NULL,hom,&w,hilb);
2711  test=save;
2712  idDelete(&h);
2713#else
2714  extern ideal kGroebner(ideal F, ideal Q);
2715  hh=kGroebner(h,NULL);
2716#endif
2717  // go back to the original ring
2718  rChangeCurrRing(origR);
2719  i = IDELEMS(hh)-1;
2720  while ((i >= 0) && (hh->m[i] == NULL)) i--;
2721  j = -1;
2722  // fetch data from temp ring
2723  for (k=0; k<=i; k++)
2724  {
2725    l=pVariables;
2726    while ((l>0) && (p_GetExp( hh->m[k],l,tmpR)*pGetExp(delVar,l)==0)) l--;
2727    if (l==0)
2728    {
2729      j++;
2730      if (j >= IDELEMS(h3))
2731      {
2732        pEnlargeSet(&(h3->m),IDELEMS(h3),16);
2733        IDELEMS(h3) += 16;
2734      }
2735      h3->m[j] = prMoveR( hh->m[k], tmpR);
2736      hh->m[k] = NULL;
2737    }
2738  }
2739  id_Delete(&hh, tmpR);
2740  idSkipZeroes(h3);
2741  rDelete(tmpR);
2742  if (w!=NULL)
2743    delete w;
2744  return h3;
2745}
2746
2747/*2
2748* compute the which-th ar-minor of the matrix a
2749*/
2750poly idMinor(matrix a, int ar, unsigned long which, ideal R)
2751{
2752  int     i,j,k,size;
2753  unsigned long curr;
2754  int *rowchoise,*colchoise;
2755  BOOLEAN rowch,colch;
2756  ideal result;
2757  matrix tmp;
2758  poly p,q;
2759
2760  i = binom(a->rows(),ar);
2761  j = binom(a->cols(),ar);
2762
2763  rowchoise=(int *)omAlloc(ar*sizeof(int));
2764  colchoise=(int *)omAlloc(ar*sizeof(int));
2765  if ((i>512) || (j>512) || (i*j >512)) size=512;
2766  else size=i*j;
2767  result=idInit(size,1);
2768  tmp=mpNew(ar,ar);
2769  k = 0; /* the index in result*/
2770  curr = 0; /* index of current minor */
2771  idInitChoise(ar,1,a->rows(),&rowch,rowchoise);
2772  while (!rowch)
2773  {
2774    idInitChoise(ar,1,a->cols(),&colch,colchoise);
2775    while (!colch)
2776    {
2777      if (curr == which)
2778      {
2779        for (i=1; i<=ar; i++)
2780        {
2781          for (j=1; j<=ar; j++)
2782          {
2783            MATELEM(tmp,i,j) = MATELEM(a,rowchoise[i-1],colchoise[j-1]);
2784          }
2785        }
2786        p = mpDetBareiss(tmp);
2787        if (p!=NULL)
2788        {
2789          if (R!=NULL)
2790          {
2791            q = p;
2792            p = kNF(R,currQuotient,q);
2793            pDelete(&q);
2794          }
2795          /*delete the matrix tmp*/
2796          for (i=1; i<=ar; i++)
2797          {
2798            for (j=1; j<=ar; j++) MATELEM(tmp,i,j) = NULL;
2799          }
2800          idDelete((ideal*)&tmp);
2801          omFreeSize((ADDRESS)rowchoise,ar*sizeof(int));
2802          omFreeSize((ADDRESS)colchoise,ar*sizeof(int));
2803          return (p);
2804        }
2805      }
2806      curr++;
2807      idGetNextChoise(ar,a->cols(),&colch,colchoise);
2808    }
2809    idGetNextChoise(ar,a->rows(),&rowch,rowchoise);
2810  }
2811  return (poly) 1;
2812}
2813
2814#ifdef WITH_OLD_MINOR
2815/*2
2816* compute all ar-minors of the matrix a
2817*/
2818ideal idMinors(matrix a, int ar, ideal R)
2819{
2820  int     i,j,k,size;
2821  int *rowchoise,*colchoise;
2822  BOOLEAN rowch,colch;
2823  ideal result;
2824  matrix tmp;
2825  poly p,q;
2826
2827  i = binom(a->rows(),ar);
2828  j = binom(a->cols(),ar);
2829
2830  rowchoise=(int *)omAlloc(ar*sizeof(int));
2831  colchoise=(int *)omAlloc(ar*sizeof(int));
2832  if ((i>512) || (j>512) || (i*j >512)) size=512;
2833  else size=i*j;
2834  result=idInit(size,1);
2835  tmp=mpNew(ar,ar);
2836  k = 0; /* the index in result*/
2837  idInitChoise(ar,1,a->rows(),&rowch,rowchoise);
2838  while (!rowch)
2839  {
2840    idInitChoise(ar,1,a->cols(),&colch,colchoise);
2841    while (!colch)
2842    {
2843      for (i=1; i<=ar; i++)
2844      {
2845        for (j=1; j<=ar; j++)
2846        {
2847          MATELEM(tmp,i,j) = MATELEM(a,rowchoise[i-1],colchoise[j-1]);
2848        }
2849      }
2850      p = mpDetBareiss(tmp);
2851      if (p!=NULL)
2852      {
2853        if (R!=NULL)
2854        {
2855          q = p;
2856          p = kNF(R,currQuotient,q);
2857          pDelete(&q);
2858        }
2859        if (p!=NULL)
2860        {
2861          if (k>=size)
2862          {
2863            pEnlargeSet(&result->m,size,32);
2864            size += 32;
2865          }
2866          result->m[k] = p;
2867          k++;
2868        }
2869      }
2870      idGetNextChoise(ar,a->cols(),&colch,colchoise);
2871    }
2872    idGetNextChoise(ar,a->rows(),&rowch,rowchoise);
2873  }
2874  /*delete the matrix tmp*/
2875  for (i=1; i<=ar; i++)
2876  {
2877    for (j=1; j<=ar; j++) MATELEM(tmp,i,j) = NULL;
2878  }
2879  idDelete((ideal*)&tmp);
2880  if (k==0)
2881  {
2882    k=1;
2883    result->m[0]=NULL;
2884  }
2885  omFreeSize((ADDRESS)rowchoise,ar*sizeof(int));
2886  omFreeSize((ADDRESS)colchoise,ar*sizeof(int));
2887  pEnlargeSet(&result->m,size,k-size);
2888  IDELEMS(result) = k;
2889  return (result);
2890}
2891#else
2892/*2
2893* compute all ar-minors of the matrix a
2894* the caller of mpRecMin
2895* the elements of the result are not in R (if R!=NULL)
2896*/
2897ideal idMinors(matrix a, int ar, ideal R)
2898{
2899  int elems=0;
2900  int r=a->nrows,c=a->ncols;
2901  int i;
2902  matrix b;
2903  ideal result,h;
2904  ring origR;
2905  ring tmpR;
2906  long bound;
2907
2908  if((ar<=0) || (ar>r) || (ar>c))
2909  {
2910    Werror("%d-th minor, matrix is %dx%d",ar,r,c);
2911    return NULL;
2912  }
2913  h = idMatrix2Module(mpCopy(a));
2914  bound = smExpBound(h,c,r,ar);
2915  idDelete(&h);
2916  tmpR=smRingChange(&origR,bound);
2917  b = mpNew(r,c);
2918  for (i=r*c-1;i>=0;i--)
2919  {
2920    if (a->m[i])
2921      b->m[i] = prCopyR(a->m[i],origR);
2922  }
2923  if (R!=NULL)
2924  {
2925    R = idrCopyR(R,origR);
2926    //if (ar>1) // otherwise done in mpMinorToResult
2927    //{
2928    //  matrix bb=(matrix)kNF(R,currQuotient,(ideal)b);
2929    //  bb->rank=b->rank; bb->nrows=b->nrows; bb->ncols=b->ncols;
2930    //  idDelete((ideal*)&b); b=bb;
2931    //}
2932  }
2933  result=idInit(32,1);
2934  if(ar>1) mpRecMin(ar-1,result,elems,b,r,c,NULL,R);
2935  else mpMinorToResult(result,elems,b,r,c,R);
2936  idDelete((ideal *)&b);
2937  if (R!=NULL) idDelete(&R);
2938  idSkipZeroes(result);
2939  rChangeCurrRing(origR);
2940  result = idrMoveR(result,tmpR);
2941  smKillModifiedRing(tmpR);
2942  idTest(result);
2943  return result;
2944}
2945#endif
2946
2947/*2
2948*skips all zeroes and double elements, searches also for units
2949*/
2950void idCompactify(ideal id)
2951{
2952  int i,j;
2953  BOOLEAN b=FALSE;
2954
2955  i = IDELEMS(id)-1;
2956  while ((! b) && (i>=0))
2957  {
2958    b=pIsUnit(id->m[i]);
2959    i--;
2960  }
2961  if (b)
2962  {
2963    for(i=IDELEMS(id)-1;i>=0;i--) pDelete(&id->m[i]);
2964    id->m[0]=pOne();
2965  }
2966  else
2967  {
2968    idDelMultiples(id);
2969  }
2970  idSkipZeroes(id);
2971}
2972
2973/*2
2974*returns TRUE if id1 is a submodule of id2
2975*/
2976BOOLEAN idIsSubModule(ideal id1,ideal id2)
2977{
2978  int i;
2979  poly p;
2980
2981  if (idIs0(id1)) return TRUE;
2982  for (i=0;i<IDELEMS(id1);i++)
2983  {
2984    if (id1->m[i] != NULL)
2985    {
2986      p = kNF(id2,currQuotient,id1->m[i]);
2987      if (p != NULL)
2988      {
2989        pDelete(&p);
2990        return FALSE;
2991      }
2992    }
2993  }
2994  return TRUE;
2995}
2996
2997/*2
2998* returns the ideals of initial terms
2999*/
3000ideal idHead(ideal h)
3001{
3002  ideal m = idInit(IDELEMS(h),h->rank);
3003  int i;
3004
3005  for (i=IDELEMS(h)-1;i>=0; i--)
3006  {
3007    if (h->m[i]!=NULL) m->m[i]=pHead(h->m[i]);
3008  }
3009  return m;
3010}
3011
3012ideal idHomogen(ideal h, int varnum)
3013{
3014  ideal m = idInit(IDELEMS(h),h->rank);
3015  int i;
3016
3017  for (i=IDELEMS(h)-1;i>=0; i--)
3018  {
3019    m->m[i]=pHomogen(h->m[i],varnum);
3020  }
3021  return m;
3022}
3023
3024/*------------------type conversions----------------*/
3025ideal idVec2Ideal(poly vec)
3026{
3027   ideal result=idInit(1,1);
3028   omFree((ADDRESS)result->m);
3029   result->m=NULL; // remove later
3030   pVec2Polys(vec, &(result->m), &(IDELEMS(result)));
3031   return result;
3032}
3033
3034#define NEW_STUFF
3035#ifndef NEW_STUFF
3036// converts mat to module, destroys mat
3037ideal idMatrix2Module(matrix mat)
3038{
3039  int mc=MATCOLS(mat);
3040  int mr=MATROWS(mat);
3041  ideal result = idInit(si_max(mc,1),si_max(mr,1));
3042  int i,j;
3043  poly h;
3044
3045  for(j=0;j<mc /*MATCOLS(mat)*/;j++) /* j is also index in result->m */
3046  {
3047    for (i=1;i<=mr /*MATROWS(mat)*/;i++)
3048    {
3049      h = MATELEM(mat,i,j+1);
3050      if (h!=NULL)
3051      {
3052        MATELEM(mat,i,j+1)=NULL;
3053        pSetCompP(h,i);
3054        result->m[j] = pAdd(result->m[j],h);
3055      }
3056    }
3057  }
3058  // obachman: need to clean this up
3059  idDelete((ideal*) &mat);
3060  return result;
3061}
3062#else
3063
3064#include <kernel/sbuckets.h>
3065
3066// converts mat to module, destroys mat
3067ideal idMatrix2Module(matrix mat)
3068{
3069  int mc=MATCOLS(mat);
3070  int mr=MATROWS(mat);
3071  ideal result = idInit(si_max(mc,1),si_max(mr,1));
3072  int i,j, l;
3073  poly h;
3074  poly p;
3075  sBucket_pt bucket = sBucketCreate(currRing);
3076
3077  for(j=0;j<mc /*MATCOLS(mat)*/;j++) /* j is also index in result->m */
3078  {
3079    for (i=1;i<=mr /*MATROWS(mat)*/;i++)
3080    {
3081      h = MATELEM(mat,i,j+1);
3082      if (h!=NULL)
3083      {
3084        l=pLength(h);
3085        MATELEM(mat,i,j+1)=NULL;
3086        p_SetCompP(h,i, currRing);
3087        sBucket_Merge_p(bucket, h, l);
3088      }
3089    }
3090    sBucketClearMerge(bucket, &(result->m[j]), &l);
3091  }
3092  sBucketDestroy(&bucket);
3093
3094  // obachman: need to clean this up
3095  idDelete((ideal*) &mat);
3096  return result;
3097}
3098#endif
3099
3100/*2
3101* converts a module into a matrix, destroyes the input
3102*/
3103matrix idModule2Matrix(ideal mod)
3104{
3105  matrix result = mpNew(mod->rank,IDELEMS(mod));
3106  int i,cp;
3107  poly p,h;
3108
3109  for(i=0;i<IDELEMS(mod);i++)
3110  {
3111    p=pReverse(mod->m[i]);
3112    mod->m[i]=NULL;
3113    while (p!=NULL)
3114    {
3115      h=p;
3116      pIter(p);
3117      pNext(h)=NULL;
3118//      cp = si_max(1,pGetComp(h));     // if used for ideals too
3119      cp = pGetComp(h);
3120      pSetComp(h,0);
3121      pSetmComp(h);
3122#ifdef TEST
3123      if (cp>mod->rank)
3124      {
3125        Print("## inv. rank %ld -> %d\n",mod->rank,cp);
3126        int k,l,o=mod->rank;
3127        mod->rank=cp;
3128        matrix d=mpNew(mod->rank,IDELEMS(mod));
3129        for (l=1; l<=o; l++)
3130        {
3131          for (k=1; k<=IDELEMS(mod); k++)
3132          {
3133            MATELEM(d,l,k)=MATELEM(result,l,k);
3134            MATELEM(result,l,k)=NULL;
3135          }
3136        }
3137        idDelete((ideal *)&result);
3138        result=d;
3139      }
3140#endif
3141      MATELEM(result,cp,i+1) = pAdd(MATELEM(result,cp,i+1),h);
3142    }
3143  }
3144  // obachman 10/99: added the following line, otherwise memory leack!
3145  idDelete(&mod);
3146  return result;
3147}
3148
3149matrix idModule2formatedMatrix(ideal mod,int rows, int cols)
3150{
3151  matrix result = mpNew(rows,cols);
3152  int i,cp,r=idRankFreeModule(mod),c=IDELEMS(mod);
3153  poly p,h;
3154
3155  if (r>rows) r = rows;
3156  if (c>cols) c = cols;
3157  for(i=0;i<c;i++)
3158  {
3159    p=pReverse(mod->m[i]);
3160    mod->m[i]=NULL;
3161    while (p!=NULL)
3162    {
3163      h=p;
3164      pIter(p);
3165      pNext(h)=NULL;
3166      cp = pGetComp(h);
3167      if (cp<=r)
3168      {
3169        pSetComp(h,0);
3170        pSetmComp(h);
3171        MATELEM(result,cp,i+1) = pAdd(MATELEM(result,cp,i+1),h);
3172      }
3173      else
3174        pDelete(&h);
3175    }
3176  }
3177  idDelete(&mod);
3178  return result;
3179}
3180
3181/*2
3182* substitute the n-th variable by the monomial e in id
3183* destroy id
3184*/
3185ideal  idSubst(ideal id, int n, poly e)
3186{
3187  int k=MATROWS((matrix)id)*MATCOLS((matrix)id);
3188  ideal res=(ideal)mpNew(MATROWS((matrix)id),MATCOLS((matrix)id));
3189
3190  res->rank = id->rank;
3191  for(k--;k>=0;k--)
3192  {
3193    res->m[k]=pSubst(id->m[k],n,e);
3194    id->m[k]=NULL;
3195  }
3196  idDelete(&id);
3197  return res;
3198}
3199
3200BOOLEAN idHomModule(ideal m, ideal Q, intvec **w)
3201{
3202  if (w!=NULL) *w=NULL;
3203  if ((Q!=NULL) && (!idHomIdeal(Q,NULL))) return FALSE;
3204  if (idIs0(m))
3205  {
3206    if (w!=NULL) (*w)=new intvec(m->rank);
3207    return TRUE;
3208  }
3209
3210  long cmax=1,order=0,ord,* diff,diffmin=32000;
3211  int *iscom;
3212  int i,j;
3213  poly p=NULL;
3214  pFDegProc d;
3215  if (pLexOrder && (currRing->order[0]==ringorder_lp))
3216     d=p_Totaldegree;
3217  else
3218     d=pFDeg;
3219  int length=IDELEMS(m);
3220  polyset P=m->m;
3221  polyset F=(polyset)omAlloc(length*sizeof(poly));
3222  for (i=length-1;i>=0;i--)
3223  {
3224    p=F[i]=P[i];
3225    cmax=si_max(cmax,(long)pMaxComp(p));
3226  }
3227  cmax++;
3228  diff = (long *)omAlloc0(cmax*sizeof(long));
3229  if (w!=NULL) *w=new intvec(cmax-1);
3230  iscom = (int *)omAlloc0(cmax*sizeof(int));
3231  i=0;
3232  while (i<=length)
3233  {
3234    if (i<length)
3235    {
3236      p=F[i];
3237      while ((p!=NULL) && (iscom[pGetComp(p)]==0)) pIter(p);
3238    }
3239    if ((p==NULL) && (i<length))
3240    {
3241      i++;
3242    }
3243    else
3244    {
3245      if (p==NULL) /* && (i==length) */
3246      {
3247        i=0;
3248        while ((i<length) && (F[i]==NULL)) i++;
3249        if (i>=length) break;
3250        p = F[i];
3251      }
3252      //if (pLexOrder && (currRing->order[0]==ringorder_lp))
3253      //  order=pTotaldegree(p);
3254      //else
3255      //  order = p->order;
3256      //  order = pFDeg(p,currRing);
3257      order = d(p,currRing) +diff[pGetComp(p)];
3258      //order += diff[pGetComp(p)];
3259      p = F[i];
3260//Print("Actual p=F[%d]: ",i);pWrite(p);
3261      F[i] = NULL;
3262      i=0;
3263    }
3264    while (p!=NULL)
3265    {
3266      if (pLexOrder && (currRing->order[0]==ringorder_lp))
3267        ord=pTotaldegree(p);
3268      else
3269      //  ord = p->order;
3270        ord = pFDeg(p,currRing);
3271      if (iscom[pGetComp(p)]==0)
3272      {
3273        diff[pGetComp(p)] = order-ord;
3274        iscom[pGetComp(p)] = 1;
3275/*
3276*PrintS("new diff: ");
3277*for (j=0;j<cmax;j++) Print("%d ",diff[j]);
3278*PrintLn();
3279*PrintS("new iscom: ");
3280*for (j=0;j<cmax;j++) Print("%d ",iscom[j]);
3281*PrintLn();
3282*Print("new set %d, order %d, ord %d, diff %d\n",pGetComp(p),order,ord,diff[pGetComp(p)]);
3283*/
3284      }
3285      else
3286      {
3287/*
3288*PrintS("new diff: ");
3289*for (j=0;j<cmax;j++) Print("%d ",diff[j]);
3290*PrintLn();
3291*Print("order %d, ord %d, diff %d\n",order,ord,diff[pGetComp(p)]);
3292*/
3293        if (order != (ord+diff[pGetComp(p)]))
3294        {
3295          omFreeSize((ADDRESS) iscom,cmax*sizeof(int));
3296          omFreeSize((ADDRESS) diff,cmax*sizeof(long));
3297          omFreeSize((ADDRESS) F,length*sizeof(poly));
3298          delete *w;*w=NULL;
3299          return FALSE;
3300        }
3301      }
3302      pIter(p);
3303    }
3304  }
3305  omFreeSize((ADDRESS) iscom,cmax*sizeof(int));
3306  omFreeSize((ADDRESS) F,length*sizeof(poly));
3307  for (i=1;i<cmax;i++) (**w)[i-1]=(int)(diff[i]);
3308  for (i=1;i<cmax;i++)
3309  {
3310    if (diff[i]<diffmin) diffmin=diff[i];
3311  }
3312  if (w!=NULL)
3313  {
3314    for (i=1;i<cmax;i++)
3315    {
3316      (**w)[i-1]=(int)(diff[i]-diffmin);
3317    }
3318  }
3319  omFreeSize((ADDRESS) diff,cmax*sizeof(long));
3320  return TRUE;
3321}
3322
3323BOOLEAN idTestHomModule(ideal m, ideal Q, intvec *w)
3324{
3325  if ((Q!=NULL) && (!idHomIdeal(Q,NULL)))  { PrintS(" Q not hom\n"); return FALSE;}
3326  if (idIs0(m)) return TRUE;
3327
3328  int cmax=-1;
3329  int i;
3330  poly p=NULL;
3331  int length=IDELEMS(m);
3332  polyset P=m->m;
3333  for (i=length-1;i>=0;i--)
3334  {
3335    p=P[i];
3336    if (p!=NULL) cmax=si_max(cmax,(int)pMaxComp(p)+1);
3337  }
3338  if (w != NULL)
3339  if (w->length()+1 < cmax)
3340  {
3341    // Print("length: %d - %d \n", w->length(),cmax);
3342    return FALSE;
3343  }
3344
3345  if(w!=NULL)
3346    pSetModDeg(w);
3347
3348  for (i=length-1;i>=0;i--)
3349  {
3350    p=P[i];
3351    poly q=p;
3352    if (p!=NULL)
3353    {
3354      int d=pFDeg(p,currRing);
3355      loop
3356      {
3357        pIter(p);
3358        if (p==NULL) break;
3359        if (d!=pFDeg(p,currRing))
3360        {
3361          //pWrite(q); wrp(p); Print(" -> %d - %d\n",d,pFDeg(p,currRing));
3362          if(w!=NULL)
3363            pSetModDeg(NULL);
3364          return FALSE;
3365        }
3366      }
3367    }
3368  }
3369
3370  if(w!=NULL)
3371    pSetModDeg(NULL);
3372
3373  return TRUE;
3374}
3375
3376ideal idJet(ideal i,int d)
3377{
3378  ideal r=idInit((i->nrows)*(i->ncols),i->rank);
3379  r->nrows = i-> nrows;
3380  r->ncols = i-> ncols;
3381  //r->rank = i-> rank;
3382  int k;
3383  for(k=(i->nrows)*(i->ncols)-1;k>=0; k--)
3384  {
3385    r->m[k]=ppJet(i->m[k],d);
3386  }
3387  return r;
3388}
3389
3390ideal idJetW(ideal i,int d, intvec * iv)
3391{
3392  ideal r=idInit(IDELEMS(i),i->rank);
3393  if (ecartWeights!=NULL)
3394  {
3395    WerrorS("cannot compute weighted jets now");
3396  }
3397  else
3398  {
3399    short *w=iv2array(iv);
3400    int k;
3401    for(k=0; k<IDELEMS(i); k++)
3402    {
3403      r->m[k]=ppJetW(i->m[k],d,w);
3404    }
3405    omFreeSize((ADDRESS)w,(pVariables+1)*sizeof(short));
3406  }
3407  return r;
3408}
3409
3410int idMinDegW(ideal M,intvec *w)
3411{
3412  int d=-1;
3413  for(int i=0;i<IDELEMS(M);i++)
3414  {
3415    int d0=pMinDeg(M->m[i],w);
3416    if(-1<d0&&(d0<d||d==-1))
3417      d=d0;
3418  }
3419  return d;
3420}
3421
3422ideal idSeries(int n,ideal M,matrix U,intvec *w)
3423{
3424  for(int i=IDELEMS(M)-1;i>=0;i--)
3425  {
3426    if(U==NULL)
3427      M->m[i]=pSeries(n,M->m[i],NULL,w);
3428    else
3429    {
3430      M->m[i]=pSeries(n,M->m[i],MATELEM(U,i+1,i+1),w);
3431      MATELEM(U,i+1,i+1)=NULL;
3432    }
3433  }
3434  if(U!=NULL)
3435    idDelete((ideal*)&U);
3436  return M;
3437}
3438
3439matrix idDiff(matrix i, int k)
3440{
3441  int e=MATCOLS(i)*MATROWS(i);
3442  matrix r=mpNew(MATROWS(i),MATCOLS(i));
3443  r->rank=i->rank;
3444  int j;
3445  for(j=0; j<e; j++)
3446  {
3447    r->m[j]=pDiff(i->m[j],k);
3448  }
3449  return r;
3450}
3451
3452matrix idDiffOp(ideal I, ideal J,BOOLEAN multiply)
3453{
3454  matrix r=mpNew(IDELEMS(I),IDELEMS(J));
3455  int i,j;
3456  for(i=0; i<IDELEMS(I); i++)
3457  {
3458    for(j=0; j<IDELEMS(J); j++)
3459    {
3460      MATELEM(r,i+1,j+1)=pDiffOp(I->m[i],J->m[j],multiply);
3461    }
3462  }
3463  return r;
3464}
3465
3466/*3
3467*handles for some ideal operations the ring/syzcomp managment
3468*returns all syzygies (componentwise-)shifted by -syzcomp
3469*or -syzcomp-1 (in case of ideals as input)
3470static ideal idHandleIdealOp(ideal arg,int syzcomp,int isIdeal=FALSE)
3471{
3472  ring orig_ring=currRing;
3473  ring syz_ring=rCurrRingAssure_SyzComp();
3474  rSetSyzComp(length);
3475
3476  ideal s_temp;
3477  if (orig_ring!=syz_ring)
3478    s_temp=idrMoveR_NoSort(arg,orig_ring);
3479  else
3480    s_temp=arg;
3481
3482  ideal s_temp1 = kStd(s_temp,currQuotient,testHomog,&w,NULL,length);
3483  if (w!=NULL) delete w;
3484
3485  if (syz_ring!=orig_ring)
3486  {
3487    idDelete(&s_temp);
3488    rChangeCurrRing(orig_ring);
3489  }
3490
3491  idDelete(&temp);
3492  ideal temp1=idRingCopy(s_temp1,syz_ring);
3493
3494  if (syz_ring!=orig_ring)
3495  {
3496    rChangeCurrRing(syz_ring);
3497    idDelete(&s_temp1);
3498    rChangeCurrRing(orig_ring);
3499    rKill(syz_ring);
3500  }
3501
3502  for (i=0;i<IDELEMS(temp1);i++)
3503  {
3504    if ((temp1->m[i]!=NULL)
3505    && (pGetComp(temp1->m[i])<=length))
3506    {
3507      pDelete(&(temp1->m[i]));
3508    }
3509    else
3510    {
3511      pShift(&(temp1->m[i]),-length);
3512    }
3513  }
3514  temp1->rank = rk;
3515  idSkipZeroes(temp1);
3516
3517  return temp1;
3518}
3519*/
3520/*2
3521* represents (h1+h2)/h2=h1/(h1 intersect h2)
3522*/
3523//ideal idModulo (ideal h2,ideal h1)
3524ideal idModulo (ideal h2,ideal h1, tHomog hom, intvec ** w)
3525{
3526  intvec *wtmp=NULL;
3527
3528  int i,j,k,rk,flength=0,slength,length;
3529  poly p,q;
3530
3531  if (idIs0(h2))
3532    return idFreeModule(si_max(1,h2->ncols));
3533  if (!idIs0(h1))
3534    flength = idRankFreeModule(h1);
3535  slength = idRankFreeModule(h2);
3536  length  = si_max(flength,slength);
3537  if (length==0)
3538  {
3539    length = 1;
3540  }
3541  ideal temp = idInit(IDELEMS(h2),length+IDELEMS(h2));
3542  if ((w!=NULL)&&((*w)!=NULL))
3543  {
3544    //Print("input weights:");(*w)->show(1);PrintLn();
3545    int d;
3546    int k;
3547    wtmp=new intvec(length+IDELEMS(h2));
3548    for (i=0;i<length;i++)
3549      ((*wtmp)[i])=(**w)[i];
3550    for (i=0;i<IDELEMS(h2);i++)
3551    {
3552      poly p=h2->m[i];
3553      if (p!=NULL)
3554      {
3555        d = pDeg(p);
3556        k= pGetComp(p);
3557        if (slength>0) k--;
3558        d +=((**w)[k]);
3559        ((*wtmp)[i+length]) = d;
3560      }
3561    }
3562    //Print("weights:");wtmp->show(1);PrintLn();
3563  }
3564  for (i=0;i<IDELEMS(h2);i++)
3565  {
3566    temp->m[i] = pCopy(h2->m[i]);
3567    q = pOne();
3568    pSetComp(q,i+1+length);
3569    pSetmComp(q);
3570    if(temp->m[i]!=NULL)
3571    {
3572      if (slength==0) pShift(&(temp->m[i]),1);
3573      p = temp->m[i];
3574      while (pNext(p)!=NULL) pIter(p);
3575      pNext(p) = q;
3576    }
3577    else
3578      temp->m[i]=q;
3579  }
3580  rk = k = IDELEMS(h2);
3581  if (!idIs0(h1))
3582  {
3583    pEnlargeSet(&(temp->m),IDELEMS(temp),IDELEMS(h1));
3584    IDELEMS(temp) += IDELEMS(h1);
3585    for (i=0;i<IDELEMS(h1);i++)
3586    {
3587      if (h1->m[i]!=NULL)
3588      {
3589        temp->m[k] = pCopy(h1->m[i]);
3590        if (flength==0) pShift(&(temp->m[k]),1);
3591        k++;
3592      }
3593    }
3594  }
3595
3596  ring orig_ring=currRing;
3597  ring syz_ring=rCurrRingAssure_SyzComp();
3598  rSetSyzComp(length);
3599  ideal s_temp;
3600
3601  if (syz_ring != orig_ring)
3602  {
3603    s_temp = idrMoveR_NoSort(temp, orig_ring);
3604  }
3605  else
3606  {
3607    s_temp = temp;
3608  }
3609
3610  idTest(s_temp);
3611  ideal s_temp1 = kStd(s_temp,currQuotient,hom,&wtmp,NULL,length);
3612
3613  //if (wtmp!=NULL)  Print("output weights:");wtmp->show(1);PrintLn();
3614  if ((w!=NULL) && (*w !=NULL) && (wtmp!=NULL))
3615  {
3616    delete *w;
3617    *w=new intvec(IDELEMS(h2));
3618    for (i=0;i<IDELEMS(h2);i++)
3619      ((**w)[i])=(*wtmp)[i+length];
3620  }
3621  if (wtmp!=NULL) delete wtmp;
3622
3623  for (i=0;i<IDELEMS(s_temp1);i++)
3624  {
3625    if ((s_temp1->m[i]!=NULL)
3626    && (pGetComp(s_temp1->m[i])<=length))
3627    {
3628      pDelete(&(s_temp1->m[i]));
3629    }
3630    else
3631    {
3632      pShift(&(s_temp1->m[i]),-length);
3633    }
3634  }
3635  s_temp1->rank = rk;
3636  idSkipZeroes(s_temp1);
3637
3638  if (syz_ring!=orig_ring)
3639  {
3640    rChangeCurrRing(orig_ring);
3641    s_temp1 = idrMoveR_NoSort(s_temp1, syz_ring);
3642    rKill(syz_ring);
3643    // Hmm ... here seems to be a memory leak
3644    // However, simply deleting it causes memory trouble
3645    // idDelete(&s_temp);
3646  }
3647  else
3648  {
3649    idDelete(&temp);
3650  }
3651  idTest(s_temp1);
3652  return s_temp1;
3653}
3654
3655int idElem(const ideal F)
3656{
3657  int i=0,j=IDELEMS(F)-1;
3658
3659  while(j>=0)
3660  {
3661    if ((F->m)[j]!=NULL) i++;
3662    j--;
3663  }
3664  return i;
3665}
3666
3667/*
3668*computes module-weights for liftings of homogeneous modules
3669*/
3670intvec * idMWLift(ideal mod,intvec * weights)
3671{
3672  if (idIs0(mod)) return new intvec(2);
3673  int i=IDELEMS(mod);
3674  while ((i>0) && (mod->m[i-1]==NULL)) i--;
3675  intvec *result = new intvec(i+1);
3676  while (i>0)
3677  {
3678    (*result)[i]=pFDeg(mod->m[i],currRing)+(*weights)[pGetComp(mod->m[i])];
3679  }
3680  return result;
3681}
3682
3683/*2
3684*sorts the kbase for idCoef* in a special way (lexicographically
3685*with x_max,...,x_1)
3686*/
3687ideal idCreateSpecialKbase(ideal kBase,intvec ** convert)
3688{
3689  int i;
3690  ideal result;
3691
3692  if (idIs0(kBase)) return NULL;
3693  result = idInit(IDELEMS(kBase),kBase->rank);
3694  *convert = idSort(kBase,FALSE);
3695  for (i=0;i<(*convert)->length();i++)
3696  {
3697    result->m[i] = pCopy(kBase->m[(**convert)[i]-1]);
3698  }
3699  return result;
3700}
3701
3702/*2
3703*returns the index of a given monom in the list of the special kbase
3704*/
3705int idIndexOfKBase(poly monom, ideal kbase)
3706{
3707  int j=IDELEMS(kbase);
3708
3709  while ((j>0) && (kbase->m[j-1]==NULL)) j--;
3710  if (j==0) return -1;
3711  int i=pVariables;
3712  while (i>0)
3713  {
3714    loop
3715    {
3716      if (pGetExp(monom,i)>pGetExp(kbase->m[j-1],i)) return -1;
3717      if (pGetExp(monom,i)==pGetExp(kbase->m[j-1],i)) break;
3718      j--;
3719      if (j==0) return -1;
3720    }
3721    if (i==1)
3722    {
3723      while(j>0)
3724      {
3725        if (pGetComp(monom)==pGetComp(kbase->m[j-1])) return j-1;
3726        if (pGetComp(monom)>pGetComp(kbase->m[j-1])) return -1;
3727        j--;
3728      }
3729    }
3730    i--;
3731  }
3732  return -1;
3733}
3734
3735/*2
3736*decomposes the monom in a part of coefficients described by the
3737*complement of how and a monom in variables occuring in how, the
3738*index of which in kbase is returned as integer pos (-1 if it don't
3739*exists)
3740*/
3741poly idDecompose(poly monom, poly how, ideal kbase, int * pos)
3742{
3743  int i;
3744  poly coeff=pOne(), base=pOne();
3745
3746  for (i=1;i<=pVariables;i++)
3747  {
3748    if (pGetExp(how,i)>0)
3749    {
3750      pSetExp(base,i,pGetExp(monom,i));
3751    }
3752    else
3753    {
3754      pSetExp(coeff,i,pGetExp(monom,i));
3755    }
3756  }
3757  pSetComp(base,pGetComp(monom));
3758  pSetm(base);
3759  pSetCoeff(coeff,nCopy(pGetCoeff(monom)));
3760  pSetm(coeff);
3761  *pos = idIndexOfKBase(base,kbase);
3762  if (*pos<0)
3763    pDelete(&coeff);
3764  pDelete(&base);
3765  return coeff;
3766}
3767
3768/*2
3769*returns a matrix A of coefficients with kbase*A=arg
3770*if all monomials in variables of how occur in kbase
3771*the other are deleted
3772*/
3773matrix idCoeffOfKBase(ideal arg, ideal kbase, poly how)
3774{
3775  matrix result;
3776  ideal tempKbase;
3777  poly p,q;
3778  intvec * convert;
3779  int i=IDELEMS(kbase),j=IDELEMS(arg),k,pos;
3780#if 0
3781  while ((i>0) && (kbase->m[i-1]==NULL)) i--;
3782  if (idIs0(arg))
3783    return mpNew(i,1);
3784  while ((j>0) && (arg->m[j-1]==NULL)) j--;
3785  result = mpNew(i,j);
3786#else
3787  result = mpNew(i, j);
3788  while ((j>0) && (arg->m[j-1]==NULL)) j--;
3789#endif
3790
3791  tempKbase = idCreateSpecialKbase(kbase,&convert);
3792  for (k=0;k<j;k++)
3793  {
3794    p = arg->m[k];
3795    while (p!=NULL)
3796    {
3797      q = idDecompose(p,how,tempKbase,&pos);
3798      if (pos>=0)
3799      {
3800        MATELEM(result,(*convert)[pos],k+1) =
3801            pAdd(MATELEM(result,(*convert)[pos],k+1),q);
3802      }
3803      else
3804        pDelete(&q);
3805      pIter(p);
3806    }
3807  }
3808  idDelete(&tempKbase);
3809  return result;
3810}
3811
3812/*3
3813* searches for units in the components of the module arg and
3814* returns the first one
3815*/
3816static int idReadOutUnits(ideal arg,int* comp)
3817{
3818  if (idIs0(arg)) return -1;
3819  int i=0,j, generator=-1;
3820  int rk_arg=arg->rank; //idRankFreeModule(arg);
3821  int * componentIsUsed =(int *)omAlloc((rk_arg+1)*sizeof(int));
3822  poly p,q;
3823
3824  while ((generator<0) && (i<IDELEMS(arg)))
3825  {
3826    memset(componentIsUsed,0,(rk_arg+1)*sizeof(int));
3827    p = arg->m[i];
3828    while (p!=NULL)
3829    {
3830      j = pGetComp(p);
3831      if (componentIsUsed[j]==0)
3832      {
3833        if (pLmIsConstantComp(p))
3834        {
3835          generator = i;
3836          componentIsUsed[j] = 1;
3837        }
3838        else
3839        {
3840          componentIsUsed[j] = -1;
3841        }
3842      }
3843      else if (componentIsUsed[j]>0)
3844      {
3845        (componentIsUsed[j])++;
3846      }
3847      pIter(p);
3848    }
3849    i++;
3850  }
3851  i = 0;
3852  *comp = -1;
3853  for (j=0;j<=rk_arg;j++)
3854  {
3855    if (componentIsUsed[j]>0)
3856    {
3857      if ((*comp==-1) || (componentIsUsed[j]<i))
3858      {
3859        *comp = j;
3860        i= componentIsUsed[j];
3861      }
3862    }
3863  }
3864  omFree(componentIsUsed);
3865  return generator;
3866}
3867
3868#if 0
3869static void idDeleteComp(ideal arg,int red_comp)
3870{
3871  int i,j;
3872  poly p;
3873
3874  for (i=IDELEMS(arg)-1;i>=0;i--)
3875  {
3876    p = arg->m[i];
3877    while (p!=NULL)
3878    {
3879      j = pGetComp(p);
3880      if (j>red_comp)
3881      {
3882        pSetComp(p,j-1);
3883        pSetm(p);
3884      }
3885      pIter(p);
3886    }
3887  }
3888  (arg->rank)--;
3889}
3890#endif
3891
3892static void idDeleteComps(ideal arg,int* red_comp,int del)
3893// red_comp is an array [0..args->rank]
3894{
3895  int i,j;
3896  poly p;
3897
3898  for (i=IDELEMS(arg)-1;i>=0;i--)
3899  {
3900    p = arg->m[i];
3901    while (p!=NULL)
3902    {
3903      j = pGetComp(p);
3904      if (red_comp[j]!=j)
3905      {
3906        pSetComp(p,red_comp[j]);
3907        pSetmComp(p);
3908      }
3909      pIter(p);
3910    }
3911  }
3912  (arg->rank) -= del;
3913}
3914
3915/*2
3916* returns the presentation of an isomorphic, minimally
3917* embedded  module (arg represents the quotient!)
3918*/
3919ideal idMinEmbedding(ideal arg,BOOLEAN inPlace, intvec **w)
3920{
3921  if (idIs0(arg)) return idInit(1,arg->rank);
3922  int i,next_gen,next_comp;
3923  ideal res=arg;
3924
3925  if (!inPlace) res = idCopy(arg);
3926  res->rank=si_max(res->rank,idRankFreeModule(res));
3927  int *red_comp=(int*)omAlloc((res->rank+1)*sizeof(int));
3928  for (i=res->rank;i>=0;i--) red_comp[i]=i;
3929
3930  int del=0;
3931  loop
3932  {
3933    next_gen = idReadOutUnits(res,&next_comp);
3934    if (next_gen<0) break;
3935    del++;
3936    syGaussForOne(res,next_gen,next_comp,0,IDELEMS(res));
3937    for(i=next_comp+1;i<=arg->rank;i++) red_comp[i]--;
3938    if ((w !=NULL)&&(*w!=NULL))
3939    {
3940      for(i=next_comp;i<(*w)->length();i++) (**w)[i-1]=(**w)[i];
3941    }
3942  }
3943
3944  idDeleteComps(res,red_comp,del);
3945  idSkipZeroes(res);
3946  omFree(red_comp);
3947
3948  if ((w !=NULL)&&(*w!=NULL) &&(del>0))
3949  {
3950    intvec *wtmp=new intvec((*w)->length()-del);
3951    for(i=0;i<res->rank;i++) (*wtmp)[i]=(**w)[i];
3952    delete *w;
3953    *w=wtmp;
3954  }
3955  return res;
3956}
3957
3958/*2
3959* transpose a module
3960*/
3961ideal idTransp(ideal a)
3962{
3963  int r = a->rank, c = IDELEMS(a);
3964  ideal b =  idInit(r,c);
3965
3966  for (int i=c; i>0; i--)
3967  {
3968    poly p=a->m[i-1];
3969    while(p!=NULL)
3970    {
3971      poly h=pHead(p);
3972      int co=pGetComp(h)-1;
3973      pSetComp(h,i);
3974      pSetmComp(h);
3975      b->m[co]=pAdd(b->m[co],h);
3976      pIter(p);
3977    }
3978  }
3979  return b;
3980}
3981
3982intvec * idQHomWeight(ideal id)
3983{
3984  poly head, tail;
3985  int k;
3986  int in=IDELEMS(id)-1, ready=0, all=0,
3987      coldim=pVariables, rowmax=2*coldim;
3988  if (in<0) return NULL;
3989  intvec *imat=new intvec(rowmax+1,coldim,0);
3990
3991  do
3992  {
3993    head = id->m[in--];
3994    if (head!=NULL)
3995    {
3996      tail = pNext(head);
3997      while (tail!=NULL)
3998      {
3999        all++;
4000        for (k=1;k<=coldim;k++)
4001          IMATELEM(*imat,all,k) = pGetExpDiff(head,tail,k);
4002        if (all==rowmax)
4003        {
4004          ivTriangIntern(imat, ready, all);
4005          if (ready==coldim)
4006          {
4007            delete imat;
4008            return NULL;
4009          }
4010        }
4011        pIter(tail);
4012      }
4013    }
4014  } while (in>=0);
4015  if (all>ready)
4016  {
4017    ivTriangIntern(imat, ready, all);
4018    if (ready==coldim)
4019    {
4020      delete imat;
4021      return NULL;
4022    }
4023  }
4024  intvec *result = ivSolveKern(imat, ready);
4025  delete imat;
4026  return result;
4027}
4028
4029BOOLEAN idIsZeroDim(ideal I)
4030{
4031  BOOLEAN *UsedAxis=(BOOLEAN *)omAlloc0(pVariables*sizeof(BOOLEAN));
4032  int i,n;
4033  poly po;
4034  BOOLEAN res=TRUE;
4035  for(i=IDELEMS(I)-1;i>=0;i--)
4036  {
4037    po=I->m[i];
4038    if ((po!=NULL) &&((n=pIsPurePower(po))!=0)) UsedAxis[n-1]=TRUE;
4039  }
4040  for(i=pVariables-1;i>=0;i--)
4041  {
4042    if(UsedAxis[i]==FALSE) {res=FALSE; break;} // not zero-dim.
4043  }
4044  omFreeSize(UsedAxis,pVariables*sizeof(BOOLEAN));
4045  return res;
4046}
4047
4048void idNormalize(ideal I)
4049{
4050  if (rField_has_simple_inverse()) return; /* Z/p, GF(p,n), R, long R/C */
4051  int i;
4052  poly p;
4053  for(i=IDELEMS(I)-1;i>=0;i--)
4054  {
4055    p=I->m[i] ;
4056    while(p!=NULL)
4057    {
4058      nNormalize(pGetCoeff(p));
4059      pIter(p);
4060    }
4061  }
4062}
4063
4064#include <kernel/clapsing.h>
4065
4066#ifdef HAVE_FACTORY
4067poly id_GCD(poly f, poly g, const ring r)
4068{
4069  ring save_r=currRing;
4070  rChangeCurrRing(r);
4071  ideal I=idInit(2,1); I->m[0]=f; I->m[1]=g;
4072  intvec *w = NULL;
4073  ideal S=idSyzygies(I,testHomog,&w);
4074  if (w!=NULL) delete w;
4075  poly gg=pTakeOutComp(&(S->m[0]),2);
4076  idDelete(&S);
4077  poly gcd_p=singclap_pdivide(f,gg);
4078  pDelete(&gg);
4079  rChangeCurrRing(save_r);
4080  return gcd_p;
4081}
4082#endif
4083
4084/*2
4085* xx,q: arrays of length 0..rl-1
4086* xx[i]: SB mod q[i]
4087* assume: char=0
4088* assume: q[i]!=0
4089* destroys xx
4090*/
4091#ifdef HAVE_FACTORY
4092ideal idChineseRemainder(ideal *xx, number *q, int rl)
4093{
4094  int cnt=IDELEMS(xx[0])*xx[0]->nrows;
4095  ideal result=idInit(cnt,xx[0]->rank);
4096  result->nrows=xx[0]->nrows; // for lifting matrices
4097  result->ncols=xx[0]->ncols; // for lifting matrices
4098  int i,j;
4099  poly r,h,hh,res_p;
4100  number *x=(number *)omAlloc(rl*sizeof(number));
4101  for(i=cnt-1;i>=0;i--)
4102  {
4103    res_p=NULL;
4104    loop
4105    {
4106      r=NULL;
4107      for(j=rl-1;j>=0;j--)
4108      {
4109        h=xx[j]->m[i];
4110        if ((h!=NULL)
4111        &&((r==NULL)||(pLmCmp(r,h)==-1)))
4112          r=h;
4113      }
4114      if (r==NULL) break;
4115      h=pHead(r);
4116      for(j=rl-1;j>=0;j--)
4117      {
4118        hh=xx[j]->m[i];
4119        if ((hh!=NULL) && (pLmCmp(r,hh)==0))
4120        {
4121          x[j]=pGetCoeff(hh);
4122          hh=pLmFreeAndNext(hh);
4123          xx[j]->m[i]=hh;
4124        }
4125        else
4126          x[j]=nlInit(0, currRing);
4127      }
4128      number n=nlChineseRemainder(x,q,rl);
4129      for(j=rl-1;j>=0;j--)
4130      {
4131        x[j]=NULL; // nlInit(0...) takes no memory
4132      }
4133      if (nlIsZero(n)) pDelete(&h);
4134      else
4135      {
4136        pSetCoeff(h,n);
4137        //Print("new mon:");pWrite(h);
4138        res_p=pAdd(res_p,h);
4139      }
4140    }
4141    result->m[i]=res_p;
4142  }
4143  omFree(x);
4144  for(i=rl-1;i>=0;i--) idDelete(&(xx[i]));
4145  omFree(xx);
4146  return result;
4147}
4148#endif
4149/* currently unsed:
4150ideal idChineseRemainder(ideal *xx, intvec *iv)
4151{
4152  int rl=iv->length();
4153  number *q=(number *)omAlloc(rl*sizeof(number));
4154  int i;
4155  for(i=0; i<rl; i++)
4156  {
4157    q[i]=nInit((*iv)[i]);
4158  }
4159  return idChineseRemainder(xx,q,rl);
4160}
4161*/
4162/*
4163 * lift ideal with coeffs over Z (mod N) to Q via Farey
4164 */
4165ideal idFarey(ideal x, number N)
4166{
4167  int cnt=IDELEMS(x)*x->nrows;
4168  ideal result=idInit(cnt,x->rank);
4169  result->nrows=x->nrows; // for lifting matrices
4170  result->ncols=x->ncols; // for lifting matrices
4171
4172  int i;
4173  for(i=cnt-1;i>=0;i--)
4174  {
4175    poly h=pCopy(x->m[i]);
4176    result->m[i]=h;
4177    while(h!=NULL)
4178    {
4179      number c=pGetCoeff(h);
4180      pSetCoeff0(h,nlFarey(c,N));
4181      nDelete(&c);
4182      pIter(h);
4183    }
4184    while((result->m[i]!=NULL)&&(nIsZero(pGetCoeff(result->m[i]))))
4185    {
4186      pLmDelete(&(result->m[i]));
4187    }
4188    h=result->m[i];
4189    while((h!=NULL) && (pNext(h)!=NULL))
4190    {
4191      if(nIsZero(pGetCoeff(pNext(h))))
4192      {
4193        pLmDelete(&pNext(h));
4194      }
4195      else pIter(h);
4196    }
4197  }
4198  return result;
4199}
4200
4201/*2
4202* transpose a module
4203* NOTE: just a version of "ideal idTransp(ideal)" which works within specified ring.
4204*/
4205ideal id_Transp(ideal a, const ring rRing)
4206{
4207  int r = a->rank, c = IDELEMS(a);
4208  ideal b =  idInit(r,c);
4209
4210  for (int i=c; i>0; i--)
4211  {
4212    poly p=a->m[i-1];
4213    while(p!=NULL)
4214    {
4215      poly h=p_Head(p, rRing);
4216      int co=p_GetComp(h, rRing)-1;
4217      p_SetComp(h, i, rRing);
4218      p_Setm(h, rRing);
4219      b->m[co] = p_Add_q(b->m[co], h, rRing);
4220      pIter(p);
4221    }
4222  }
4223  return b;
4224}
4225
4226
4227
4228/*2
4229* The following is needed to compute the image of certain map used in
4230* the computation of cohomologies via BGG
4231* let M = { w_1, ..., w_k }, k = size(M) == ncols(M), n = nvars(currRing).
4232* assuming that nrows(M) <= m*n; the procedure computes:
4233* transpose(M) * transpose( var(1) I_m | ... | var(n) I_m ) :== transpose(module{f_1, ... f_k}),
4234* where f_i = \sum_{j=1}^{m} (w_i, v_j) gen(j),  (w_i, v_j) is a `scalar` multiplication.
4235* that is, if w_i = (a^1_1, ... a^1_m) | (a^2_1, ..., a^2_m) | ... | (a^n_1, ..., a^n_m) then
4236
4237  (a^1_1, ... a^1_m) | (a^2_1, ..., a^2_m) | ... | (a^n_1, ..., a^n_m)
4238*  var_1  ... var_1  |  var_2  ...  var_2  | ... |  var_n  ...  var(n)
4239*  gen_1  ... gen_m  |  gen_1  ...  gen_m  | ... |  gen_1  ...  gen_m
4240+ =>
4241  f_i =
4242
4243   a^1_1 * var(1) * gen(1) + ... + a^1_m * var(1) * gen(m) +
4244   a^2_1 * var(2) * gen(1) + ... + a^2_m * var(2) * gen(m) +
4245                             ...
4246   a^n_1 * var(n) * gen(1) + ... + a^n_m * var(n) * gen(m);
4247
4248   NOTE: for every f_i we run only ONCE along w_i saving partial sums into a temporary array of polys of size m
4249*/
4250ideal id_TensorModuleMult(const int m, const ideal M, const ring rRing)
4251{
4252// #ifdef DEBU
4253//  WarnS("tensorModuleMult!!!!");
4254
4255  assume(m > 0);
4256  assume(M != NULL);
4257
4258  const int n = rRing->N;
4259
4260  assume(M->rank <= m * n);
4261
4262  const int k = IDELEMS(M);
4263
4264  ideal idTemp =  idInit(k,m); // = {f_1, ..., f_k }
4265
4266  for( int i = 0; i < k; i++ ) // for every w \in M
4267  {
4268    poly pTempSum = NULL;
4269
4270    poly w = M->m[i];
4271
4272    while(w != NULL) // for each term of w...
4273    {
4274      poly h = p_Head(w, rRing);
4275
4276      const int  gen = p_GetComp(h, rRing); // 1 ...
4277
4278      assume(gen > 0);
4279      assume(gen <= n*m);
4280
4281      // TODO: write a formula with %, / instead of while!
4282      /*
4283      int c = gen;
4284      int v = 1;
4285      while(c > m)
4286      {
4287        c -= m;
4288        v++;
4289      }
4290      */
4291
4292      int cc = gen % m;
4293      if( cc == 0) cc = m;
4294      int vv = 1 + (gen - cc) / m;
4295
4296//      assume( cc == c );
4297//      assume( vv == v );
4298
4299      //  1<= c <= m
4300      assume( cc > 0 );
4301      assume( cc <= m );
4302
4303      assume( vv > 0 );
4304      assume( vv <= n );
4305
4306      assume( (cc + (vv-1)*m) == gen );
4307
4308      p_IncrExp(h, vv, rRing); // h *= var(j) && //      p_AddExp(h, vv, 1, rRing);
4309      p_SetComp(h, cc, rRing);
4310
4311      p_Setm(h, rRing);         // addjust degree after the previous steps!
4312
4313      pTempSum = p_Add_q(pTempSum, h, rRing); // it is slow since h will be usually put to the back of pTempSum!!!
4314
4315      pIter(w);
4316    }
4317
4318    idTemp->m[i] = pTempSum;
4319  }
4320
4321  // simplify idTemp???
4322
4323  ideal idResult = id_Transp(idTemp, rRing);
4324
4325  id_Delete(&idTemp, rRing);
4326
4327  return(idResult);
4328}
Note: See TracBrowser for help on using the repository browser.