ipshell.cc
Go to the documentation of this file.
1 /****************************************
2 * Computer Algebra System SINGULAR *
3 ****************************************/
4 /*
5 * ABSTRACT:
6 */
7 
8 #include <kernel/mod2.h>
9 
10 #include <omalloc/omalloc.h>
11 
12 #include <factory/factory.h>
13 
14 #include <misc/options.h>
15 #include <misc/mylimits.h>
16 #include <misc/intvec.h>
17 #include <misc/prime.h>
18 
19 #include <coeffs/numbers.h>
20 #include <coeffs/coeffs.h>
21 
22 #include <coeffs/rmodulon.h>
23 #include <coeffs/longrat.h>
24 
25 #include <polys/monomials/ring.h>
26 #include <polys/monomials/maps.h>
27 
28 #include <polys/prCopy.h>
29 #include <polys/matpol.h>
30 
31 #include <polys/weight.h>
32 #include <polys/clapsing.h>
33 
34 
37 
38 #include <kernel/polys.h>
39 #include <kernel/ideals.h>
40 
43 
44 #include <kernel/GBEngine/syz.h>
45 #include <kernel/GBEngine/kstd1.h>
46 #include <kernel/GBEngine/kutil.h> // denominator_list
47 
50 
51 #include <kernel/spectrum/semic.h>
52 #include <kernel/spectrum/splist.h>
54 
56 
57 #include <Singular/lists.h>
58 #include <Singular/attrib.h>
59 #include <Singular/ipconv.h>
60 #include <Singular/links/silink.h>
61 #include <Singular/ipshell.h>
62 #include <Singular/maps_ip.h>
63 #include <Singular/tok.h>
64 #include <Singular/ipid.h>
65 #include <Singular/subexpr.h>
66 #include <Singular/fevoices.h>
67 #include <Singular/sdb.h>
68 
69 #include <math.h>
70 #include <ctype.h>
71 
72 #include <kernel/maps/gen_maps.h>
73 
74 #ifdef SINGULAR_4_2
75 #include <Singular/number2.h>
76 #include <coeffs/bigintmat.h>
77 #endif
80 const char *lastreserved=NULL;
81 
83 
84 /*0 implementation*/
85 
86 const char * iiTwoOps(int t)
87 {
88  if (t<127)
89  {
90  static char ch[2];
91  switch (t)
92  {
93  case '&':
94  return "and";
95  case '|':
96  return "or";
97  default:
98  ch[0]=t;
99  ch[1]='\0';
100  return ch;
101  }
102  }
103  switch (t)
104  {
105  case COLONCOLON: return "::";
106  case DOTDOT: return "..";
107  //case PLUSEQUAL: return "+=";
108  //case MINUSEQUAL: return "-=";
109  case MINUSMINUS: return "--";
110  case PLUSPLUS: return "++";
111  case EQUAL_EQUAL: return "==";
112  case LE: return "<=";
113  case GE: return ">=";
114  case NOTEQUAL: return "<>";
115  default: return Tok2Cmdname(t);
116  }
117 }
118 
119 int iiOpsTwoChar(const char *s)
120 {
121 /* not handling: &&, ||, ** */
122  if (s[1]=='\0') return s[0];
123  else if (s[2]!='\0') return 0;
124  switch(s[0])
125  {
126  case '.': if (s[1]=='.') return DOTDOT;
127  else return 0;
128  case ':': if (s[1]==':') return COLONCOLON;
129  else return 0;
130  case '-': if (s[1]=='-') return MINUSMINUS;
131  else return 0;
132  case '+': if (s[1]=='+') return PLUSPLUS;
133  else return 0;
134  case '=': if (s[1]=='=') return EQUAL_EQUAL;
135  else return 0;
136  case '<': if (s[1]=='=') return LE;
137  else if (s[1]=='>') return NOTEQUAL;
138  else return 0;
139  case '>': if (s[1]=='=') return GE;
140  else return 0;
141  case '!': if (s[1]=='=') return NOTEQUAL;
142  else return 0;
143  }
144  return 0;
145 }
146 
147 static void list1(const char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
148 {
149  char buffer[22];
150  int l;
151  char buf2[128];
152 
153  if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
154  else sprintf(buf2, "%s", IDID(h));
155 
156  Print("%s%-30.30s [%d] ",s,buf2,IDLEV(h));
157  if (h == currRingHdl) PrintS("*");
158  PrintS(Tok2Cmdname((int)IDTYP(h)));
159 
160  ipListFlag(h);
161  switch(IDTYP(h))
162  {
163  case ALIAS_CMD: Print(" for %s",IDID((idhdl)IDDATA(h))); break;
164  case INT_CMD: Print(" %d",IDINT(h)); break;
165  case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
166  case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
167  break;
168  case POLY_CMD:
169  case VECTOR_CMD:if (c)
170  {
171  PrintS(" ");wrp(IDPOLY(h));
172  if(IDPOLY(h) != NULL)
173  {
174  Print(", %d monomial(s)",pLength(IDPOLY(h)));
175  }
176  }
177  break;
178  case MODUL_CMD: Print(", rk %d", (int)(IDIDEAL(h)->rank));
179  case IDEAL_CMD: Print(", %u generator(s)",
180  IDELEMS(IDIDEAL(h))); break;
181  case MAP_CMD:
182  Print(" from %s",IDMAP(h)->preimage); break;
183  case MATRIX_CMD:Print(" %u x %u"
184  ,MATROWS(IDMATRIX(h))
185  ,MATCOLS(IDMATRIX(h))
186  );
187  break;
188  case PACKAGE_CMD:
189  paPrint(IDID(h),IDPACKAGE(h));
190  break;
191  case PROC_CMD: if((IDPROC(h)->libname!=NULL)
192  && (strlen(IDPROC(h)->libname)>0))
193  Print(" from %s",IDPROC(h)->libname);
194  if(IDPROC(h)->language==LANG_C)
195  PrintS(" (C)");
196  if(IDPROC(h)->is_static)
197  PrintS(" (static)");
198  break;
199  case STRING_CMD:
200  {
201  char *s;
202  l=strlen(IDSTRING(h));
203  memset(buffer,0,22);
204  strncpy(buffer,IDSTRING(h),si_min(l,20));
205  if ((s=strchr(buffer,'\n'))!=NULL)
206  {
207  *s='\0';
208  }
209  PrintS(" ");
210  PrintS(buffer);
211  if((s!=NULL) ||(l>20))
212  {
213  Print("..., %d char(s)",l);
214  }
215  break;
216  }
217  case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
218  break;
219  case RING_CMD:
220  if ((IDRING(h)==currRing) && (currRingHdl!=h))
221  PrintS("(*)"); /* this is an alias to currRing */
222 #ifdef RDEBUG
224  Print(" <%lx>",(long)(IDRING(h)));
225 #endif
226  break;
227 #ifdef SINGULAR_4_2
228  case CNUMBER_CMD:
229  { number2 n=(number2)IDDATA(h);
230  Print(" (%s)",nCoeffName(n->cf));
231  break;
232  }
233  case CMATRIX_CMD:
234  { bigintmat *b=(bigintmat*)IDDATA(h);
235  Print(" %d x %d (%s)",
236  b->rows(),b->cols(),
237  nCoeffName(b->basecoeffs()));
238  break;
239  }
240 #endif
241  /*default: break;*/
242  }
243  PrintLn();
244 }
245 
247 {
248  BOOLEAN oldShortOut = FALSE;
249 
250  if (currRing != NULL)
251  {
252  oldShortOut = currRing->ShortOut;
253  currRing->ShortOut = 1;
254  }
255  int t=v->Typ();
256  Print("// %s %s ",v->Name(),Tok2Cmdname(t));
257  switch (t)
258  {
259  case MAP_CMD:Print(" from %s\n",((map)(v->Data()))->preimage); break;
260  case INTMAT_CMD: Print(" %d x %d\n",((intvec*)(v->Data()))->rows(),
261  ((intvec*)(v->Data()))->cols()); break;
262  case MATRIX_CMD:Print(" %u x %u\n" ,
263  MATROWS((matrix)(v->Data())),
264  MATCOLS((matrix)(v->Data())));break;
265  case MODUL_CMD: Print(", rk %d\n", (int)(((ideal)(v->Data()))->rank));break;
266  case LIST_CMD: Print(", size %d\n",((lists)(v->Data()))->nr+1); break;
267 
268  case PROC_CMD:
269  case RING_CMD:
270  case IDEAL_CMD: PrintLn(); break;
271 
272  //case INT_CMD:
273  //case STRING_CMD:
274  //case INTVEC_CMD:
275  //case POLY_CMD:
276  //case VECTOR_CMD:
277  //case PACKAGE_CMD:
278 
279  default:
280  break;
281  }
282  v->Print();
283  if (currRing != NULL)
284  currRing->ShortOut = oldShortOut;
285 }
286 
287 static void killlocals0(int v, idhdl * localhdl, const ring r)
288 {
289  idhdl h = *localhdl;
290  while (h!=NULL)
291  {
292  int vv;
293  //Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
294  if ((vv=IDLEV(h))>0)
295  {
296  if (vv < v)
297  {
298  if (iiNoKeepRing)
299  {
300  //PrintS(" break\n");
301  return;
302  }
303  h = IDNEXT(h);
304  //PrintLn();
305  }
306  else //if (vv >= v)
307  {
308  idhdl nexth = IDNEXT(h);
309  killhdl2(h,localhdl,r);
310  h = nexth;
311  //PrintS("kill\n");
312  }
313  }
314  else
315  {
316  h = IDNEXT(h);
317  //PrintLn();
318  }
319  }
320 }
321 
322 void killlocals_rec(idhdl *root,int v, ring r)
323 {
324  idhdl h=*root;
325  while (h!=NULL)
326  {
327  if (IDLEV(h)>=v)
328  {
329 // Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
330  idhdl n=IDNEXT(h);
331  killhdl2(h,root,r);
332  h=n;
333  }
334  else if (IDTYP(h)==PACKAGE_CMD)
335  {
336  // Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
337  if (IDPACKAGE(h)!=basePack)
338  killlocals_rec(&(IDRING(h)->idroot),v,r);
339  h=IDNEXT(h);
340  }
341  else if (IDTYP(h)==RING_CMD)
342  {
343  if ((IDRING(h)!=NULL) && (IDRING(h)->idroot!=NULL))
344  // we have to test IDRING(h)!=NULL: qring Q=groebner(...): killlocals
345  {
346  // Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
347  killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
348  }
349  h=IDNEXT(h);
350  }
351  else
352  {
353 // Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
354  h=IDNEXT(h);
355  }
356  }
357 }
359 {
360  if (L==NULL) return FALSE;
361  BOOLEAN changed=FALSE;
362  int n=L->nr;
363  for(;n>=0;n--)
364  {
365  leftv h=&(L->m[n]);
366  void *d=h->data;
367  if ((h->rtyp==RING_CMD)
368  && (((ring)d)->idroot!=NULL))
369  {
370  if (d!=currRing) {changed=TRUE;rChangeCurrRing((ring)d);}
371  killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
372  }
373  else if (h->rtyp==LIST_CMD)
374  changed|=killlocals_list(v,(lists)d);
375  }
376  return changed;
377 }
378 void killlocals(int v)
379 {
380  BOOLEAN changed=FALSE;
381  idhdl sh=currRingHdl;
382  ring cr=currRing;
383  if (sh!=NULL) changed=((IDLEV(sh)<v) || (IDRING(sh)->ref>0));
384  //if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
385 
386  killlocals_rec(&(basePack->idroot),v,currRing);
387 
389  {
390  int t=iiRETURNEXPR.Typ();
391  if (/*iiRETURNEXPR.Typ()*/ t==RING_CMD)
392  {
394  if (((ring)h->data)->idroot!=NULL)
395  killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
396  }
397  else if (/*iiRETURNEXPR.Typ()*/ t==LIST_CMD)
398  {
400  changed |=killlocals_list(v,(lists)h->data);
401  }
402  }
403  if (changed)
404  {
406  if (currRingHdl==NULL)
407  currRing=NULL;
408  else if(cr!=currRing)
409  rChangeCurrRing(cr);
410  }
411 
412  if (myynest<=1) iiNoKeepRing=TRUE;
413  //Print("end killlocals >= %d\n",v);
414  //listall();
415 }
416 
417 void list_cmd(int typ, const char* what, const char *prefix,BOOLEAN iterate, BOOLEAN fullname)
418 {
419  package savePack=currPack;
420  idhdl h,start;
421  BOOLEAN all = typ<0;
422  BOOLEAN really_all=FALSE;
423 
424  if ( typ==0 )
425  {
426  if (strcmp(what,"all")==0)
427  {
428  if (currPack!=basePack)
429  list_cmd(-1,NULL,prefix,iterate,fullname); // list current package
430  really_all=TRUE;
431  h=basePack->idroot;
432  }
433  else
434  {
435  h = ggetid(what);
436  if (h!=NULL)
437  {
438  if (iterate) list1(prefix,h,TRUE,fullname);
439  if (IDTYP(h)==ALIAS_CMD) PrintS("A");
440  if ((IDTYP(h)==RING_CMD)
441  //|| (IDTYP(h)==PACKE_CMD)
442  )
443  {
444  h=IDRING(h)->idroot;
445  }
446  else if(IDTYP(h)==PACKAGE_CMD)
447  {
448  currPack=IDPACKAGE(h);
449  //Print("list_cmd:package\n");
450  all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
451  h=IDPACKAGE(h)->idroot;
452  }
453  else
454  {
455  currPack=savePack;
456  return;
457  }
458  }
459  else
460  {
461  Werror("%s is undefined",what);
462  currPack=savePack;
463  return;
464  }
465  }
466  all=TRUE;
467  }
468  else if (RingDependend(typ))
469  {
470  h = currRing->idroot;
471  }
472  else
473  h = IDROOT;
474  start=h;
475  while (h!=NULL)
476  {
477  if ((all
478  && (IDTYP(h)!=PROC_CMD)
479  &&(IDTYP(h)!=PACKAGE_CMD)
480  &&(IDTYP(h)!=CRING_CMD)
481  )
482  || (typ == IDTYP(h))
483  || ((IDTYP(h)==CRING_CMD) && (typ==RING_CMD))
484  )
485  {
486  list1(prefix,h,start==currRingHdl, fullname);
487  if ((IDTYP(h)==RING_CMD)
488  && (really_all || (all && (h==currRingHdl)))
489  && ((IDLEV(h)==0)||(IDLEV(h)==myynest)))
490  {
491  list_cmd(0,IDID(h),"// ",FALSE);
492  }
493  if (IDTYP(h)==PACKAGE_CMD && really_all)
494  {
495  package save_p=currPack;
496  currPack=IDPACKAGE(h);
497  list_cmd(0,IDID(h),"// ",FALSE);
498  currPack=save_p;
499  }
500  }
501  h = IDNEXT(h);
502  }
503  currPack=savePack;
504 }
505 
506 void test_cmd(int i)
507 {
508  int ii;
509 
510  if (i<0)
511  {
512  ii= -i;
513  if (ii < 32)
514  {
515  si_opt_1 &= ~Sy_bit(ii);
516  }
517  else if (ii < 64)
518  {
519  si_opt_2 &= ~Sy_bit(ii-32);
520  }
521  else
522  WerrorS("out of bounds\n");
523  }
524  else if (i<32)
525  {
526  ii=i;
527  if (Sy_bit(ii) & kOptions)
528  {
529  Warn("Gerhard, use the option command");
530  si_opt_1 |= Sy_bit(ii);
531  }
532  else if (Sy_bit(ii) & validOpts)
533  si_opt_1 |= Sy_bit(ii);
534  }
535  else if (i<64)
536  {
537  ii=i-32;
538  si_opt_2 |= Sy_bit(ii);
539  }
540  else
541  WerrorS("out of bounds\n");
542 }
543 
545 {
546  int rc = 0;
547  while (v!=NULL)
548  {
549  switch (v->Typ())
550  {
551  case INT_CMD:
552  case POLY_CMD:
553  case VECTOR_CMD:
554  case NUMBER_CMD:
555  rc++;
556  break;
557  case INTVEC_CMD:
558  case INTMAT_CMD:
559  rc += ((intvec *)(v->Data()))->length();
560  break;
561  case MATRIX_CMD:
562  case IDEAL_CMD:
563  case MODUL_CMD:
564  {
565  matrix mm = (matrix)(v->Data());
566  rc += mm->rows() * mm->cols();
567  }
568  break;
569  case LIST_CMD:
570  rc+=((lists)v->Data())->nr+1;
571  break;
572  default:
573  rc++;
574  }
575  v = v->next;
576  }
577  return rc;
578 }
579 
581 {
582  sleftv vf;
583  if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
584  {
585  WerrorS("link expected");
586  return TRUE;
587  }
588  si_link l=(si_link)vf.Data();
589  if (vf.next == NULL)
590  {
591  WerrorS("write: need at least two arguments");
592  return TRUE;
593  }
594 
595  BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
596  if (b)
597  {
598  const char *s;
599  if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
600  else s=sNoName;
601  Werror("cannot write to %s",s);
602  }
603  vf.CleanUp();
604  return b;
605 }
606 
607 leftv iiMap(map theMap, const char * what)
608 {
609  idhdl w,r;
610  leftv v;
611  int i;
612  nMapFunc nMap;
613 
614  r=IDROOT->get(theMap->preimage,myynest);
615  if ((currPack!=basePack)
616  &&((r==NULL) || ((r->typ != RING_CMD) )))
617  r=basePack->idroot->get(theMap->preimage,myynest);
618  if ((r==NULL) && (currRingHdl!=NULL)
619  && (strcmp(theMap->preimage,IDID(currRingHdl))==0))
620  {
621  r=currRingHdl;
622  }
623  if ((r!=NULL) && (r->typ == RING_CMD))
624  {
625  ring src_ring=IDRING(r);
626  if ((nMap=n_SetMap(src_ring->cf, currRing->cf))==NULL)
627  {
628  Werror("can not map from ground field of %s to current ground field",
629  theMap->preimage);
630  return NULL;
631  }
632  if (IDELEMS(theMap)<src_ring->N)
633  {
634  theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
635  IDELEMS(theMap)*sizeof(poly),
636  (src_ring->N)*sizeof(poly));
637  for(i=IDELEMS(theMap);i<src_ring->N;i++)
638  theMap->m[i]=NULL;
639  IDELEMS(theMap)=src_ring->N;
640  }
641  if (what==NULL)
642  {
643  WerrorS("argument of a map must have a name");
644  }
645  else if ((w=src_ring->idroot->get(what,myynest))!=NULL)
646  {
647  char *save_r=NULL;
649  sleftv tmpW;
650  memset(&tmpW,0,sizeof(sleftv));
651  tmpW.rtyp=IDTYP(w);
652  if (tmpW.rtyp==MAP_CMD)
653  {
654  tmpW.rtyp=IDEAL_CMD;
655  save_r=IDMAP(w)->preimage;
656  IDMAP(w)->preimage=0;
657  }
658  tmpW.data=IDDATA(w);
659  // check overflow
660  BOOLEAN overflow=FALSE;
661  if ((tmpW.rtyp==IDEAL_CMD)
662  || (tmpW.rtyp==MODUL_CMD)
663  || (tmpW.rtyp==MAP_CMD))
664  {
665  ideal id=(ideal)tmpW.data;
666  long *degs=(long*)omAlloc(IDELEMS(id)*sizeof(long));
667  for(int i=IDELEMS(id)-1;i>=0;i--)
668  {
669  poly p=id->m[i];
670  if (p!=NULL) degs[i]=p_Totaldegree(p,src_ring);
671  else degs[i]=0;
672  }
673  for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
674  {
675  if (theMap->m[j]!=NULL)
676  {
677  long deg_monexp=pTotaldegree(theMap->m[j]);
678 
679  for(int i=IDELEMS(id)-1;i>=0;i--)
680  {
681  poly p=id->m[i];
682  if ((p!=NULL) && (degs[i]!=0) &&
683  ((unsigned long)deg_monexp > (currRing->bitmask / ((unsigned long)degs[i])/2)))
684  {
685  overflow=TRUE;
686  break;
687  }
688  }
689  }
690  }
691  omFreeSize(degs,IDELEMS(id)*sizeof(long));
692  }
693  else if (tmpW.rtyp==POLY_CMD)
694  {
695  for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
696  {
697  if (theMap->m[j]!=NULL)
698  {
699  long deg_monexp=pTotaldegree(theMap->m[j]);
700  poly p=(poly)tmpW.data;
701  long deg=0;
702  if ((p!=NULL) && ((deg=p_Totaldegree(p,src_ring))!=0) &&
703  ((unsigned long)deg_monexp > (currRing->bitmask / ((unsigned long)deg)/2)))
704  {
705  overflow=TRUE;
706  break;
707  }
708  }
709  }
710  }
711  if (overflow)
712  Warn("possible OVERFLOW in map, max exponent is %ld",currRing->bitmask/2);
713 #if 0
714  if (((tmpW.rtyp==IDEAL_CMD)||(tmpW.rtyp==MODUL_CMD)) && idIs0(IDIDEAL(w)))
715  {
716  v->rtyp=tmpW.rtyp;
717  v->data=idInit(IDELEMS(IDIDEAL(w)),IDIDEAL(w)->rank);
718  }
719  else
720 #endif
721  {
722  if ((tmpW.rtyp==IDEAL_CMD)
723  ||(tmpW.rtyp==MODUL_CMD)
724  ||(tmpW.rtyp==MATRIX_CMD)
725  ||(tmpW.rtyp==MAP_CMD))
726  {
727  v->rtyp=tmpW.rtyp;
728  char *tmp = theMap->preimage;
729  theMap->preimage=(char*)1L;
730  // map gets 1 as its rank (as an ideal)
731  v->data=maMapIdeal(IDIDEAL(w), src_ring, (ideal)theMap, currRing,nMap);
732  theMap->preimage=tmp; // map gets its preimage back
733  }
734  if (v->data==NULL) /*i.e. not IDEAL_CMD/MODUL_CMD/MATRIX_CMD/MAP */
735  {
736  if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,src_ring,NULL,NULL,0,nMap))
737  {
738  Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
740  if (save_r!=NULL) IDMAP(w)->preimage=save_r;
741  return NULL;
742  }
743  }
744  }
745  if (save_r!=NULL)
746  {
747  IDMAP(w)->preimage=save_r;
748  IDMAP((idhdl)v)->preimage=omStrDup(save_r);
749  v->rtyp=MAP_CMD;
750  }
751  return v;
752  }
753  else
754  {
755  Werror("%s undefined in %s",what,theMap->preimage);
756  }
757  }
758  else
759  {
760  Werror("cannot find preimage %s",theMap->preimage);
761  }
762  return NULL;
763 }
764 
765 #ifdef OLD_RES
766 void iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
767  intvec ** weights)
768 {
769  lists L=liMakeResolv(r,length,rlen,typ0,weights);
770  int i=0;
771  idhdl h;
772  char * s=(char *)omAlloc(strlen(name)+5);
773 
774  while (i<=L->nr)
775  {
776  sprintf(s,"%s(%d)",name,i+1);
777  if (i==0)
778  h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
779  else
780  h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
781  if (h!=NULL)
782  {
783  h->data.uideal=(ideal)L->m[i].data;
784  h->attribute=L->m[i].attribute;
786  Print("//defining: %s as %d-th syzygy module\n",s,i+1);
787  }
788  else
789  {
790  idDelete((ideal *)&(L->m[i].data));
791  Warn("cannot define %s",s);
792  }
793  //L->m[i].data=NULL;
794  //L->m[i].rtyp=0;
795  //L->m[i].attribute=NULL;
796  i++;
797  }
798  omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
800  omFreeSize((ADDRESS)s,strlen(name)+5);
801 }
802 #endif
803 
804 //resolvente iiFindRes(char * name, int * len, int *typ0)
805 //{
806 // char *s=(char *)omAlloc(strlen(name)+5);
807 // int i=-1;
808 // resolvente r;
809 // idhdl h;
810 //
811 // do
812 // {
813 // i++;
814 // sprintf(s,"%s(%d)",name,i+1);
815 // h=currRing->idroot->get(s,myynest);
816 // } while (h!=NULL);
817 // *len=i-1;
818 // if (*len<=0)
819 // {
820 // Werror("no objects %s(1),.. found",name);
821 // omFreeSize((ADDRESS)s,strlen(name)+5);
822 // return NULL;
823 // }
824 // r=(ideal *)omAlloc(/*(len+1)*/ i*sizeof(ideal));
825 // memset(r,0,(*len)*sizeof(ideal));
826 // i=-1;
827 // *typ0=MODUL_CMD;
828 // while (i<(*len))
829 // {
830 // i++;
831 // sprintf(s,"%s(%d)",name,i+1);
832 // h=currRing->idroot->get(s,myynest);
833 // if (h->typ != MODUL_CMD)
834 // {
835 // if ((i!=0) || (h->typ!=IDEAL_CMD))
836 // {
837 // Werror("%s is not of type module",s);
838 // omFreeSize((ADDRESS)r,(*len)*sizeof(ideal));
839 // omFreeSize((ADDRESS)s,strlen(name)+5);
840 // return NULL;
841 // }
842 // *typ0=IDEAL_CMD;
843 // }
844 // if ((i>0) && (idIs0(r[i-1])))
845 // {
846 // *len=i-1;
847 // break;
848 // }
849 // r[i]=IDIDEAL(h);
850 // }
851 // omFreeSize((ADDRESS)s,strlen(name)+5);
852 // return r;
853 //}
854 
856 {
857  int i;
858  resolvente res=(ideal *)omAlloc0((l+1)*sizeof(ideal));
859 
860  for (i=0; i<l; i++)
861  if (r[i]!=NULL) res[i]=idCopy(r[i]);
862  return res;
863 }
864 
866 {
867  int len=0;
868  int typ0;
869  lists L=(lists)v->Data();
870  intvec *weights=(intvec*)atGet(v,"isHomog",INTVEC_CMD);
871  int add_row_shift = 0;
872  if (weights==NULL)
873  weights=(intvec*)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
874  if (weights!=NULL) add_row_shift=weights->min_in();
875  resolvente rr=liFindRes(L,&len,&typ0);
876  if (rr==NULL) return TRUE;
877  resolvente r=iiCopyRes(rr,len);
878 
879  syMinimizeResolvente(r,len,0);
880  omFreeSize((ADDRESS)rr,len*sizeof(ideal));
881  len++;
882  res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL,add_row_shift);
883  return FALSE;
884 }
885 
887 {
888  sleftv tmp;
889  memset(&tmp,0,sizeof(tmp));
890  tmp.rtyp=INT_CMD;
891  tmp.data=(void *)1;
892  if ((u->Typ()==IDEAL_CMD)
893  || (u->Typ()==MODUL_CMD))
894  return jjBETTI2_ID(res,u,&tmp);
895  else
896  return jjBETTI2(res,u,&tmp);
897 }
898 
900 {
902  l->Init(1);
903  l->m[0].rtyp=u->Typ();
904  l->m[0].data=u->Data();
905  attr *a=u->Attribute();
906  if (a!=NULL)
907  l->m[0].attribute=*a;
908  sleftv tmp2;
909  memset(&tmp2,0,sizeof(tmp2));
910  tmp2.rtyp=LIST_CMD;
911  tmp2.data=(void *)l;
912  BOOLEAN r=jjBETTI2(res,&tmp2,v);
913  l->m[0].data=NULL;
914  l->m[0].attribute=NULL;
915  l->m[0].rtyp=DEF_CMD;
916  l->Clean();
917  return r;
918 }
919 
921 {
922  resolvente r;
923  int len;
924  int reg,typ0;
925  lists l=(lists)u->Data();
926 
927  intvec *weights=NULL;
928  int add_row_shift=0;
929  intvec *ww=NULL;
930  if (l->nr>=0) ww=(intvec *)atGet(&(l->m[0]),"isHomog",INTVEC_CMD);
931  if (ww!=NULL)
932  {
933  weights=ivCopy(ww);
934  add_row_shift = ww->min_in();
935  (*weights) -= add_row_shift;
936  }
937  //Print("attr:%x\n",weights);
938 
939  r=liFindRes(l,&len,&typ0);
940  if (r==NULL) return TRUE;
941  intvec* res_im=syBetti(r,len,&reg,weights,(int)(long)v->Data());
942  res->data=(void*)res_im;
943  omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
944  //Print("rowShift: %d ",add_row_shift);
945  for(int i=1;i<=res_im->rows();i++)
946  {
947  if (IMATELEM(*res_im,1,i)==0) { add_row_shift--; }
948  else break;
949  }
950  //Print(" %d\n",add_row_shift);
951  atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
952  if (weights!=NULL) delete weights;
953  return FALSE;
954 }
955 
957 {
958  int len,reg,typ0;
959 
960  resolvente r=liFindRes(L,&len,&typ0);
961 
962  if (r==NULL)
963  return -2;
964  intvec *weights=NULL;
965  int add_row_shift=0;
966  intvec *ww=(intvec *)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
967  if (ww!=NULL)
968  {
969  weights=ivCopy(ww);
970  add_row_shift = ww->min_in();
971  (*weights) -= add_row_shift;
972  }
973  //Print("attr:%x\n",weights);
974 
975  intvec *dummy=syBetti(r,len,&reg,weights);
976  if (weights!=NULL) delete weights;
977  delete dummy;
978  omFreeSize((ADDRESS)r,len*sizeof(ideal));
979  return reg+1+add_row_shift;
980 }
981 
983 #define BREAK_LINE_LENGTH 80
984 void iiDebug()
985 {
986 #ifdef HAVE_SDB
987  sdb_flags=1;
988 #endif
989  Print("\n-- break point in %s --\n",VoiceName());
990  if (iiDebugMarker) VoiceBackTrack();
991  char * s;
992  iiDebugMarker=FALSE;
993  s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
994  loop
995  {
996  memset(s,0,80);
998  if (s[BREAK_LINE_LENGTH-1]!='\0')
999  {
1000  Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
1001  }
1002  else
1003  break;
1004  }
1005  if (*s=='\n')
1006  {
1007  iiDebugMarker=TRUE;
1008  }
1009 #if MDEBUG
1010  else if(strncmp(s,"cont;",5)==0)
1011  {
1012  iiDebugMarker=TRUE;
1013  }
1014 #endif /* MDEBUG */
1015  else
1016  {
1017  strcat( s, "\n;~\n");
1018  newBuffer(s,BT_execute);
1019  }
1020 }
1021 
1022 lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
1023 {
1024  int i;
1025  indset save;
1027 
1028  hexist = hInit(S, Q, &hNexist, currRing);
1029  if (hNexist == 0)
1030  {
1031  intvec *iv=new intvec(rVar(currRing));
1032  for(i=0; i<rVar(currRing); i++) (*iv)[i]=1;
1033  res->Init(1);
1034  res->m[0].rtyp=INTVEC_CMD;
1035  res->m[0].data=(intvec*)iv;
1036  return res;
1037  }
1038  else if (hisModule!=0)
1039  {
1040  res->Init(0);
1041  return res;
1042  }
1043  save = ISet = (indset)omAlloc0Bin(indlist_bin);
1044  hMu = 0;
1045  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
1046  hvar = (varset)omAlloc((rVar(currRing) + 1) * sizeof(int));
1047  hpure = (scmon)omAlloc((1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1048  hrad = hexist;
1049  hNrad = hNexist;
1050  radmem = hCreate(rVar(currRing) - 1);
1051  hCo = rVar(currRing) + 1;
1052  hNvar = rVar(currRing);
1053  hRadical(hrad, &hNrad, hNvar);
1054  hSupp(hrad, hNrad, hvar, &hNvar);
1055  if (hNvar)
1056  {
1057  hCo = hNvar;
1058  memset(hpure, 0, (rVar(currRing) + 1) * sizeof(long));
1059  hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
1060  hLexR(hrad, hNrad, hvar, hNvar);
1062  }
1063  if (hCo && (hCo < rVar(currRing)))
1064  {
1066  }
1067  if (hMu!=0)
1068  {
1069  ISet = save;
1070  hMu2 = 0;
1071  if (all && (hCo+1 < rVar(currRing)))
1072  {
1075  i=hMu+hMu2;
1076  res->Init(i);
1077  if (hMu2 == 0)
1078  {
1080  }
1081  }
1082  else
1083  {
1084  res->Init(hMu);
1085  }
1086  for (i=0;i<hMu;i++)
1087  {
1088  res->m[i].data = (void *)save->set;
1089  res->m[i].rtyp = INTVEC_CMD;
1090  ISet = save;
1091  save = save->nx;
1093  }
1094  omFreeBin((ADDRESS)save, indlist_bin);
1095  if (hMu2 != 0)
1096  {
1097  save = JSet;
1098  for (i=hMu;i<hMu+hMu2;i++)
1099  {
1100  res->m[i].data = (void *)save->set;
1101  res->m[i].rtyp = INTVEC_CMD;
1102  JSet = save;
1103  save = save->nx;
1105  }
1106  omFreeBin((ADDRESS)save, indlist_bin);
1107  }
1108  }
1109  else
1110  {
1111  res->Init(0);
1113  }
1114  hKill(radmem, rVar(currRing) - 1);
1115  omFreeSize((ADDRESS)hpure, (1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1116  omFreeSize((ADDRESS)hvar, (rVar(currRing) + 1) * sizeof(int));
1117  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1119  return res;
1120 }
1121 
1122 int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
1123 {
1124  BOOLEAN res=FALSE;
1125  const char *id = name->name;
1126 
1127  memset(sy,0,sizeof(sleftv));
1128  if ((name->name==NULL)||(isdigit(name->name[0])))
1129  {
1130  WerrorS("object to declare is not a name");
1131  res=TRUE;
1132  }
1133  else
1134  {
1135  if (t==QRING_CMD) t=RING_CMD; // qring is always RING_CMD
1136 
1137  if (TEST_V_ALLWARN
1138  && (name->rtyp!=0)
1139  && (name->rtyp!=IDHDL)
1140  && (currRingHdl!=NULL) && (IDLEV(currRingHdl)==myynest))
1141  {
1142  Warn("`%s` is %s in %s:%d:%s",name->name,Tok2Cmdname(name->rtyp),
1144  }
1145  {
1146  sy->data = (char *)enterid(id,lev,t,root,init_b);
1147  }
1148  if (sy->data!=NULL)
1149  {
1150  sy->rtyp=IDHDL;
1151  currid=sy->name=IDID((idhdl)sy->data);
1152  // name->name=NULL; /* used in enterid */
1153  //sy->e = NULL;
1154  if (name->next!=NULL)
1155  {
1157  res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
1158  }
1159  }
1160  else res=TRUE;
1161  }
1162  name->CleanUp();
1163  return res;
1164 }
1165 
1167 {
1168  attr at=NULL;
1169  if (iiCurrProc!=NULL)
1170  at=iiCurrProc->attribute->get("default_arg");
1171  if (at==NULL)
1172  return FALSE;
1173  sleftv tmp;
1174  memset(&tmp,0,sizeof(sleftv));
1175  tmp.rtyp=at->atyp;
1176  tmp.data=at->CopyA();
1177  return iiAssign(p,&tmp);
1178 }
1180 {
1181  // <string1...stringN>,<proc>
1182  // known: args!=NULL, l>=1
1183  int l=args->listLength();
1184  int ll=0;
1185  if (iiCurrArgs!=NULL) ll=iiCurrArgs->listLength();
1186  if (ll!=(l-1)) return FALSE;
1187  leftv h=args;
1188  short *t=(short*)omAlloc(l*sizeof(short));
1189  t[0]=l-1;
1190  int b;
1191  int i;
1192  for(i=1;i<l;i++,h=h->next)
1193  {
1194  if (h->Typ()!=STRING_CMD)
1195  {
1196  omFree(t);
1197  Werror("arg %d is not a string",i);
1198  return TRUE;
1199  }
1200  int tt;
1201  b=IsCmd((char *)h->Data(),tt);
1202  if(b) t[i]=tt;
1203  else
1204  {
1205  omFree(t);
1206  Werror("arg %d is not a type name",i);
1207  return TRUE;
1208  }
1209  }
1210  if (h->Typ()!=PROC_CMD)
1211  {
1212  omFree(t);
1213  Werror("last arg (%d) is not a proc",i);
1214  return TRUE;
1215  }
1216  b=iiCheckTypes(iiCurrArgs,t,0);
1217  omFree(t);
1218  if (b && (h->rtyp==IDHDL) && (h->e==NULL))
1219  {
1220  BOOLEAN err;
1221  //Print("branchTo: %s\n",h->Name());
1222  iiCurrProc=(idhdl)h->data;
1223  procinfo * pi=IDPROC(iiCurrProc);
1224  if( pi->data.s.body==NULL )
1225  {
1227  if (pi->data.s.body==NULL) return TRUE;
1228  }
1229  if ((pi->pack!=NULL)&&(currPack!=pi->pack))
1230  {
1231  currPack=pi->pack;
1234  //Print("set pack=%s\n",IDID(currPackHdl));
1235  }
1236  err=iiAllStart(pi,pi->data.s.body,BT_proc,pi->data.s.body_lineno-(iiCurrArgs==NULL));
1238  if (iiCurrArgs!=NULL)
1239  {
1240  if (!err) Warn("too many arguments for %s",IDID(iiCurrProc));
1241  iiCurrArgs->CleanUp();
1242  omFreeBin((ADDRESS)iiCurrArgs, sleftv_bin);
1243  iiCurrArgs=NULL;
1244  }
1245  return 2-err;
1246  }
1247  return FALSE;
1248 }
1250 {
1251  if (iiCurrArgs==NULL)
1252  {
1253  if (strcmp(p->name,"#")==0)
1254  return iiDefaultParameter(p);
1255  Werror("not enough arguments for proc %s",VoiceName());
1256  p->CleanUp();
1257  return TRUE;
1258  }
1259  leftv h=iiCurrArgs;
1260  leftv rest=h->next; /*iiCurrArgs is not NULL here*/
1261  BOOLEAN is_default_list=FALSE;
1262  if (strcmp(p->name,"#")==0)
1263  {
1264  is_default_list=TRUE;
1265  rest=NULL;
1266  }
1267  else
1268  {
1269  h->next=NULL;
1270  }
1271  BOOLEAN res=iiAssign(p,h);
1272  if (is_default_list)
1273  {
1274  iiCurrArgs=NULL;
1275  }
1276  else
1277  {
1278  iiCurrArgs=rest;
1279  }
1280  h->CleanUp();
1282  return res;
1283 }
1284 
1285 static BOOLEAN iiInternalExport (leftv v, int toLev)
1286 {
1287  idhdl h=(idhdl)v->data;
1288  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
1289  if (IDLEV(h)==0)
1290  {
1291  if (BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(h));
1292  }
1293  else
1294  {
1295  h=IDROOT->get(v->name,toLev);
1296  idhdl *root=&IDROOT;
1297  if ((h==NULL)&&(currRing!=NULL))
1298  {
1299  h=currRing->idroot->get(v->name,toLev);
1300  root=&currRing->idroot;
1301  }
1302  BOOLEAN keepring=FALSE;
1303  if ((h!=NULL)&&(IDLEV(h)==toLev))
1304  {
1305  if (IDTYP(h)==v->Typ())
1306  {
1307  if ((IDTYP(h)==RING_CMD)
1308  && (v->Data()==IDDATA(h)))
1309  {
1310  IDRING(h)->ref++;
1311  keepring=TRUE;
1312  IDLEV(h)=toLev;
1313  //WarnS("keepring");
1314  return FALSE;
1315  }
1316  if (BVERBOSE(V_REDEFINE))
1317  {
1318  Warn("redefining %s (%s)",IDID(h),my_yylinebuf);
1319  }
1320  if (iiLocalRing[0]==IDRING(h) && (!keepring)) iiLocalRing[0]=NULL;
1321  killhdl2(h,root,currRing);
1322  }
1323  else
1324  {
1325  return TRUE;
1326  }
1327  }
1328  h=(idhdl)v->data;
1329  IDLEV(h)=toLev;
1330  if (keepring) IDRING(h)->ref--;
1332  //Print("export %s\n",IDID(h));
1333  }
1334  return FALSE;
1335 }
1336 
1337 BOOLEAN iiInternalExport (leftv v, int toLev, package rootpack)
1338 {
1339  idhdl h=(idhdl)v->data;
1340  if(h==NULL)
1341  {
1342  Warn("'%s': no such identifier\n", v->name);
1343  return FALSE;
1344  }
1345  package frompack=v->req_packhdl;
1346  if (frompack==NULL) frompack=currPack;
1347  if ((RingDependend(IDTYP(h)))
1348  || ((IDTYP(h)==LIST_CMD)
1349  && (lRingDependend(IDLIST(h)))
1350  )
1351  )
1352  {
1353  //Print("// ==> Ringdependent set nesting to 0\n");
1354  return (iiInternalExport(v, toLev));
1355  }
1356  else
1357  {
1358  IDLEV(h)=toLev;
1359  v->req_packhdl=rootpack;
1360  if (h==frompack->idroot)
1361  {
1362  frompack->idroot=h->next;
1363  }
1364  else
1365  {
1366  idhdl hh=frompack->idroot;
1367  while ((hh!=NULL) && (hh->next!=h))
1368  hh=hh->next;
1369  if ((hh!=NULL) && (hh->next==h))
1370  hh->next=h->next;
1371  else
1372  {
1373  Werror("`%s` not found",v->Name());
1374  return TRUE;
1375  }
1376  }
1377  h->next=rootpack->idroot;
1378  rootpack->idroot=h;
1379  }
1380  return FALSE;
1381 }
1382 
1383 BOOLEAN iiExport (leftv v, int toLev)
1384 {
1385  BOOLEAN nok=FALSE;
1386  leftv r=v;
1387  while (v!=NULL)
1388  {
1389  if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
1390  {
1391  Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1392  nok=TRUE;
1393  }
1394  else
1395  {
1396  if(iiInternalExport(v, toLev))
1397  {
1398  r->CleanUp();
1399  return TRUE;
1400  }
1401  }
1402  v=v->next;
1403  }
1404  r->CleanUp();
1405  return nok;
1406 }
1407 
1408 /*assume root!=idroot*/
1409 BOOLEAN iiExport (leftv v, int toLev, package pack)
1410 {
1411 // if ((pack==basePack)&&(pack!=currPack))
1412 // { Warn("'exportto' to Top is depreciated in >>%s<<",my_yylinebuf);}
1413  BOOLEAN nok=FALSE;
1414  leftv rv=v;
1415  while (v!=NULL)
1416  {
1417  if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1418  )
1419  {
1420  Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1421  nok=TRUE;
1422  }
1423  else
1424  {
1425  idhdl old=pack->idroot->get( v->name,toLev);
1426  if (old!=NULL)
1427  {
1428  if ((pack==currPack) && (old==(idhdl)v->data))
1429  {
1430  if (BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(old));
1431  break;
1432  }
1433  else if (IDTYP(old)==v->Typ())
1434  {
1435  if (BVERBOSE(V_REDEFINE))
1436  {
1437  Warn("redefining %s (%s)",IDID(old),my_yylinebuf);
1438  }
1439  v->name=omStrDup(v->name);
1440  killhdl2(old,&(pack->idroot),currRing);
1441  }
1442  else
1443  {
1444  rv->CleanUp();
1445  return TRUE;
1446  }
1447  }
1448  //Print("iiExport: pack=%s\n",IDID(root));
1449  if(iiInternalExport(v, toLev, pack))
1450  {
1451  rv->CleanUp();
1452  return TRUE;
1453  }
1454  }
1455  v=v->next;
1456  }
1457  rv->CleanUp();
1458  return nok;
1459 }
1460 
1462 {
1463  if (currRing==NULL)
1464  {
1465  #ifdef SIQ
1466  if (siq<=0)
1467  {
1468  #endif
1469  if (RingDependend(i))
1470  {
1471  WerrorS("no ring active");
1472  return TRUE;
1473  }
1474  #ifdef SIQ
1475  }
1476  #endif
1477  }
1478  return FALSE;
1479 }
1480 
1481 poly iiHighCorner(ideal I, int ak)
1482 {
1483  int i;
1484  if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1485  poly po=NULL;
1487  {
1488  scComputeHC(I,currRing->qideal,ak,po);
1489  if (po!=NULL)
1490  {
1491  pGetCoeff(po)=nInit(1);
1492  for (i=rVar(currRing); i>0; i--)
1493  {
1494  if (pGetExp(po, i) > 0) pDecrExp(po,i);
1495  }
1496  pSetComp(po,ak);
1497  pSetm(po);
1498  }
1499  }
1500  else
1501  po=pOne();
1502  return po;
1503 }
1504 
1506 {
1507  if (p!=basePack)
1508  {
1509  idhdl t=basePack->idroot;
1510  while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
1511  if (t==NULL)
1512  {
1513  WarnS("package not found\n");
1514  p=basePack;
1515  }
1516  }
1517 }
1518 
1519 idhdl rDefault(const char *s)
1520 {
1521  idhdl tmp=NULL;
1522 
1523  if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
1524  if (tmp==NULL) return NULL;
1525 
1526 // if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
1528  {
1530  memset(&sLastPrinted,0,sizeof(sleftv));
1531  }
1532 
1533  ring r = IDRING(tmp) = (ring) omAlloc0Bin(sip_sring_bin);
1534 
1535  r->cf = nInitChar(n_Zp, (void*)32003); // r->cf->ch = 32003;
1536  r->N = 3;
1537  /*r->P = 0; Alloc0 in idhdl::set, ipid.cc*/
1538  /*names*/
1539  r->names = (char **) omAlloc0(3 * sizeof(char_ptr));
1540  r->names[0] = omStrDup("x");
1541  r->names[1] = omStrDup("y");
1542  r->names[2] = omStrDup("z");
1543  /*weights: entries for 3 blocks: NULL*/
1544  r->wvhdl = (int **)omAlloc0(3 * sizeof(int_ptr));
1545  /*order: dp,C,0*/
1546  r->order = (int *) omAlloc(3 * sizeof(int *));
1547  r->block0 = (int *)omAlloc0(3 * sizeof(int *));
1548  r->block1 = (int *)omAlloc0(3 * sizeof(int *));
1549  /* ringorder dp for the first block: var 1..3 */
1550  r->order[0] = ringorder_dp;
1551  r->block0[0] = 1;
1552  r->block1[0] = 3;
1553  /* ringorder C for the second block: no vars */
1554  r->order[1] = ringorder_C;
1555  /* the last block: everything is 0 */
1556  r->order[2] = 0;
1557 
1558  /* complete ring intializations */
1559  rComplete(r);
1560  rSetHdl(tmp);
1561  return currRingHdl;
1562 }
1563 
1565 {
1566  idhdl h=rSimpleFindHdl(r,IDROOT,n);
1567  if (h!=NULL) return h;
1568  if (IDROOT!=basePack->idroot) h=rSimpleFindHdl(r,basePack->idroot,n);
1569  if (h!=NULL) return h;
1571  while(p!=NULL)
1572  {
1573  if ((p->cPack!=basePack)
1574  && (p->cPack!=currPack))
1575  h=rSimpleFindHdl(r,p->cPack->idroot,n);
1576  if (h!=NULL) return h;
1577  p=p->next;
1578  }
1579  idhdl tmp=basePack->idroot;
1580  while (tmp!=NULL)
1581  {
1582  if (IDTYP(tmp)==PACKAGE_CMD)
1583  h=rSimpleFindHdl(r,IDPACKAGE(tmp)->idroot,n);
1584  if (h!=NULL) return h;
1585  tmp=IDNEXT(tmp);
1586  }
1587  return NULL;
1588 }
1589 
1590 void rDecomposeCF(leftv h,const ring r,const ring R)
1591 {
1593  L->Init(4);
1594  h->rtyp=LIST_CMD;
1595  h->data=(void *)L;
1596  // 0: char/ cf - ring
1597  // 1: list (var)
1598  // 2: list (ord)
1599  // 3: qideal
1600  // ----------------------------------------
1601  // 0: char/ cf - ring
1602  L->m[0].rtyp=INT_CMD;
1603  L->m[0].data=(void *)(long)r->cf->ch;
1604  // ----------------------------------------
1605  // 1: list (var)
1607  LL->Init(r->N);
1608  int i;
1609  for(i=0; i<r->N; i++)
1610  {
1611  LL->m[i].rtyp=STRING_CMD;
1612  LL->m[i].data=(void *)omStrDup(r->names[i]);
1613  }
1614  L->m[1].rtyp=LIST_CMD;
1615  L->m[1].data=(void *)LL;
1616  // ----------------------------------------
1617  // 2: list (ord)
1619  i=rBlocks(r)-1;
1620  LL->Init(i);
1621  i--;
1622  lists LLL;
1623  for(; i>=0; i--)
1624  {
1625  intvec *iv;
1626  int j;
1627  LL->m[i].rtyp=LIST_CMD;
1629  LLL->Init(2);
1630  LLL->m[0].rtyp=STRING_CMD;
1631  LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1632  if (r->block1[i]-r->block0[i] >=0 )
1633  {
1634  j=r->block1[i]-r->block0[i];
1635  if(r->order[i]==ringorder_M) j=(j+1)*(j+1)-1;
1636  iv=new intvec(j+1);
1637  if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1638  {
1639  for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1640  }
1641  else switch (r->order[i])
1642  {
1643  case ringorder_dp:
1644  case ringorder_Dp:
1645  case ringorder_ds:
1646  case ringorder_Ds:
1647  case ringorder_lp:
1648  for(;j>=0; j--) (*iv)[j]=1;
1649  break;
1650  default: /* do nothing */;
1651  }
1652  }
1653  else
1654  {
1655  iv=new intvec(1);
1656  }
1657  LLL->m[1].rtyp=INTVEC_CMD;
1658  LLL->m[1].data=(void *)iv;
1659  LL->m[i].data=(void *)LLL;
1660  }
1661  L->m[2].rtyp=LIST_CMD;
1662  L->m[2].data=(void *)LL;
1663  // ----------------------------------------
1664  // 3: qideal
1665  L->m[3].rtyp=IDEAL_CMD;
1666  if (nCoeff_is_transExt(R->cf))
1667  L->m[3].data=(void *)idInit(1,1);
1668  else
1669  {
1670  ideal q=idInit(IDELEMS(r->qideal));
1671  q->m[0]=p_Init(R);
1672  pSetCoeff0(q->m[0],(number)(r->qideal->m[0]));
1673  L->m[3].data=(void *)q;
1674 // I->m[0] = pNSet(R->minpoly);
1675  }
1676  // ----------------------------------------
1677 }
1678 static void rDecomposeC_41(leftv h,const coeffs C)
1679 /* field is R or C */
1680 {
1682  if (nCoeff_is_long_C(C)) L->Init(3);
1683  else L->Init(2);
1684  h->rtyp=LIST_CMD;
1685  h->data=(void *)L;
1686  // 0: char/ cf - ring
1687  // 1: list (var)
1688  // 2: list (ord)
1689  // ----------------------------------------
1690  // 0: char/ cf - ring
1691  L->m[0].rtyp=INT_CMD;
1692  L->m[0].data=(void *)0;
1693  // ----------------------------------------
1694  // 1:
1696  LL->Init(2);
1697  LL->m[0].rtyp=INT_CMD;
1698  LL->m[0].data=(void *)(long)si_max(C->float_len,SHORT_REAL_LENGTH/2);
1699  LL->m[1].rtyp=INT_CMD;
1700  LL->m[1].data=(void *)(long)si_max(C->float_len2,SHORT_REAL_LENGTH);
1701  L->m[1].rtyp=LIST_CMD;
1702  L->m[1].data=(void *)LL;
1703  // ----------------------------------------
1704  // 2: list (par)
1705  if (nCoeff_is_long_C(C))
1706  {
1707  L->m[2].rtyp=STRING_CMD;
1708  L->m[2].data=(void *)omStrDup(*n_ParameterNames(C));
1709  }
1710  // ----------------------------------------
1711 }
1712 static void rDecomposeC(leftv h,const ring R)
1713 /* field is R or C */
1714 {
1716  if (rField_is_long_C(R)) L->Init(3);
1717  else L->Init(2);
1718  h->rtyp=LIST_CMD;
1719  h->data=(void *)L;
1720  // 0: char/ cf - ring
1721  // 1: list (var)
1722  // 2: list (ord)
1723  // ----------------------------------------
1724  // 0: char/ cf - ring
1725  L->m[0].rtyp=INT_CMD;
1726  L->m[0].data=(void *)0;
1727  // ----------------------------------------
1728  // 1:
1730  LL->Init(2);
1731  LL->m[0].rtyp=INT_CMD;
1732  LL->m[0].data=(void *)(long)si_max(R->cf->float_len,SHORT_REAL_LENGTH/2);
1733  LL->m[1].rtyp=INT_CMD;
1734  LL->m[1].data=(void *)(long)si_max(R->cf->float_len2,SHORT_REAL_LENGTH);
1735  L->m[1].rtyp=LIST_CMD;
1736  L->m[1].data=(void *)LL;
1737  // ----------------------------------------
1738  // 2: list (par)
1739  if (rField_is_long_C(R))
1740  {
1741  L->m[2].rtyp=STRING_CMD;
1742  L->m[2].data=(void *)omStrDup(*rParameter(R));
1743  }
1744  // ----------------------------------------
1745 }
1746 
1747 #ifdef HAVE_RINGS
1749 /* field is R or C */
1750 {
1752  if (nCoeff_is_Ring(C)) L->Init(1);
1753  else L->Init(2);
1754  h->rtyp=LIST_CMD;
1755  h->data=(void *)L;
1756  // 0: char/ cf - ring
1757  // 1: list (module)
1758  // ----------------------------------------
1759  // 0: char/ cf - ring
1760  L->m[0].rtyp=STRING_CMD;
1761  L->m[0].data=(void *)omStrDup("integer");
1762  // ----------------------------------------
1763  // 1: modulo
1764  if (nCoeff_is_Ring_Z(C)) return;
1766  LL->Init(2);
1767  LL->m[0].rtyp=BIGINT_CMD;
1768  LL->m[0].data=nlMapGMP((number) C->modBase, C, coeffs_BIGINT);
1769  LL->m[1].rtyp=INT_CMD;
1770  LL->m[1].data=(void *) C->modExponent;
1771  L->m[1].rtyp=LIST_CMD;
1772  L->m[1].data=(void *)LL;
1773 }
1774 #endif
1775 
1776 void rDecomposeRing(leftv h,const ring R)
1777 /* field is R or C */
1778 {
1779 #ifdef HAVE_RINGS
1781  if (rField_is_Ring_Z(R)) L->Init(1);
1782  else L->Init(2);
1783  h->rtyp=LIST_CMD;
1784  h->data=(void *)L;
1785  // 0: char/ cf - ring
1786  // 1: list (module)
1787  // ----------------------------------------
1788  // 0: char/ cf - ring
1789  L->m[0].rtyp=STRING_CMD;
1790  L->m[0].data=(void *)omStrDup("integer");
1791  // ----------------------------------------
1792  // 1: module
1793  if (rField_is_Ring_Z(R)) return;
1795  LL->Init(2);
1796  LL->m[0].rtyp=BIGINT_CMD;
1797  LL->m[0].data=nlMapGMP((number) R->cf->modBase, R->cf, R->cf); // TODO: what is this?? // extern number nlMapGMP(number from, const coeffs src, const coeffs dst); // FIXME: replace with n_InitMPZ(R->cf->modBase, coeffs_BIGINT); ?
1798  LL->m[1].rtyp=INT_CMD;
1799  LL->m[1].data=(void *) R->cf->modExponent;
1800  L->m[1].rtyp=LIST_CMD;
1801  L->m[1].data=(void *)LL;
1802 #else
1803  WerrorS("rDecomposeRing");
1804 #endif
1805 }
1806 
1807 
1809 {
1810  assume( C != NULL );
1811 
1812  // sanity check: require currRing==r for rings with polynomial data
1813  if ( nCoeff_is_algExt(C) && (C != currRing->cf))
1814  {
1815  WerrorS("ring with polynomial data must be the base ring or compatible");
1816  return TRUE;
1817  }
1818  if (nCoeff_is_numeric(C))
1819  {
1820  rDecomposeC_41(res,C);
1821  }
1822 #ifdef HAVE_RINGS
1823  else if (nCoeff_is_Ring(C))
1824  {
1825  rDecomposeRing_41(res,C);
1826  }
1827 #endif
1828  else if ( C->extRing!=NULL )// nCoeff_is_algExt(r->cf))
1829  {
1830  rDecomposeCF(res, C->extRing, currRing);
1831  }
1832  else if(nCoeff_is_GF(C))
1833  {
1835  Lc->Init(4);
1836  // char:
1837  Lc->m[0].rtyp=INT_CMD;
1838  Lc->m[0].data=(void*)(long)C->m_nfCharQ;
1839  // var:
1841  Lv->Init(1);
1842  Lv->m[0].rtyp=STRING_CMD;
1843  Lv->m[0].data=(void *)omStrDup(*n_ParameterNames(C));
1844  Lc->m[1].rtyp=LIST_CMD;
1845  Lc->m[1].data=(void*)Lv;
1846  // ord:
1848  Lo->Init(1);
1850  Loo->Init(2);
1851  Loo->m[0].rtyp=STRING_CMD;
1852  Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
1853 
1854  intvec *iv=new intvec(1); (*iv)[0]=1;
1855  Loo->m[1].rtyp=INTVEC_CMD;
1856  Loo->m[1].data=(void *)iv;
1857 
1858  Lo->m[0].rtyp=LIST_CMD;
1859  Lo->m[0].data=(void*)Loo;
1860 
1861  Lc->m[2].rtyp=LIST_CMD;
1862  Lc->m[2].data=(void*)Lo;
1863  // q-ideal:
1864  Lc->m[3].rtyp=IDEAL_CMD;
1865  Lc->m[3].data=(void *)idInit(1,1);
1866  // ----------------------
1867  res->rtyp=LIST_CMD;
1868  res->data=(void*)Lc;
1869  }
1870  else
1871  {
1872  res->rtyp=INT_CMD;
1873  res->data=(void *)(long)C->ch;
1874  }
1875  // ----------------------------------------
1876  return FALSE;
1877 }
1878 
1880 {
1881  assume( r != NULL );
1882  const coeffs C = r->cf;
1883  assume( C != NULL );
1884 
1885  // sanity check: require currRing==r for rings with polynomial data
1886  if ( (r!=currRing) && (
1887  (r->qideal != NULL)
1888 #ifdef HAVE_PLURAL
1889  || (rIsPluralRing(r))
1890 #endif
1891  )
1892  )
1893  {
1894  WerrorS("ring with polynomial data must be the base ring or compatible");
1895  return NULL;
1896  }
1897  // 0: char/ cf - ring
1898  // 1: list (var)
1899  // 2: list (ord)
1900  // 3: qideal
1901  // possibly:
1902  // 4: C
1903  // 5: D
1905  if (rIsPluralRing(r))
1906  L->Init(6);
1907  else
1908  L->Init(4);
1909  // ----------------------------------------
1910  // 0: char/ cf - ring
1911  L->m[0].rtyp=CRING_CMD;
1912  L->m[0].data=(char*)r->cf; r->cf->ref++;
1913  // ----------------------------------------
1914  // 1: list (var)
1916  LL->Init(r->N);
1917  int i;
1918  for(i=0; i<r->N; i++)
1919  {
1920  LL->m[i].rtyp=STRING_CMD;
1921  LL->m[i].data=(void *)omStrDup(r->names[i]);
1922  }
1923  L->m[1].rtyp=LIST_CMD;
1924  L->m[1].data=(void *)LL;
1925  // ----------------------------------------
1926  // 2: list (ord)
1928  i=rBlocks(r)-1;
1929  LL->Init(i);
1930  i--;
1931  lists LLL;
1932  for(; i>=0; i--)
1933  {
1934  intvec *iv;
1935  int j;
1936  LL->m[i].rtyp=LIST_CMD;
1938  LLL->Init(2);
1939  LLL->m[0].rtyp=STRING_CMD;
1940  LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1941 
1942  if(r->order[i] == ringorder_IS) // || r->order[i] == ringorder_s || r->order[i] == ringorder_S)
1943  {
1944  assume( r->block0[i] == r->block1[i] );
1945  const int s = r->block0[i];
1946  assume( -2 < s && s < 2);
1947 
1948  iv=new intvec(1);
1949  (*iv)[0] = s;
1950  }
1951  else if (r->block1[i]-r->block0[i] >=0 )
1952  {
1953  int bl=j=r->block1[i]-r->block0[i];
1954  if (r->order[i]==ringorder_M)
1955  {
1956  j=(j+1)*(j+1)-1;
1957  bl=j+1;
1958  }
1959  else if (r->order[i]==ringorder_am)
1960  {
1961  j+=r->wvhdl[i][bl+1];
1962  }
1963  iv=new intvec(j+1);
1964  if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1965  {
1966  for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
1967  }
1968  else switch (r->order[i])
1969  {
1970  case ringorder_dp:
1971  case ringorder_Dp:
1972  case ringorder_ds:
1973  case ringorder_Ds:
1974  case ringorder_lp:
1975  for(;j>=0; j--) (*iv)[j]=1;
1976  break;
1977  default: /* do nothing */;
1978  }
1979  }
1980  else
1981  {
1982  iv=new intvec(1);
1983  }
1984  LLL->m[1].rtyp=INTVEC_CMD;
1985  LLL->m[1].data=(void *)iv;
1986  LL->m[i].data=(void *)LLL;
1987  }
1988  L->m[2].rtyp=LIST_CMD;
1989  L->m[2].data=(void *)LL;
1990  // ----------------------------------------
1991  // 3: qideal
1992  L->m[3].rtyp=IDEAL_CMD;
1993  if (r->qideal==NULL)
1994  L->m[3].data=(void *)idInit(1,1);
1995  else
1996  L->m[3].data=(void *)idCopy(r->qideal);
1997  // ----------------------------------------
1998 #ifdef HAVE_PLURAL // NC! in rDecompose
1999  if (rIsPluralRing(r))
2000  {
2001  L->m[4].rtyp=MATRIX_CMD;
2002  L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2003  L->m[5].rtyp=MATRIX_CMD;
2004  L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2005  }
2006 #endif
2007  return L;
2008 }
2009 
2010 lists rDecompose(const ring r)
2011 {
2012  assume( r != NULL );
2013  const coeffs C = r->cf;
2014  assume( C != NULL );
2015 
2016  // sanity check: require currRing==r for rings with polynomial data
2017  if ( (r!=currRing) && (
2018  (nCoeff_is_algExt(C) && (C != currRing->cf))
2019  || (r->qideal != NULL)
2020 #ifdef HAVE_PLURAL
2021  || (rIsPluralRing(r))
2022 #endif
2023  )
2024  )
2025  {
2026  WerrorS("ring with polynomial data must be the base ring or compatible");
2027  return NULL;
2028  }
2029  // 0: char/ cf - ring
2030  // 1: list (var)
2031  // 2: list (ord)
2032  // 3: qideal
2033  // possibly:
2034  // 4: C
2035  // 5: D
2037  if (rIsPluralRing(r))
2038  L->Init(6);
2039  else
2040  L->Init(4);
2041  // ----------------------------------------
2042  // 0: char/ cf - ring
2043  if (rField_is_numeric(r))
2044  {
2045  rDecomposeC(&(L->m[0]),r);
2046  }
2047  else if (rField_is_Ring(r))
2048  {
2049  rDecomposeRing(&(L->m[0]),r);
2050  }
2051  else if ( r->cf->extRing!=NULL )// nCoeff_is_algExt(r->cf))
2052  {
2053  rDecomposeCF(&(L->m[0]), r->cf->extRing, r);
2054  }
2055  else if(rField_is_GF(r))
2056  {
2058  Lc->Init(4);
2059  // char:
2060  Lc->m[0].rtyp=INT_CMD;
2061  Lc->m[0].data=(void*)(long)r->cf->m_nfCharQ;
2062  // var:
2064  Lv->Init(1);
2065  Lv->m[0].rtyp=STRING_CMD;
2066  Lv->m[0].data=(void *)omStrDup(*rParameter(r));
2067  Lc->m[1].rtyp=LIST_CMD;
2068  Lc->m[1].data=(void*)Lv;
2069  // ord:
2071  Lo->Init(1);
2073  Loo->Init(2);
2074  Loo->m[0].rtyp=STRING_CMD;
2075  Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
2076 
2077  intvec *iv=new intvec(1); (*iv)[0]=1;
2078  Loo->m[1].rtyp=INTVEC_CMD;
2079  Loo->m[1].data=(void *)iv;
2080 
2081  Lo->m[0].rtyp=LIST_CMD;
2082  Lo->m[0].data=(void*)Loo;
2083 
2084  Lc->m[2].rtyp=LIST_CMD;
2085  Lc->m[2].data=(void*)Lo;
2086  // q-ideal:
2087  Lc->m[3].rtyp=IDEAL_CMD;
2088  Lc->m[3].data=(void *)idInit(1,1);
2089  // ----------------------
2090  L->m[0].rtyp=LIST_CMD;
2091  L->m[0].data=(void*)Lc;
2092  }
2093  else
2094  {
2095  L->m[0].rtyp=INT_CMD;
2096  L->m[0].data=(void *)(long)r->cf->ch;
2097  }
2098  // ----------------------------------------
2099  // 1: list (var)
2101  LL->Init(r->N);
2102  int i;
2103  for(i=0; i<r->N; i++)
2104  {
2105  LL->m[i].rtyp=STRING_CMD;
2106  LL->m[i].data=(void *)omStrDup(r->names[i]);
2107  }
2108  L->m[1].rtyp=LIST_CMD;
2109  L->m[1].data=(void *)LL;
2110  // ----------------------------------------
2111  // 2: list (ord)
2113  i=rBlocks(r)-1;
2114  LL->Init(i);
2115  i--;
2116  lists LLL;
2117  for(; i>=0; i--)
2118  {
2119  intvec *iv;
2120  int j;
2121  LL->m[i].rtyp=LIST_CMD;
2123  LLL->Init(2);
2124  LLL->m[0].rtyp=STRING_CMD;
2125  LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
2126 
2127  if(r->order[i] == ringorder_IS) // || r->order[i] == ringorder_s || r->order[i] == ringorder_S)
2128  {
2129  assume( r->block0[i] == r->block1[i] );
2130  const int s = r->block0[i];
2131  assume( -2 < s && s < 2);
2132 
2133  iv=new intvec(1);
2134  (*iv)[0] = s;
2135  }
2136  else if (r->block1[i]-r->block0[i] >=0 )
2137  {
2138  int bl=j=r->block1[i]-r->block0[i];
2139  if (r->order[i]==ringorder_M)
2140  {
2141  j=(j+1)*(j+1)-1;
2142  bl=j+1;
2143  }
2144  else if (r->order[i]==ringorder_am)
2145  {
2146  j+=r->wvhdl[i][bl+1];
2147  }
2148  iv=new intvec(j+1);
2149  if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
2150  {
2151  for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
2152  }
2153  else switch (r->order[i])
2154  {
2155  case ringorder_dp:
2156  case ringorder_Dp:
2157  case ringorder_ds:
2158  case ringorder_Ds:
2159  case ringorder_lp:
2160  for(;j>=0; j--) (*iv)[j]=1;
2161  break;
2162  default: /* do nothing */;
2163  }
2164  }
2165  else
2166  {
2167  iv=new intvec(1);
2168  }
2169  LLL->m[1].rtyp=INTVEC_CMD;
2170  LLL->m[1].data=(void *)iv;
2171  LL->m[i].data=(void *)LLL;
2172  }
2173  L->m[2].rtyp=LIST_CMD;
2174  L->m[2].data=(void *)LL;
2175  // ----------------------------------------
2176  // 3: qideal
2177  L->m[3].rtyp=IDEAL_CMD;
2178  if (r->qideal==NULL)
2179  L->m[3].data=(void *)idInit(1,1);
2180  else
2181  L->m[3].data=(void *)idCopy(r->qideal);
2182  // ----------------------------------------
2183 #ifdef HAVE_PLURAL // NC! in rDecompose
2184  if (rIsPluralRing(r))
2185  {
2186  L->m[4].rtyp=MATRIX_CMD;
2187  L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2188  L->m[5].rtyp=MATRIX_CMD;
2189  L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2190  }
2191 #endif
2192  return L;
2193 }
2194 
2195 void rComposeC(lists L, ring R)
2196 /* field is R or C */
2197 {
2198  // ----------------------------------------
2199  // 0: char/ cf - ring
2200  if ((L->m[0].rtyp!=INT_CMD) || (L->m[0].data!=(char *)0))
2201  {
2202  WerrorS("invalid coeff. field description, expecting 0");
2203  return;
2204  }
2205 // R->cf->ch=0;
2206  // ----------------------------------------
2207  // 1:
2208  if (L->m[1].rtyp!=LIST_CMD)
2209  {
2210  WerrorS("invalid coeff. field description, expecting precision list");
2211  return;
2212  }
2213  lists LL=(lists)L->m[1].data;
2214  if (((LL->nr!=2)
2215  || (LL->m[0].rtyp!=INT_CMD)
2216  || (LL->m[1].rtyp!=INT_CMD))
2217  && ((LL->nr!=1)
2218  || (LL->m[0].rtyp!=INT_CMD)))
2219  {
2220  WerrorS("invalid coeff. field description list");
2221  return;
2222  }
2223  int r1=(int)(long)LL->m[0].data;
2224  int r2=(int)(long)LL->m[1].data;
2225  if (L->nr==2) // complex
2226  R->cf = nInitChar(n_long_C, NULL);
2227  else if ((r1<=SHORT_REAL_LENGTH)
2228  && (r2=SHORT_REAL_LENGTH))
2229  R->cf = nInitChar(n_R, NULL);
2230  else
2231  {
2233  p->float_len=r1;
2234  p->float_len2=r2;
2235  R->cf = nInitChar(n_long_R, NULL);
2236  }
2237 
2238  if ((r1<=SHORT_REAL_LENGTH) // should go into nInitChar
2239  && (r2=SHORT_REAL_LENGTH))
2240  {
2241  R->cf->float_len=SHORT_REAL_LENGTH/2;
2242  R->cf->float_len2=SHORT_REAL_LENGTH;
2243  }
2244  else
2245  {
2246  R->cf->float_len=si_min(r1,32767);
2247  R->cf->float_len2=si_min(r2,32767);
2248  }
2249  // ----------------------------------------
2250  // 2: list (par)
2251  if (L->nr==2)
2252  {
2253  //R->cf->extRing->N=1;
2254  if (L->m[2].rtyp!=STRING_CMD)
2255  {
2256  WerrorS("invalid coeff. field description, expecting parameter name");
2257  return;
2258  }
2259  //(rParameter(R))=(char**)omAlloc0(rPar(R)*sizeof(char_ptr));
2260  rParameter(R)[0]=omStrDup((char *)L->m[2].data);
2261  }
2262  // ----------------------------------------
2263 }
2264 
2265 #ifdef HAVE_RINGS
2266 void rComposeRing(lists L, ring R)
2267 /* field is R or C */
2268 {
2269  // ----------------------------------------
2270  // 0: string: integer
2271  // no further entries --> Z
2272  mpz_ptr modBase = NULL;
2273  unsigned int modExponent = 1;
2274 
2275  modBase = (mpz_ptr) omAlloc(sizeof(mpz_t));
2276  if (L->nr == 0)
2277  {
2278  mpz_init_set_ui(modBase,0);
2279  modExponent = 1;
2280  }
2281  // ----------------------------------------
2282  // 1:
2283  else
2284  {
2285  if (L->m[1].rtyp!=LIST_CMD) WerrorS("invalid data, expecting list of numbers");
2286  lists LL=(lists)L->m[1].data;
2287  if ((LL->nr >= 0) && LL->m[0].rtyp == BIGINT_CMD)
2288  {
2289  number tmp= (number) LL->m[0].data; // never use CopyD() on list elements
2290  // assume that tmp is integer, not rational
2291  n_MPZ (modBase, tmp, coeffs_BIGINT);
2292  }
2293  else if (LL->nr >= 0 && LL->m[0].rtyp == INT_CMD)
2294  {
2295  mpz_init_set_ui(modBase,(unsigned long) LL->m[0].data);
2296  }
2297  else
2298  {
2299  mpz_init_set_ui(modBase,0);
2300  }
2301  if (LL->nr >= 1)
2302  {
2303  modExponent = (unsigned long) LL->m[1].data;
2304  }
2305  else
2306  {
2307  modExponent = 1;
2308  }
2309  }
2310  // ----------------------------------------
2311  if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_cmp_ui(modBase, 0) < 0))
2312  {
2313  WerrorS("Wrong ground ring specification (module is 1)");
2314  return;
2315  }
2316  if (modExponent < 1)
2317  {
2318  WerrorS("Wrong ground ring specification (exponent smaller than 1)");
2319  return;
2320  }
2321  // module is 0 ---> integers
2322  if (mpz_cmp_ui(modBase, 0) == 0)
2323  {
2324  R->cf=nInitChar(n_Z,NULL);
2325  }
2326  // we have an exponent
2327  else if (modExponent > 1)
2328  {
2329  //R->cf->ch = R->cf->modExponent;
2330  if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(unsigned long)))
2331  {
2332  /* this branch should be active for modExponent = 2..32 resp. 2..64,
2333  depending on the size of a long on the respective platform */
2334  R->cf=nInitChar(n_Z2m,(void*)(long)modExponent); // Use Z/2^ch
2335  omFreeSize (modBase, sizeof(mpz_t));
2336  }
2337  else
2338  {
2339  //ringtype 3
2340  ZnmInfo info;
2341  info.base= modBase;
2342  info.exp= modExponent;
2343  R->cf=nInitChar(n_Znm,(void*) &info);
2344  }
2345  }
2346  // just a module m > 1
2347  else
2348  {
2349  //ringtype = 2;
2350  //const int ch = mpz_get_ui(modBase);
2351  ZnmInfo info;
2352  info.base= modBase;
2353  info.exp= modExponent;
2354  R->cf=nInitChar(n_Zn,(void*) &info);
2355  }
2356 }
2357 #endif
2358 
2359 static void rRenameVars(ring R)
2360 {
2361  int i,j;
2362  BOOLEAN ch;
2363  do
2364  {
2365  ch=0;
2366  for(i=0;i<R->N-1;i++)
2367  {
2368  for(j=i+1;j<R->N;j++)
2369  {
2370  if (strcmp(R->names[i],R->names[j])==0)
2371  {
2372  ch=TRUE;
2373  Warn("name conflict var(%d) and var(%d): `%s`, rename to `@%s`",i+1,j+1,R->names[i],R->names[i]);
2374  omFree(R->names[j]);
2375  R->names[j]=(char *)omAlloc(2+strlen(R->names[i]));
2376  sprintf(R->names[j],"@%s",R->names[i]);
2377  }
2378  }
2379  }
2380  }
2381  while (ch);
2382  for(i=0;i<rPar(R); i++)
2383  {
2384  for(j=0;j<R->N;j++)
2385  {
2386  if (strcmp(rParameter(R)[i],R->names[j])==0)
2387  {
2388  Warn("name conflict par(%d) and var(%d): `%s`, renaming the VARIABLE to `@@(%d)`",i+1,j+1,R->names[j],i+1);
2389 // omFree(rParameter(R)[i]);
2390 // rParameter(R)[i]=(char *)omAlloc(10);
2391 // sprintf(rParameter(R)[i],"@@(%d)",i+1);
2392  omFree(R->names[j]);
2393  R->names[j]=(char *)omAlloc(10);
2394  sprintf(R->names[j],"@@(%d)",i+1);
2395  }
2396  }
2397  }
2398 }
2399 
2400 static inline BOOLEAN rComposeVar(const lists L, ring R)
2401 {
2402  assume(R!=NULL);
2403  if (L->m[1].Typ()==LIST_CMD)
2404  {
2405  lists v=(lists)L->m[1].Data();
2406  R->N = v->nr+1;
2407  if (R->N<=0)
2408  {
2409  WerrorS("no ring variables");
2410  return TRUE;
2411  }
2412  R->names = (char **)omAlloc0(R->N * sizeof(char_ptr));
2413  int i;
2414  for(i=0;i<R->N;i++)
2415  {
2416  if (v->m[i].Typ()==STRING_CMD)
2417  R->names[i]=omStrDup((char *)v->m[i].Data());
2418  else if (v->m[i].Typ()==POLY_CMD)
2419  {
2420  poly p=(poly)v->m[i].Data();
2421  int nr=pIsPurePower(p);
2422  if (nr>0)
2423  R->names[i]=omStrDup(currRing->names[nr-1]);
2424  else
2425  {
2426  Werror("var name %d must be a string or a ring variable",i+1);
2427  return TRUE;
2428  }
2429  }
2430  else
2431  {
2432  Werror("var name %d must be `string`",i+1);
2433  return TRUE;
2434  }
2435  }
2436  }
2437  else
2438  {
2439  WerrorS("variable must be given as `list`");
2440  return TRUE;
2441  }
2442  return FALSE;
2443 }
2444 
2445 static inline BOOLEAN rComposeOrder(const lists L, const BOOLEAN check_comp, ring R)
2446 {
2447  assume(R!=NULL);
2448  long bitmask=0L;
2449  if (L->m[2].Typ()==LIST_CMD)
2450  {
2451  lists v=(lists)L->m[2].Data();
2452  int n= v->nr+2;
2453  int j_in_R,j_in_L;
2454  // do we have an entry "L",... ?: set bitmask
2455  for (int j=0; j < n-1; j++)
2456  {
2457  if (v->m[j].Typ()==LIST_CMD)
2458  {
2459  lists vv=(lists)v->m[j].Data();
2460  if ((vv->nr==1)
2461  &&(vv->m[0].Typ()==STRING_CMD)
2462  &&(strcmp((char*)vv->m[0].Data(),"L")==0))
2463  {
2464  number nn=(number)vv->m[1].Data();
2465  if (vv->m[1].Typ()==BIGINT_CMD)
2466  bitmask=n_Int(nn,coeffs_BIGINT);
2467  else if (vv->m[1].Typ()==INT_CMD)
2468  bitmask=(long)nn;
2469  else
2470  {
2471  Werror("illegal argument for pseudo ordering L: %d",vv->m[1].Typ());
2472  return TRUE;
2473  }
2474  break;
2475  }
2476  }
2477  }
2478  if (bitmask!=0) n--;
2479 
2480  // initialize fields of R
2481  R->order=(int *)omAlloc0(n*sizeof(int));
2482  R->block0=(int *)omAlloc0(n*sizeof(int));
2483  R->block1=(int *)omAlloc0(n*sizeof(int));
2484  R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
2485  // init order, so that rBlocks works correctly
2486  for (j_in_R= n-2; j_in_R>=0; j_in_R--)
2487  R->order[j_in_R] = (int) ringorder_unspec;
2488  // orderings
2489  for(j_in_R=0,j_in_L=0;j_in_R<n-1;j_in_R++,j_in_L++)
2490  {
2491  // todo: a(..), M
2492  if (v->m[j_in_L].Typ()!=LIST_CMD)
2493  {
2494  WerrorS("ordering must be list of lists");
2495  return TRUE;
2496  }
2497  lists vv=(lists)v->m[j_in_L].Data();
2498  if ((vv->nr==1)
2499  && (vv->m[0].Typ()==STRING_CMD))
2500  {
2501  if (strcmp((char*)vv->m[0].Data(),"L")==0)
2502  {
2503  j_in_R--;
2504  continue;
2505  }
2506  if ((vv->m[1].Typ()!=INTVEC_CMD) && (vv->m[1].Typ()!=INT_CMD))
2507  {
2508  PrintS(lString(vv));
2509  WerrorS("ordering name must be a (string,intvec)(1)");
2510  return TRUE;
2511  }
2512  R->order[j_in_R]=rOrderName(omStrDup((char*)vv->m[0].Data())); // assume STRING
2513 
2514  if (j_in_R==0) R->block0[0]=1;
2515  else
2516  {
2517  int jj=j_in_R-1;
2518  while((jj>=0)
2519  && ((R->order[jj]== ringorder_a)
2520  || (R->order[jj]== ringorder_aa)
2521  || (R->order[jj]== ringorder_am)
2522  || (R->order[jj]== ringorder_c)
2523  || (R->order[jj]== ringorder_C)
2524  || (R->order[jj]== ringorder_s)
2525  || (R->order[jj]== ringorder_S)
2526  ))
2527  {
2528  //Print("jj=%, skip %s\n",rSimpleOrdStr(R->order[jj]));
2529  jj--;
2530  }
2531  if (jj<0) R->block0[j_in_R]=1;
2532  else R->block0[j_in_R]=R->block1[jj]+1;
2533  }
2534  intvec *iv;
2535  if (vv->m[1].Typ()==INT_CMD)
2536  iv=new intvec((int)(long)vv->m[1].Data(),(int)(long)vv->m[1].Data());
2537  else
2538  iv=ivCopy((intvec*)vv->m[1].Data()); //assume INTVEC
2539  int iv_len=iv->length();
2540  R->block1[j_in_R]=si_max(R->block0[j_in_R],R->block0[j_in_R]+iv_len-1);
2541  if (R->block1[j_in_R]>R->N)
2542  {
2543  R->block1[j_in_R]=R->N;
2544  iv_len=R->block1[j_in_R]-R->block0[j_in_R]+1;
2545  }
2546  //Print("block %d from %d to %d\n",j,R->block0[j], R->block1[j]);
2547  int i;
2548  switch (R->order[j_in_R])
2549  {
2550  case ringorder_ws:
2551  case ringorder_Ws:
2552  R->OrdSgn=-1;
2553  case ringorder_aa:
2554  case ringorder_a:
2555  case ringorder_wp:
2556  case ringorder_Wp:
2557  R->wvhdl[j_in_R] =( int *)omAlloc(iv_len*sizeof(int));
2558  for (i=0; i<iv_len;i++)
2559  {
2560  R->wvhdl[j_in_R][i]=(*iv)[i];
2561  }
2562  break;
2563  case ringorder_am:
2564  R->wvhdl[j_in_R] =( int *)omAlloc((iv->length()+1)*sizeof(int));
2565  for (i=0; i<iv_len;i++)
2566  {
2567  R->wvhdl[j_in_R][i]=(*iv)[i];
2568  }
2569  R->wvhdl[j_in_R][i]=iv->length() - iv_len;
2570  //printf("ivlen:%d,iv->len:%d,mod:%d\n",iv_len,iv->length(),R->wvhdl[j][i]);
2571  for (; i<iv->length(); i++)
2572  {
2573  R->wvhdl[j_in_R][i+1]=(*iv)[i];
2574  }
2575  break;
2576  case ringorder_M:
2577  R->wvhdl[j_in_R] =( int *)omAlloc((iv->length())*sizeof(int));
2578  for (i=0; i<iv->length();i++) R->wvhdl[j_in_R][i]=(*iv)[i];
2579  R->block1[j_in_R]=si_max(R->block0[j_in_R],R->block0[j_in_R]+(int)sqrt((double)(iv->length()-1)));
2580  if (R->block1[j_in_R]>R->N)
2581  {
2582  WerrorS("ordering matrix too big");
2583  return TRUE;
2584  }
2585  break;
2586  case ringorder_ls:
2587  case ringorder_ds:
2588  case ringorder_Ds:
2589  case ringorder_rs:
2590  R->OrdSgn=-1;
2591  case ringorder_lp:
2592  case ringorder_dp:
2593  case ringorder_Dp:
2594  case ringorder_rp:
2595  break;
2596  case ringorder_S:
2597  break;
2598  case ringorder_c:
2599  case ringorder_C:
2600  R->block1[j_in_R]=R->block0[j_in_R]=0;
2601  break;
2602 
2603  case ringorder_s:
2604  break;
2605 
2606  case ringorder_IS:
2607  {
2608  R->block1[j_in_R] = R->block0[j_in_R] = 0;
2609  if( iv->length() > 0 )
2610  {
2611  const int s = (*iv)[0];
2612  assume( -2 < s && s < 2 );
2613  R->block1[j_in_R] = R->block0[j_in_R] = s;
2614  }
2615  break;
2616  }
2617  case 0:
2618  case ringorder_unspec:
2619  break;
2620  }
2621  delete iv;
2622  }
2623  else
2624  {
2625  PrintS(lString(vv));
2626  WerrorS("ordering name must be a (string,intvec)");
2627  return TRUE;
2628  }
2629  }
2630  // sanity check
2631  j_in_R=n-2;
2632  if ((R->order[j_in_R]==ringorder_c)
2633  || (R->order[j_in_R]==ringorder_C)
2634  || (R->order[j_in_R]==ringorder_unspec)) j_in_R--;
2635  if (R->block1[j_in_R] != R->N)
2636  {
2637  if (((R->order[j_in_R]==ringorder_dp) ||
2638  (R->order[j_in_R]==ringorder_ds) ||
2639  (R->order[j_in_R]==ringorder_Dp) ||
2640  (R->order[j_in_R]==ringorder_Ds) ||
2641  (R->order[j_in_R]==ringorder_rp) ||
2642  (R->order[j_in_R]==ringorder_rs) ||
2643  (R->order[j_in_R]==ringorder_lp) ||
2644  (R->order[j_in_R]==ringorder_ls))
2645  &&
2646  R->block0[j_in_R] <= R->N)
2647  {
2648  R->block1[j_in_R] = R->N;
2649  }
2650  else
2651  {
2652  Werror("ordering incomplete: size (%d) should be %d",R->block1[j_in_R],R->N);
2653  return TRUE;
2654  }
2655  }
2656  if (R->block0[j_in_R]>R->N)
2657  {
2658  Werror("not enough variables (%d) for ordering block %d, scanned so far:",R->N,j_in_R+1);
2659  for(int ii=0;ii<=j_in_R;ii++)
2660  Werror("ord[%d]: %s from v%d to v%d",ii+1,rSimpleOrdStr(R->order[ii]),R->block0[ii],R->block1[ii]);
2661  return TRUE;
2662  }
2663  if (check_comp)
2664  {
2665  BOOLEAN comp_order=FALSE;
2666  int jj;
2667  for(jj=0;jj<n;jj++)
2668  {
2669  if ((R->order[jj]==ringorder_c) ||
2670  (R->order[jj]==ringorder_C)) { comp_order=TRUE; break; }
2671  }
2672  if (!comp_order)
2673  {
2674  R->order=(int*)omRealloc0Size(R->order,n*sizeof(int),(n+1)*sizeof(int));
2675  R->block0=(int*)omRealloc0Size(R->block0,n*sizeof(int),(n+1)*sizeof(int));
2676  R->block1=(int*)omRealloc0Size(R->block1,n*sizeof(int),(n+1)*sizeof(int));
2677  R->wvhdl=(int**)omRealloc0Size(R->wvhdl,n*sizeof(int_ptr),(n+1)*sizeof(int_ptr));
2678  R->order[n-1]=ringorder_C;
2679  R->block0[n-1]=0;
2680  R->block1[n-1]=0;
2681  R->wvhdl[n-1]=NULL;
2682  n++;
2683  }
2684  }
2685  }
2686  else
2687  {
2688  WerrorS("ordering must be given as `list`");
2689  return TRUE;
2690  }
2691  if (bitmask!=0) R->bitmask=bitmask*2;
2692  return FALSE;
2693 }
2694 
2695 ring rCompose(const lists L, const BOOLEAN check_comp)
2696 {
2697  if ((L->nr!=3)
2698 #ifdef HAVE_PLURAL
2699  &&(L->nr!=5)
2700 #endif
2701  )
2702  return NULL;
2703  int is_gf_char=0;
2704  // 0: char/ cf - ring
2705  // 1: list (var)
2706  // 2: list (ord)
2707  // 3: qideal
2708  // possibly:
2709  // 4: C
2710  // 5: D
2711 
2712  ring R = (ring) omAlloc0Bin(sip_sring_bin);
2713 
2714  // ------------------------------------------------------------------
2715  // 0: char:
2716  if (L->m[0].Typ()==CRING_CMD)
2717  {
2718  R->cf=(coeffs)L->m[0].Data();
2719  R->cf->ref++;
2720  }
2721  else
2722  if (L->m[0].Typ()==INT_CMD)
2723  {
2724  int ch = (int)(long)L->m[0].Data();
2725  assume( ch >= 0 );
2726 
2727  if (ch == 0) // Q?
2728  R->cf = nInitChar(n_Q, NULL);
2729  else
2730  {
2731  int l = IsPrime(ch); // Zp?
2732  if( l != ch )
2733  {
2734  Warn("%d is invalid characteristic of ground field. %d is used.", ch, l);
2735  ch = l;
2736  }
2737  R->cf = nInitChar(n_Zp, (void*)(long)ch);
2738  }
2739  }
2740  else if (L->m[0].Typ()==LIST_CMD) // something complicated...
2741  {
2742  lists LL=(lists)L->m[0].Data();
2743 
2744 #ifdef HAVE_RINGS
2745  if (LL->m[0].Typ() == STRING_CMD) // 1st comes a string?
2746  {
2747  rComposeRing(LL, R); // Ring!?
2748  }
2749  else
2750 #endif
2751  if (LL->nr < 3)
2752  rComposeC(LL,R); // R, long_R, long_C
2753  else
2754  {
2755  if (LL->m[0].Typ()==INT_CMD)
2756  {
2757  int ch = (int)(long)LL->m[0].Data();
2758  while ((ch!=fftable[is_gf_char]) && (fftable[is_gf_char])) is_gf_char++;
2759  if (fftable[is_gf_char]==0) is_gf_char=-1;
2760 
2761  if(is_gf_char!= -1)
2762  {
2763  GFInfo param;
2764 
2765  param.GFChar = ch;
2766  param.GFDegree = 1;
2767  param.GFPar_name = (const char*)(((lists)(LL->m[1].Data()))->m[0].Data());
2768 
2769  // nfInitChar should be able to handle the case when ch is in fftables!
2770  R->cf = nInitChar(n_GF, (void*)&param);
2771  }
2772  }
2773 
2774  if( R->cf == NULL )
2775  {
2776  ring extRing = rCompose((lists)L->m[0].Data(),FALSE);
2777 
2778  if (extRing==NULL)
2779  {
2780  WerrorS("could not create the specified coefficient field");
2781  goto rCompose_err;
2782  }
2783 
2784  if( extRing->qideal != NULL ) // Algebraic extension
2785  {
2786  AlgExtInfo extParam;
2787 
2788  extParam.r = extRing;
2789 
2790  R->cf = nInitChar(n_algExt, (void*)&extParam);
2791  }
2792  else // Transcendental extension
2793  {
2794  TransExtInfo extParam;
2795  extParam.r = extRing;
2796  assume( extRing->qideal == NULL );
2797 
2798  R->cf = nInitChar(n_transExt, &extParam);
2799  }
2800  }
2801  }
2802  }
2803  else
2804  {
2805  WerrorS("coefficient field must be described by `int` or `list`");
2806  goto rCompose_err;
2807  }
2808 
2809  if( R->cf == NULL )
2810  {
2811  WerrorS("could not create coefficient field described by the input!");
2812  goto rCompose_err;
2813  }
2814 
2815  // ------------------------- VARS ---------------------------
2816  if (rComposeVar(L,R)) goto rCompose_err;
2817  // ------------------------ ORDER ------------------------------
2818  if (rComposeOrder(L,check_comp,R)) goto rCompose_err;
2819 
2820  // ------------------------ ??????? --------------------
2821 
2822  rRenameVars(R);
2823  rComplete(R);
2824 
2825  // ------------------------ Q-IDEAL ------------------------
2826 
2827  if (L->m[3].Typ()==IDEAL_CMD)
2828  {
2829  ideal q=(ideal)L->m[3].Data();
2830  if (q->m[0]!=NULL)
2831  {
2832  if (R->cf != currRing->cf) //->cf->ch!=currRing->cf->ch)
2833  {
2834  #if 0
2835  WerrorS("coefficient fields must be equal if q-ideal !=0");
2836  goto rCompose_err;
2837  #else
2838  ring orig_ring=currRing;
2839  rChangeCurrRing(R);
2840  int *perm=NULL;
2841  int *par_perm=NULL;
2842  int par_perm_size=0;
2843  nMapFunc nMap;
2844 
2845  if ((nMap=nSetMap(orig_ring->cf))==NULL)
2846  {
2847  if (rEqual(orig_ring,currRing))
2848  {
2849  nMap=n_SetMap(currRing->cf, currRing->cf);
2850  }
2851  else
2852  // Allow imap/fetch to be make an exception only for:
2853  if ( (rField_is_Q_a(orig_ring) && // Q(a..) -> Q(a..) || Q || Zp || Zp(a)
2856  ||
2857  (rField_is_Zp_a(orig_ring) && // Zp(a..) -> Zp(a..) || Zp
2858  (rField_is_Zp(currRing, rInternalChar(orig_ring)) ||
2859  rField_is_Zp_a(currRing, rInternalChar(orig_ring)))) )
2860  {
2861  par_perm_size=rPar(orig_ring);
2862 
2863 // if ((orig_ring->minpoly != NULL) || (orig_ring->qideal != NULL))
2864 // naSetChar(rInternalChar(orig_ring),orig_ring);
2865 // else ntSetChar(rInternalChar(orig_ring),orig_ring);
2866 
2867  nSetChar(currRing->cf);
2868  }
2869  else
2870  {
2871  WerrorS("coefficient fields must be equal if q-ideal !=0");
2872  goto rCompose_err;
2873  }
2874  }
2875  perm=(int *)omAlloc0((orig_ring->N+1)*sizeof(int));
2876  if (par_perm_size!=0)
2877  par_perm=(int *)omAlloc0(par_perm_size*sizeof(int));
2878  int i;
2879  #if 0
2880  // use imap:
2881  maFindPerm(orig_ring->names,orig_ring->N,orig_ring->parameter,orig_ring->P,
2882  currRing->names,currRing->N,currRing->parameter, currRing->P,
2883  perm,par_perm, currRing->ch);
2884  #else
2885  // use fetch
2886  if ((rPar(orig_ring)>0) && (rPar(currRing)==0))
2887  {
2888  for(i=si_min(rPar(orig_ring),rVar(currRing))-1;i>=0;i--) par_perm[i]=i+1;
2889  }
2890  else if (par_perm_size!=0)
2891  for(i=si_min(rPar(orig_ring),rPar(currRing))-1;i>=0;i--) par_perm[i]=-(i+1);
2892  for(i=si_min(orig_ring->N,rVar(currRing));i>0;i--) perm[i]=i;
2893  #endif
2894  ideal dest_id=idInit(IDELEMS(q),1);
2895  for(i=IDELEMS(q)-1; i>=0; i--)
2896  {
2897  dest_id->m[i]=p_PermPoly(q->m[i],perm,orig_ring, currRing,nMap,
2898  par_perm,par_perm_size);
2899  // PrintS("map:");pWrite(dest_id->m[i]);PrintLn();
2900  pTest(dest_id->m[i]);
2901  }
2902  R->qideal=dest_id;
2903  if (perm!=NULL)
2904  omFreeSize((ADDRESS)perm,(orig_ring->N+1)*sizeof(int));
2905  if (par_perm!=NULL)
2906  omFreeSize((ADDRESS)par_perm,par_perm_size*sizeof(int));
2907  rChangeCurrRing(orig_ring);
2908  #endif
2909  }
2910  else
2911  R->qideal=idrCopyR(q,currRing,R);
2912  }
2913  }
2914  else
2915  {
2916  WerrorS("q-ideal must be given as `ideal`");
2917  goto rCompose_err;
2918  }
2919 
2920 
2921  // ---------------------------------------------------------------
2922  #ifdef HAVE_PLURAL
2923  if (L->nr==5)
2924  {
2925  if (nc_CallPlural((matrix)L->m[4].Data(),
2926  (matrix)L->m[5].Data(),
2927  NULL,NULL,
2928  R,
2929  true, // !!!
2930  true, false,
2931  currRing, FALSE)) goto rCompose_err;
2932  // takes care about non-comm. quotient! i.e. calls "nc_SetupQuotient" due to last true
2933  }
2934  #endif
2935  return R;
2936 
2937 rCompose_err:
2938  if (R->N>0)
2939  {
2940  int i;
2941  if (R->names!=NULL)
2942  {
2943  i=R->N-1;
2944  while (i>=0) { if (R->names[i]!=NULL) omFree(R->names[i]); i--; }
2945  omFree(R->names);
2946  }
2947  }
2948  if (R->order!=NULL) omFree(R->order);
2949  if (R->block0!=NULL) omFree(R->block0);
2950  if (R->block1!=NULL) omFree(R->block1);
2951  if (R->wvhdl!=NULL) omFree(R->wvhdl);
2952  omFree(R);
2953  return NULL;
2954 }
2955 
2956 // from matpol.cc
2957 
2958 /*2
2959 * compute the jacobi matrix of an ideal
2960 */
2962 {
2963  int i,j;
2964  matrix result;
2965  ideal id=(ideal)a->Data();
2966 
2967  result =mpNew(IDELEMS(id),rVar(currRing));
2968  for (i=1; i<=IDELEMS(id); i++)
2969  {
2970  for (j=1; j<=rVar(currRing); j++)
2971  {
2972  MATELEM(result,i,j) = pDiff(id->m[i-1],j);
2973  }
2974  }
2975  res->data=(char *)result;
2976  return FALSE;
2977 }
2978 
2979 /*2
2980 * returns the Koszul-matrix of degree d of a vectorspace with dimension n
2981 * uses the first n entrees of id, if id <> NULL
2982 */
2984 {
2985  int n=(int)(long)b->Data();
2986  int d=(int)(long)c->Data();
2987  int k,l,sign,row,col;
2988  matrix result;
2989  ideal temp;
2990  BOOLEAN bo;
2991  poly p;
2992 
2993  if ((d>n) || (d<1) || (n<1))
2994  {
2995  res->data=(char *)mpNew(1,1);
2996  return FALSE;
2997  }
2998  int *choise = (int*)omAlloc(d*sizeof(int));
2999  if (id==NULL)
3000  temp=idMaxIdeal(1);
3001  else
3002  temp=(ideal)id->Data();
3003 
3004  k = binom(n,d);
3005  l = k*d;
3006  l /= n-d+1;
3007  result =mpNew(l,k);
3008  col = 1;
3009  idInitChoise(d,1,n,&bo,choise);
3010  while (!bo)
3011  {
3012  sign = 1;
3013  for (l=1;l<=d;l++)
3014  {
3015  if (choise[l-1]<=IDELEMS(temp))
3016  {
3017  p = pCopy(temp->m[choise[l-1]-1]);
3018  if (sign == -1) p = pNeg(p);
3019  sign *= -1;
3020  row = idGetNumberOfChoise(l-1,d,1,n,choise);
3021  MATELEM(result,row,col) = p;
3022  }
3023  }
3024  col++;
3025  idGetNextChoise(d,n,&bo,choise);
3026  }
3027  if (id==NULL) idDelete(&temp);
3028 
3029  res->data=(char *)result;
3030  return FALSE;
3031 }
3032 
3033 // from syz1.cc
3034 /*2
3035 * read out the Betti numbers from resolution
3036 * (interpreter interface)
3037 */
3039 {
3040  syStrategy syzstr=(syStrategy)u->Data();
3041 
3042  BOOLEAN minim=(int)(long)w->Data();
3043  int row_shift=0;
3044  int add_row_shift=0;
3045  intvec *weights=NULL;
3046  intvec *ww=(intvec *)atGet(u,"isHomog",INTVEC_CMD);
3047  if (ww!=NULL)
3048  {
3049  weights=ivCopy(ww);
3050  add_row_shift = ww->min_in();
3051  (*weights) -= add_row_shift;
3052  }
3053 
3054  res->data=(void *)syBettiOfComputation(syzstr,minim,&row_shift,weights);
3055  //row_shift += add_row_shift;
3056  //Print("row_shift=%d, add_row_shift=%d\n",row_shift,add_row_shift);
3057  atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
3058 
3059  return FALSE;
3060 }
3062 {
3063  sleftv tmp;
3064  memset(&tmp,0,sizeof(tmp));
3065  tmp.rtyp=INT_CMD;
3066  tmp.data=(void *)1;
3067  return syBetti2(res,u,&tmp);
3068 }
3069 
3070 /*3
3071 * converts a resolution into a list of modules
3072 */
3073 lists syConvRes(syStrategy syzstr,BOOLEAN toDel,int add_row_shift)
3074 {
3075  resolvente fullres = syzstr->fullres;
3076  resolvente minres = syzstr->minres;
3077 
3078  const int length = syzstr->length;
3079 
3080  if ((fullres==NULL) && (minres==NULL))
3081  {
3082  if (syzstr->hilb_coeffs==NULL)
3083  { // La Scala
3084  fullres = syReorder(syzstr->res, length, syzstr);
3085  }
3086  else
3087  { // HRES
3088  minres = syReorder(syzstr->orderedRes, length, syzstr);
3089  syKillEmptyEntres(minres, length);
3090  }
3091  }
3092 
3093  resolvente tr;
3094  int typ0=IDEAL_CMD;
3095 
3096  if (minres!=NULL)
3097  tr = minres;
3098  else
3099  tr = fullres;
3100 
3101  resolvente trueres=NULL; intvec ** w=NULL;
3102 
3103  if (length>0)
3104  {
3105  trueres = (resolvente)omAlloc0((length)*sizeof(ideal));
3106  for (int i=(length)-1;i>=0;i--)
3107  {
3108  if (tr[i]!=NULL)
3109  {
3110  trueres[i] = idCopy(tr[i]);
3111  }
3112  }
3113  if ( id_RankFreeModule(trueres[0], currRing) > 0)
3114  typ0 = MODUL_CMD;
3115  if (syzstr->weights!=NULL)
3116  {
3117  w = (intvec**)omAlloc0(length*sizeof(intvec*));
3118  for (int i=length-1;i>=0;i--)
3119  {
3120  if (syzstr->weights[i]!=NULL) w[i] = ivCopy(syzstr->weights[i]);
3121  }
3122  }
3123  }
3124 
3125  lists li = liMakeResolv(trueres, length, syzstr->list_length,typ0,
3126  w, add_row_shift);
3127 
3128  if (w != NULL) omFreeSize(w, length*sizeof(intvec*));
3129 
3130  if (toDel)
3131  syKillComputation(syzstr);
3132  else
3133  {
3134  if( fullres != NULL && syzstr->fullres == NULL )
3135  syzstr->fullres = fullres;
3136 
3137  if( minres != NULL && syzstr->minres == NULL )
3138  syzstr->minres = minres;
3139  }
3140  return li;
3141 }
3142 
3143 /*3
3144 * converts a list of modules into a resolution
3145 */
3147 {
3148  int typ0;
3150 
3151  resolvente fr = liFindRes(li,&(result->length),&typ0,&(result->weights));
3152  if (fr != NULL)
3153  {
3154 
3155  result->fullres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3156  for (int i=result->length-1;i>=0;i--)
3157  {
3158  if (fr[i]!=NULL)
3159  result->fullres[i] = idCopy(fr[i]);
3160  }
3161  result->list_length=result->length;
3162  omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3163  }
3164  else
3165  {
3166  omFreeSize(result, sizeof(ssyStrategy));
3167  result = NULL;
3168  }
3169  return result;
3170 }
3171 
3172 /*3
3173 * converts a list of modules into a minimal resolution
3174 */
3176 {
3177  int typ0;
3179 
3180  resolvente fr = liFindRes(li,&(result->length),&typ0);
3181  result->minres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3182  for (int i=result->length-1;i>=0;i--)
3183  {
3184  if (fr[i]!=NULL)
3185  result->minres[i] = idCopy(fr[i]);
3186  }
3187  omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3188  return result;
3189 }
3190 // from weight.cc
3192 {
3193  ideal F=(ideal)id->Data();
3194  intvec * iv = new intvec(rVar(currRing));
3195  polyset s;
3196  int sl, n, i;
3197  int *x;
3198 
3199  res->data=(char *)iv;
3200  s = F->m;
3201  sl = IDELEMS(F) - 1;
3202  n = rVar(currRing);
3203  double wNsqr = (double)2.0 / (double)n;
3205  x = (int * )omAlloc(2 * (n + 1) * sizeof(int));
3206  wCall(s, sl, x, wNsqr, currRing);
3207  for (i = n; i!=0; i--)
3208  (*iv)[i-1] = x[i + n + 1];
3209  omFreeSize((ADDRESS)x, 2 * (n + 1) * sizeof(int));
3210  return FALSE;
3211 }
3212 
3214 {
3215  res->data=(char *)id_QHomWeight((ideal)v->Data(), currRing);
3216  if (res->data==NULL)
3217  res->data=(char *)new intvec(rVar(currRing));
3218  return FALSE;
3219 }
3220 /*==============================================================*/
3221 // from clapsing.cc
3222 #if 0
3223 BOOLEAN jjIS_SQR_FREE(leftv res, leftv u)
3224 {
3225  BOOLEAN b=singclap_factorize((poly)(u->CopyD()), &v, 0);
3226  res->data=(void *)b;
3227 }
3228 #endif
3229 
3231 {
3232  res->data=singclap_resultant((poly)u->CopyD(),(poly)v->CopyD(),
3233  (poly)w->CopyD(), currRing);
3234  return errorreported;
3235 }
3236 
3238 {
3239  res->data=singclap_irrCharSeries((ideal)u->Data(), currRing);
3240  return (res->data==NULL);
3241 }
3242 
3243 // from semic.cc
3244 #ifdef HAVE_SPECTRUM
3245 
3246 // ----------------------------------------------------------------------------
3247 // Initialize a spectrum deep from a singular lists
3248 // ----------------------------------------------------------------------------
3249 
3250 void copy_deep( spectrum& spec, lists l )
3251 {
3252  spec.mu = (int)(long)(l->m[0].Data( ));
3253  spec.pg = (int)(long)(l->m[1].Data( ));
3254  spec.n = (int)(long)(l->m[2].Data( ));
3255 
3256  spec.copy_new( spec.n );
3257 
3258  intvec *num = (intvec*)l->m[3].Data( );
3259  intvec *den = (intvec*)l->m[4].Data( );
3260  intvec *mul = (intvec*)l->m[5].Data( );
3261 
3262  for( int i=0; i<spec.n; i++ )
3263  {
3264  spec.s[i] = (Rational)((*num)[i])/(Rational)((*den)[i]);
3265  spec.w[i] = (*mul)[i];
3266  }
3267 }
3268 
3269 // ----------------------------------------------------------------------------
3270 // singular lists constructor for spectrum
3271 // ----------------------------------------------------------------------------
3272 
3273 spectrum /*former spectrum::spectrum ( lists l )*/
3275 {
3276  spectrum result;
3277  copy_deep( result, l );
3278  return result;
3279 }
3280 
3281 // ----------------------------------------------------------------------------
3282 // generate a Singular lists from a spectrum
3283 // ----------------------------------------------------------------------------
3284 
3285 /* former spectrum::thelist ( void )*/
3287 {
3289 
3290  L->Init( 6 );
3291 
3292  intvec *num = new intvec( spec.n );
3293  intvec *den = new intvec( spec.n );
3294  intvec *mult = new intvec( spec.n );
3295 
3296  for( int i=0; i<spec.n; i++ )
3297  {
3298  (*num) [i] = spec.s[i].get_num_si( );
3299  (*den) [i] = spec.s[i].get_den_si( );
3300  (*mult)[i] = spec.w[i];
3301  }
3302 
3303  L->m[0].rtyp = INT_CMD; // milnor number
3304  L->m[1].rtyp = INT_CMD; // geometrical genus
3305  L->m[2].rtyp = INT_CMD; // # of spectrum numbers
3306  L->m[3].rtyp = INTVEC_CMD; // numerators
3307  L->m[4].rtyp = INTVEC_CMD; // denomiantors
3308  L->m[5].rtyp = INTVEC_CMD; // multiplicities
3309 
3310  L->m[0].data = (void*)(long)spec.mu;
3311  L->m[1].data = (void*)(long)spec.pg;
3312  L->m[2].data = (void*)(long)spec.n;
3313  L->m[3].data = (void*)num;
3314  L->m[4].data = (void*)den;
3315  L->m[5].data = (void*)mult;
3316 
3317  return L;
3318 }
3319 // from spectrum.cc
3320 // ----------------------------------------------------------------------------
3321 // print out an error message for a spectrum list
3322 // ----------------------------------------------------------------------------
3323 
3324 typedef enum
3325 {
3328 
3331 
3338 
3343 
3349 
3352 
3355 
3356 } semicState;
3357 
3358 void list_error( semicState state )
3359 {
3360  switch( state )
3361  {
3362  case semicListTooShort:
3363  WerrorS( "the list is too short" );
3364  break;
3365  case semicListTooLong:
3366  WerrorS( "the list is too long" );
3367  break;
3368 
3370  WerrorS( "first element of the list should be int" );
3371  break;
3373  WerrorS( "second element of the list should be int" );
3374  break;
3376  WerrorS( "third element of the list should be int" );
3377  break;
3379  WerrorS( "fourth element of the list should be intvec" );
3380  break;
3382  WerrorS( "fifth element of the list should be intvec" );
3383  break;
3385  WerrorS( "sixth element of the list should be intvec" );
3386  break;
3387 
3388  case semicListNNegative:
3389  WerrorS( "first element of the list should be positive" );
3390  break;
3392  WerrorS( "wrong number of numerators" );
3393  break;
3395  WerrorS( "wrong number of denominators" );
3396  break;
3398  WerrorS( "wrong number of multiplicities" );
3399  break;
3400 
3401  case semicListMuNegative:
3402  WerrorS( "the Milnor number should be positive" );
3403  break;
3404  case semicListPgNegative:
3405  WerrorS( "the geometrical genus should be nonnegative" );
3406  break;
3407  case semicListNumNegative:
3408  WerrorS( "all numerators should be positive" );
3409  break;
3410  case semicListDenNegative:
3411  WerrorS( "all denominators should be positive" );
3412  break;
3413  case semicListMulNegative:
3414  WerrorS( "all multiplicities should be positive" );
3415  break;
3416 
3417  case semicListNotSymmetric:
3418  WerrorS( "it is not symmetric" );
3419  break;
3421  WerrorS( "it is not monotonous" );
3422  break;
3423 
3424  case semicListMilnorWrong:
3425  WerrorS( "the Milnor number is wrong" );
3426  break;
3427  case semicListPGWrong:
3428  WerrorS( "the geometrical genus is wrong" );
3429  break;
3430 
3431  default:
3432  WerrorS( "unspecific error" );
3433  break;
3434  }
3435 }
3436 // ----------------------------------------------------------------------------
3437 // this is the main spectrum computation function
3438 // ----------------------------------------------------------------------------
3439 
3441 {
3451 };
3452 
3453 // from splist.cc
3454 // ----------------------------------------------------------------------------
3455 // Compute the spectrum of a spectrumPolyList
3456 // ----------------------------------------------------------------------------
3457 
3458 /* former spectrumPolyList::spectrum ( lists*, int) */
3460 {
3461  spectrumPolyNode **node = &speclist.root;
3463 
3464  poly f,tmp;
3465  int found,cmp;
3466 
3467  Rational smax( ( fast==0 ? 0 : rVar(currRing) ),
3468  ( fast==2 ? 2 : 1 ) );
3469 
3470  Rational weight_prev( 0,1 );
3471 
3472  int mu = 0; // the milnor number
3473  int pg = 0; // the geometrical genus
3474  int n = 0; // number of different spectral numbers
3475  int z = 0; // number of spectral number equal to smax
3476 
3477  while( (*node)!=(spectrumPolyNode*)NULL &&
3478  ( fast==0 || (*node)->weight<=smax ) )
3479  {
3480  // ---------------------------------------
3481  // determine the first normal form which
3482  // contains the monomial node->mon
3483  // ---------------------------------------
3484 
3485  found = FALSE;
3486  search = *node;
3487 
3488  while( search!=(spectrumPolyNode*)NULL && found==FALSE )
3489  {
3490  if( search->nf!=(poly)NULL )
3491  {
3492  f = search->nf;
3493 
3494  do
3495  {
3496  // --------------------------------
3497  // look for (*node)->mon in f
3498  // --------------------------------
3499 
3500  cmp = pCmp( (*node)->mon,f );
3501 
3502  if( cmp<0 )
3503  {
3504  f = pNext( f );
3505  }
3506  else if( cmp==0 )
3507  {
3508  // -----------------------------
3509  // we have found a normal form
3510  // -----------------------------
3511 
3512  found = TRUE;
3513 
3514  // normalize coefficient
3515 
3516  number inv = nInvers( pGetCoeff( f ) );
3517  pMult_nn( search->nf,inv );
3518  nDelete( &inv );
3519 
3520  // exchange normal forms
3521 
3522  tmp = (*node)->nf;
3523  (*node)->nf = search->nf;
3524  search->nf = tmp;
3525  }
3526  }
3527  while( cmp<0 && f!=(poly)NULL );
3528  }
3529  search = search->next;
3530  }
3531 
3532  if( found==FALSE )
3533  {
3534  // ------------------------------------------------
3535  // the weight of node->mon is a spectrum number
3536  // ------------------------------------------------
3537 
3538  mu++;
3539 
3540  if( (*node)->weight<=(Rational)1 ) pg++;
3541  if( (*node)->weight==smax ) z++;
3542  if( (*node)->weight>weight_prev ) n++;
3543 
3544  weight_prev = (*node)->weight;
3545  node = &((*node)->next);
3546  }
3547  else
3548  {
3549  // -----------------------------------------------
3550  // determine all other normal form which contain
3551  // the monomial node->mon
3552  // replace for node->mon its normal form
3553  // -----------------------------------------------
3554 
3555  while( search!=(spectrumPolyNode*)NULL )
3556  {
3557  if( search->nf!=(poly)NULL )
3558  {
3559  f = search->nf;
3560 
3561  do
3562  {
3563  // --------------------------------
3564  // look for (*node)->mon in f
3565  // --------------------------------
3566 
3567  cmp = pCmp( (*node)->mon,f );
3568 
3569  if( cmp<0 )
3570  {
3571  f = pNext( f );
3572  }
3573  else if( cmp==0 )
3574  {
3575  search->nf = pSub( search->nf,
3576  ppMult_nn( (*node)->nf,pGetCoeff( f ) ) );
3577  pNorm( search->nf );
3578  }
3579  }
3580  while( cmp<0 && f!=(poly)NULL );
3581  }
3582  search = search->next;
3583  }
3584  speclist.delete_node( node );
3585  }
3586 
3587  }
3588 
3589  // --------------------------------------------------------
3590  // fast computation exploits the symmetry of the spectrum
3591  // --------------------------------------------------------
3592 
3593  if( fast==2 )
3594  {
3595  mu = 2*mu - z;
3596  n = ( z > 0 ? 2*n - 1 : 2*n );
3597  }
3598 
3599  // --------------------------------------------------------
3600  // compute the spectrum numbers with their multiplicities
3601  // --------------------------------------------------------
3602 
3603  intvec *nom = new intvec( n );
3604  intvec *den = new intvec( n );
3605  intvec *mult = new intvec( n );
3606 
3607  int count = 0;
3608  int multiplicity = 1;
3609 
3610  for( search=speclist.root; search!=(spectrumPolyNode*)NULL &&
3611  ( fast==0 || search->weight<=smax );
3612  search=search->next )
3613  {
3614  if( search->next==(spectrumPolyNode*)NULL ||
3615  search->weight<search->next->weight )
3616  {
3617  (*nom) [count] = search->weight.get_num_si( );
3618  (*den) [count] = search->weight.get_den_si( );
3619  (*mult)[count] = multiplicity;
3620 
3621  multiplicity=1;
3622  count++;
3623  }
3624  else
3625  {
3626  multiplicity++;
3627  }
3628  }
3629 
3630  // --------------------------------------------------------
3631  // fast computation exploits the symmetry of the spectrum
3632  // --------------------------------------------------------
3633 
3634  if( fast==2 )
3635  {
3636  int n1,n2;
3637  for( n1=0, n2=n-1; n1<n2; n1++, n2-- )
3638  {
3639  (*nom) [n2] = rVar(currRing)*(*den)[n1]-(*nom)[n1];
3640  (*den) [n2] = (*den)[n1];
3641  (*mult)[n2] = (*mult)[n1];
3642  }
3643  }
3644 
3645  // -----------------------------------
3646  // test if the spectrum is symmetric
3647  // -----------------------------------
3648 
3649  if( fast==0 || fast==1 )
3650  {
3651  int symmetric=TRUE;
3652 
3653  for( int n1=0, n2=n-1 ; n1<n2 && symmetric==TRUE; n1++, n2-- )
3654  {
3655  if( (*mult)[n1]!=(*mult)[n2] ||
3656  (*den) [n1]!= (*den)[n2] ||
3657  (*nom)[n1]+(*nom)[n2]!=rVar(currRing)*(*den) [n1] )
3658  {
3659  symmetric = FALSE;
3660  }
3661  }
3662 
3663  if( symmetric==FALSE )
3664  {
3665  // ---------------------------------------------
3666  // the spectrum is not symmetric => degenerate
3667  // principal part
3668  // ---------------------------------------------
3669 
3670  *L = (lists)omAllocBin( slists_bin);
3671  (*L)->Init( 1 );
3672  (*L)->m[0].rtyp = INT_CMD; // milnor number
3673  (*L)->m[0].data = (void*)(long)mu;
3674 
3675  return spectrumDegenerate;
3676  }
3677  }
3678 
3679  *L = (lists)omAllocBin( slists_bin);
3680 
3681  (*L)->Init( 6 );
3682 
3683  (*L)->m[0].rtyp = INT_CMD; // milnor number
3684  (*L)->m[1].rtyp = INT_CMD; // geometrical genus
3685  (*L)->m[2].rtyp = INT_CMD; // number of spectrum values
3686  (*L)->m[3].rtyp = INTVEC_CMD; // nominators
3687  (*L)->m[4].rtyp = INTVEC_CMD; // denomiantors
3688  (*L)->m[5].rtyp = INTVEC_CMD; // multiplicities
3689 
3690  (*L)->m[0].data = (void*)(long)mu;
3691  (*L)->m[1].data = (void*)(long)pg;
3692  (*L)->m[2].data = (void*)(long)n;
3693  (*L)->m[3].data = (void*)nom;
3694  (*L)->m[4].data = (void*)den;
3695  (*L)->m[5].data = (void*)mult;
3696 
3697  return spectrumOK;
3698 }
3699 
3701 {
3702  int i;
3703 
3704  #ifdef SPECTRUM_DEBUG
3705  #ifdef SPECTRUM_PRINT
3706  #ifdef SPECTRUM_IOSTREAM
3707  cout << "spectrumCompute\n";
3708  if( fast==0 ) cout << " no optimization" << endl;
3709  if( fast==1 ) cout << " weight optimization" << endl;
3710  if( fast==2 ) cout << " symmetry optimization" << endl;
3711  #else
3712  fprintf( stdout,"spectrumCompute\n" );
3713  if( fast==0 ) fprintf( stdout," no optimization\n" );
3714  if( fast==1 ) fprintf( stdout," weight optimization\n" );
3715  if( fast==2 ) fprintf( stdout," symmetry optimization\n" );
3716  #endif
3717  #endif
3718  #endif
3719 
3720  // ----------------------
3721  // check if h is zero
3722  // ----------------------
3723 
3724  if( h==(poly)NULL )
3725  {
3726  return spectrumZero;
3727  }
3728 
3729  // ----------------------------------
3730  // check if h has a constant term
3731  // ----------------------------------
3732 
3733  if( hasConstTerm( h, currRing ) )
3734  {
3735  return spectrumBadPoly;
3736  }
3737 
3738  // --------------------------------
3739  // check if h has a linear term
3740  // --------------------------------
3741 
3742  if( hasLinearTerm( h, currRing ) )
3743  {
3744  *L = (lists)omAllocBin( slists_bin);
3745  (*L)->Init( 1 );
3746  (*L)->m[0].rtyp = INT_CMD; // milnor number
3747  /* (*L)->m[0].data = (void*)0;a -- done by Init */
3748 
3749  return spectrumNoSingularity;
3750  }
3751 
3752  // ----------------------------------
3753  // compute the jacobi ideal of (h)
3754  // ----------------------------------
3755 
3756  ideal J = NULL;
3757  J = idInit( rVar(currRing),1 );
3758 
3759  #ifdef SPECTRUM_DEBUG
3760  #ifdef SPECTRUM_PRINT
3761  #ifdef SPECTRUM_IOSTREAM
3762  cout << "\n computing the Jacobi ideal...\n";
3763  #else
3764  fprintf( stdout,"\n computing the Jacobi ideal...\n" );
3765  #endif
3766  #endif
3767  #endif
3768 
3769  for( i=0; i<rVar(currRing); i++ )
3770  {
3771  J->m[i] = pDiff( h,i+1); //j );
3772 
3773  #ifdef SPECTRUM_DEBUG
3774  #ifdef SPECTRUM_PRINT
3775  #ifdef SPECTRUM_IOSTREAM
3776  cout << " ";
3777  #else
3778  fprintf( stdout," " );
3779  #endif
3780  pWrite( J->m[i] );
3781  #endif
3782  #endif
3783  }
3784 
3785  // --------------------------------------------
3786  // compute a standard basis stdJ of jac(h)
3787  // --------------------------------------------
3788 
3789  #ifdef SPECTRUM_DEBUG
3790  #ifdef SPECTRUM_PRINT
3791  #ifdef SPECTRUM_IOSTREAM
3792  cout << endl;
3793  cout << " computing a standard basis..." << endl;
3794  #else
3795  fprintf( stdout,"\n" );
3796  fprintf( stdout," computing a standard basis...\n" );
3797  #endif
3798  #endif
3799  #endif
3800 
3801  ideal stdJ = kStd(J,currRing->qideal,isNotHomog,NULL);
3802  idSkipZeroes( stdJ );
3803 
3804  #ifdef SPECTRUM_DEBUG
3805  #ifdef SPECTRUM_PRINT
3806  for( i=0; i<IDELEMS(stdJ); i++ )
3807  {
3808  #ifdef SPECTRUM_IOSTREAM
3809  cout << " ";
3810  #else
3811  fprintf( stdout," " );
3812  #endif
3813 
3814  pWrite( stdJ->m[i] );
3815  }
3816  #endif
3817  #endif
3818 
3819  idDelete( &J );
3820 
3821  // ------------------------------------------
3822  // check if the h has a singularity
3823  // ------------------------------------------
3824 
3825  if( hasOne( stdJ, currRing ) )
3826  {
3827  // -------------------------------
3828  // h is smooth in the origin
3829  // return only the Milnor number
3830  // -------------------------------
3831 
3832  *L = (lists)omAllocBin( slists_bin);
3833  (*L)->Init( 1 );
3834  (*L)->m[0].rtyp = INT_CMD; // milnor number
3835  /* (*L)->m[0].data = (void*)0;a -- done by Init */
3836 
3837  return spectrumNoSingularity;
3838  }
3839 
3840  // ------------------------------------------
3841  // check if the singularity h is isolated
3842  // ------------------------------------------
3843 
3844  for( i=rVar(currRing); i>0; i-- )
3845  {
3846  if( hasAxis( stdJ,i, currRing )==FALSE )
3847  {
3848  return spectrumNotIsolated;
3849  }
3850  }
3851 
3852  // ------------------------------------------
3853  // compute the highest corner hc of stdJ
3854  // ------------------------------------------
3855 
3856  #ifdef SPECTRUM_DEBUG
3857  #ifdef SPECTRUM_PRINT
3858  #ifdef SPECTRUM_IOSTREAM
3859  cout << "\n computing the highest corner...\n";
3860  #else
3861  fprintf( stdout,"\n computing the highest corner...\n" );
3862  #endif
3863  #endif
3864  #endif
3865 
3866  poly hc = (poly)NULL;
3867 
3868  scComputeHC( stdJ,currRing->qideal, 0,hc );
3869 
3870  if( hc!=(poly)NULL )
3871  {
3872  pGetCoeff(hc) = nInit(1);
3873 
3874  for( i=rVar(currRing); i>0; i-- )
3875  {
3876  if( pGetExp( hc,i )>0 ) pDecrExp( hc,i );
3877  }
3878  pSetm( hc );
3879  }
3880  else
3881  {
3882  return spectrumNoHC;
3883  }
3884 
3885  #ifdef SPECTRUM_DEBUG
3886  #ifdef SPECTRUM_PRINT
3887  #ifdef SPECTRUM_IOSTREAM
3888  cout << " ";
3889  #else
3890  fprintf( stdout," " );
3891  #endif
3892  pWrite( hc );
3893  #endif
3894  #endif
3895 
3896  // ----------------------------------------
3897  // compute the Newton polygon nph of h
3898  // ----------------------------------------
3899 
3900  #ifdef SPECTRUM_DEBUG
3901  #ifdef SPECTRUM_PRINT
3902  #ifdef SPECTRUM_IOSTREAM
3903  cout << "\n computing the newton polygon...\n";
3904  #else
3905  fprintf( stdout,"\n computing the newton polygon...\n" );
3906  #endif
3907  #endif
3908  #endif
3909 
3910  newtonPolygon nph( h, currRing );
3911 
3912  #ifdef SPECTRUM_DEBUG
3913  #ifdef SPECTRUM_PRINT
3914  cout << nph;
3915  #endif
3916  #endif
3917 
3918  // -----------------------------------------------
3919  // compute the weight corner wc of (stdj,nph)
3920  // -----------------------------------------------
3921 
3922  #ifdef SPECTRUM_DEBUG
3923  #ifdef SPECTRUM_PRINT
3924  #ifdef SPECTRUM_IOSTREAM
3925  cout << "\n computing the weight corner...\n";
3926  #else
3927  fprintf( stdout,"\n computing the weight corner...\n" );
3928  #endif
3929  #endif
3930  #endif
3931 
3932  poly wc = ( fast==0 ? pCopy( hc ) :
3933  ( fast==1 ? computeWC( nph,(Rational)rVar(currRing), currRing ) :
3934  /* fast==2 */computeWC( nph,
3935  ((Rational)rVar(currRing))/(Rational)2, currRing ) ) );
3936 
3937  #ifdef SPECTRUM_DEBUG
3938  #ifdef SPECTRUM_PRINT
3939  #ifdef SPECTRUM_IOSTREAM
3940  cout << " ";
3941  #else
3942  fprintf( stdout," " );
3943  #endif
3944  pWrite( wc );
3945  #endif
3946  #endif
3947 
3948  // -------------
3949  // compute NF
3950  // -------------
3951 
3952  #ifdef SPECTRUM_DEBUG
3953  #ifdef SPECTRUM_PRINT
3954  #ifdef SPECTRUM_IOSTREAM
3955  cout << "\n computing NF...\n" << endl;
3956  #else
3957  fprintf( stdout,"\n computing NF...\n" );
3958  #endif
3959  #endif
3960  #endif
3961 
3962  spectrumPolyList NF( &nph );
3963 
3964  computeNF( stdJ,hc,wc,&NF, currRing );
3965 
3966  #ifdef SPECTRUM_DEBUG
3967  #ifdef SPECTRUM_PRINT
3968  cout << NF;
3969  #ifdef SPECTRUM_IOSTREAM
3970  cout << endl;
3971  #else
3972  fprintf( stdout,"\n" );
3973  #endif
3974  #endif
3975  #endif
3976 
3977  // ----------------------------
3978  // compute the spectrum of h
3979  // ----------------------------
3980 // spectrumState spectrumStateFromList( spectrumPolyList& speclist, lists *L, int fast );
3981 
3982  return spectrumStateFromList(NF, L, fast );
3983 }
3984 
3985 // ----------------------------------------------------------------------------
3986 // this procedure is called from the interpreter
3987 // ----------------------------------------------------------------------------
3988 // first = polynomial
3989 // result = list of spectrum numbers
3990 // ----------------------------------------------------------------------------
3991 
3993 {
3994  switch( state )
3995  {
3996  case spectrumZero:
3997  WerrorS( "polynomial is zero" );
3998  break;
3999  case spectrumBadPoly:
4000  WerrorS( "polynomial has constant term" );
4001  break;
4002  case spectrumNoSingularity:
4003  WerrorS( "not a singularity" );
4004  break;
4005  case spectrumNotIsolated:
4006  WerrorS( "the singularity is not isolated" );
4007  break;
4008  case spectrumNoHC:
4009  WerrorS( "highest corner cannot be computed" );
4010  break;
4011  case spectrumDegenerate:
4012  WerrorS( "principal part is degenerate" );
4013  break;
4014  case spectrumOK:
4015  break;
4016 
4017  default:
4018  WerrorS( "unknown error occurred" );
4019  break;
4020  }
4021 }
4022 
4024 {
4025  spectrumState state = spectrumOK;
4026 
4027  // -------------------
4028  // check consistency
4029  // -------------------
4030 
4031  // check for a local ring
4032 
4033  if( !ringIsLocal(currRing ) )
4034  {
4035  WerrorS( "only works for local orderings" );
4036  state = spectrumWrongRing;
4037  }
4038 
4039  // no quotient rings are allowed
4040 
4041  else if( currRing->qideal != NULL )
4042  {
4043  WerrorS( "does not work in quotient rings" );
4044  state = spectrumWrongRing;
4045  }
4046  else
4047  {
4048  lists L = (lists)NULL;
4049  int flag = 1; // weight corner optimization is safe
4050 
4051  state = spectrumCompute( (poly)first->Data( ),&L,flag );
4052 
4053  if( state==spectrumOK )
4054  {
4055  result->rtyp = LIST_CMD;
4056  result->data = (char*)L;
4057  }
4058  else
4059  {
4060  spectrumPrintError(state);
4061  }
4062  }
4063 
4064  return (state!=spectrumOK);
4065 }
4066 
4067 // ----------------------------------------------------------------------------
4068 // this procedure is called from the interpreter
4069 // ----------------------------------------------------------------------------
4070 // first = polynomial
4071 // result = list of spectrum numbers
4072 // ----------------------------------------------------------------------------
4073 
4075 {
4076  spectrumState state = spectrumOK;
4077 
4078  // -------------------
4079  // check consistency
4080  // -------------------
4081 
4082  // check for a local polynomial ring
4083 
4084  if( currRing->OrdSgn != -1 )
4085  // ?? HS: the test above is also true for k[x][[y]], k[[x]][y]
4086  // or should we use:
4087  //if( !ringIsLocal( ) )
4088  {
4089  WerrorS( "only works for local orderings" );
4090  state = spectrumWrongRing;
4091  }
4092  else if( currRing->qideal != NULL )
4093  {
4094  WerrorS( "does not work in quotient rings" );
4095  state = spectrumWrongRing;
4096  }
4097  else
4098  {
4099  lists L = (lists)NULL;
4100  int flag = 2; // symmetric optimization
4101 
4102  state = spectrumCompute( (poly)first->Data( ),&L,flag );
4103 
4104  if( state==spectrumOK )
4105  {
4106  result->rtyp = LIST_CMD;
4107  result->data = (char*)L;
4108  }
4109  else
4110  {
4111  spectrumPrintError(state);
4112  }
4113  }
4114 
4115  return (state!=spectrumOK);
4116 }
4117 
4118 // ----------------------------------------------------------------------------
4119 // check if a list is a spectrum
4120 // check for:
4121 // list has 6 elements
4122 // 1st element is int (mu=Milnor number)
4123 // 2nd element is int (pg=geometrical genus)
4124 // 3rd element is int (n =number of different spectrum numbers)
4125 // 4th element is intvec (num=numerators)
4126 // 5th element is intvec (den=denomiantors)
4127 // 6th element is intvec (mul=multiplicities)
4128 // exactly n numerators
4129 // exactly n denominators
4130 // exactly n multiplicities
4131 // mu>0
4132 // pg>=0
4133 // n>0
4134 // num>0
4135 // den>0
4136 // mul>0
4137 // symmetriy with respect to numberofvariables/2
4138 // monotony
4139 // mu = sum of all multiplicities
4140 // pg = sum of all multiplicities where num/den<=1
4141 // ----------------------------------------------------------------------------
4142 
4143 semicState list_is_spectrum( lists l )
4144 {
4145  // -------------------
4146  // check list length
4147  // -------------------
4148 
4149  if( l->nr < 5 )
4150  {
4151  return semicListTooShort;
4152  }
4153  else if( l->nr > 5 )
4154  {
4155  return semicListTooLong;
4156  }
4157 
4158  // -------------
4159  // check types
4160  // -------------
4161 
4162  if( l->m[0].rtyp != INT_CMD )
4163  {
4165  }
4166  else if( l->m[1].rtyp != INT_CMD )
4167  {
4169  }
4170  else if( l->m[2].rtyp != INT_CMD )
4171  {
4173  }
4174  else if( l->m[3].rtyp != INTVEC_CMD )
4175  {
4177  }
4178  else if( l->m[4].rtyp != INTVEC_CMD )
4179  {
4181  }
4182  else if( l->m[5].rtyp != INTVEC_CMD )
4183  {
4185  }
4186 
4187  // -------------------------
4188  // check number of entries
4189  // -------------------------
4190 
4191  int mu = (int)(long)(l->m[0].Data( ));
4192  int pg = (int)(long)(l->m[1].Data( ));
4193  int n = (int)(long)(l->m[2].Data( ));
4194 
4195  if( n <= 0 )
4196  {
4197  return semicListNNegative;
4198  }
4199 
4200  intvec *num = (intvec*)l->m[3].Data( );
4201  intvec *den = (intvec*)l->m[4].Data( );
4202  intvec *mul = (intvec*)l->m[5].Data( );
4203 
4204  if( n != num->length( ) )
4205  {
4207  }
4208  else if( n != den->length( ) )
4209  {
4211  }
4212  else if( n != mul->length( ) )
4213  {
4215  }
4216 
4217  // --------
4218  // values
4219  // --------
4220 
4221  if( mu <= 0 )
4222  {
4223  return semicListMuNegative;
4224  }
4225  if( pg < 0 )
4226  {
4227  return semicListPgNegative;
4228  }
4229 
4230  int i;
4231 
4232  for( i=0; i<n; i++ )
4233  {
4234  if( (*num)[i] <= 0 )
4235  {
4236  return semicListNumNegative;
4237  }
4238  if( (*den)[i] <= 0 )
4239  {
4240  return semicListDenNegative;
4241  }
4242  if( (*mul)[i] <= 0 )
4243  {
4244  return semicListMulNegative;
4245  }
4246  }
4247 
4248  // ----------------
4249  // check symmetry
4250  // ----------------
4251 
4252  int j;
4253 
4254  for( i=0, j=n-1; i<=j; i++,j-- )
4255  {
4256  if( (*num)[i] != rVar(currRing)*((*den)[i]) - (*num)[j] ||
4257  (*den)[i] != (*den)[j] ||
4258  (*mul)[i] != (*mul)[j] )
4259  {
4260  return semicListNotSymmetric;
4261  }
4262  }
4263 
4264  // ----------------
4265  // check monotony
4266  // ----------------
4267 
4268  for( i=0, j=1; i<n/2; i++,j++ )
4269  {
4270  if( (*num)[i]*(*den)[j] >= (*num)[j]*(*den)[i] )
4271  {
4272  return semicListNotMonotonous;
4273  }
4274  }
4275 
4276  // ---------------------
4277  // check Milnor number
4278  // ---------------------
4279 
4280  for( mu=0, i=0; i<n; i++ )
4281  {
4282  mu += (*mul)[i];
4283  }
4284 
4285  if( mu != (int)(long)(l->m[0].Data( )) )
4286  {
4287  return semicListMilnorWrong;
4288  }
4289 
4290  // -------------------------
4291  // check geometrical genus
4292  // -------------------------
4293 
4294  for( pg=0, i=0; i<n; i++ )
4295  {
4296  if( (*num)[i]<=(*den)[i] )
4297  {
4298  pg += (*mul)[i];
4299  }
4300  }
4301 
4302  if( pg != (int)(long)(l->m[1].Data( )) )
4303  {
4304  return semicListPGWrong;
4305  }
4306 
4307  return semicOK;
4308 }
4309 
4310 // ----------------------------------------------------------------------------
4311 // this procedure is called from the interpreter
4312 // ----------------------------------------------------------------------------
4313 // first = list of spectrum numbers
4314 // second = list of spectrum numbers
4315 // result = sum of the two lists
4316 // ----------------------------------------------------------------------------
4317 
4319 {
4320  semicState state;
4321 
4322  // -----------------
4323  // check arguments
4324  // -----------------
4325 
4326  lists l1 = (lists)first->Data( );
4327  lists l2 = (lists)second->Data( );
4328 
4329  if( (state=list_is_spectrum( l1 )) != semicOK )
4330  {
4331  WerrorS( "first argument is not a spectrum:" );
4332  list_error( state );
4333  }
4334  else if( (state=list_is_spectrum( l2 )) != semicOK )
4335  {
4336  WerrorS( "second argument is not a spectrum:" );
4337  list_error( state );
4338  }
4339  else
4340  {
4341  spectrum s1= spectrumFromList ( l1 );
4342  spectrum s2= spectrumFromList ( l2 );
4343  spectrum sum( s1+s2 );
4344 
4345  result->rtyp = LIST_CMD;
4346  result->data = (char*)(getList(sum));
4347  }
4348 
4349  return (state!=semicOK);
4350 }
4351 
4352 // ----------------------------------------------------------------------------
4353 // this procedure is called from the interpreter
4354 // ----------------------------------------------------------------------------
4355 // first = list of spectrum numbers
4356 // second = integer
4357 // result = the multiple of the first list by the second factor
4358 // ----------------------------------------------------------------------------
4359 
4361 {
4362  semicState state;
4363 
4364  // -----------------
4365  // check arguments
4366  // -----------------
4367 
4368  lists l = (lists)first->Data( );
4369  int k = (int)(long)second->Data( );
4370 
4371  if( (state=list_is_spectrum( l ))!=semicOK )
4372  {
4373  WerrorS( "first argument is not a spectrum" );
4374  list_error( state );
4375  }
4376  else if( k < 0 )
4377  {
4378  WerrorS( "second argument should be positive" );
4379  state = semicMulNegative;
4380  }
4381  else
4382  {
4383  spectrum s= spectrumFromList( l );
4384  spectrum product( k*s );
4385 
4386  result->rtyp = LIST_CMD;
4387  result->data = (char*)getList(product);
4388  }
4389 
4390  return (state!=semicOK);
4391 }
4392 
4393 // ----------------------------------------------------------------------------
4394 // this procedure is called from the interpreter
4395 // ----------------------------------------------------------------------------
4396 // first = list of spectrum numbers
4397 // second = list of spectrum numbers
4398 // result = semicontinuity index
4399 // ----------------------------------------------------------------------------
4400 
4402 {
4403  semicState state;
4404  BOOLEAN qh=(((int)(long)w->Data())==1);
4405 
4406  // -----------------
4407  // check arguments
4408  // -----------------
4409 
4410  lists l1 = (lists)u->Data( );
4411  lists l2 = (lists)v->Data( );
4412 
4413  if( (state=list_is_spectrum( l1 ))!=semicOK )
4414  {
4415  WerrorS( "first argument is not a spectrum" );
4416  list_error( state );
4417  }
4418  else if( (state=list_is_spectrum( l2 ))!=semicOK )
4419  {
4420  WerrorS( "second argument is not a spectrum" );
4421  list_error( state );
4422  }
4423  else
4424  {
4425  spectrum s1= spectrumFromList( l1 );
4426  spectrum s2= spectrumFromList( l2 );
4427 
4428  res->rtyp = INT_CMD;
4429  if (qh)
4430  res->data = (void*)(long)(s1.mult_spectrumh( s2 ));
4431  else
4432  res->data = (void*)(long)(s1.mult_spectrum( s2 ));
4433  }
4434 
4435  // -----------------
4436  // check status
4437  // -----------------
4438 
4439  return (state!=semicOK);
4440 }
4442 {
4443  sleftv tmp;
4444  memset(&tmp,0,sizeof(tmp));
4445  tmp.rtyp=INT_CMD;
4446  /* tmp.data = (void *)0; -- done by memset */
4447 
4448  return semicProc3(res,u,v,&tmp);
4449 }
4450 
4451 #endif
4452 
4454 {
4455  res->data= (void*)loNewtonPolytope( (ideal)arg1->Data() );
4456  return FALSE;
4457 }
4458 
4460 {
4461  if ( !(rField_is_long_R(currRing)) )
4462  {
4463  WerrorS("Ground field not implemented!");
4464  return TRUE;
4465  }
4466 
4467  simplex * LP;
4468  matrix m;
4469 
4470  leftv v= args;
4471  if ( v->Typ() != MATRIX_CMD ) // 1: matrix
4472  return TRUE;
4473  else
4474  m= (matrix)(v->CopyD());
4475 
4476  LP = new simplex(MATROWS(m),MATCOLS(m));
4477  LP->mapFromMatrix(m);
4478 
4479  v= v->next;
4480  if ( v->Typ() != INT_CMD ) // 2: m = number of constraints
4481  return TRUE;
4482  else
4483  LP->m= (int)(long)(v->Data());
4484 
4485  v= v->next;
4486  if ( v->Typ() != INT_CMD ) // 3: n = number of variables
4487  return TRUE;
4488  else
4489  LP->n= (int)(long)(v->Data());
4490 
4491  v= v->next;
4492  if ( v->Typ() != INT_CMD ) // 4: m1 = number of <= constraints
4493  return TRUE;
4494  else
4495  LP->m1= (int)(long)(v->Data());
4496 
4497  v= v->next;
4498  if ( v->Typ() != INT_CMD ) // 5: m2 = number of >= constraints
4499  return TRUE;
4500  else
4501  LP->m2= (int)(long)(v->Data());
4502 
4503  v= v->next;
4504  if ( v->Typ() != INT_CMD ) // 6: m3 = number of == constraints
4505  return TRUE;
4506  else
4507  LP->m3= (int)(long)(v->Data());
4508 
4509 #ifdef mprDEBUG_PROT
4510  Print("m (constraints) %d\n",LP->m);
4511  Print("n (columns) %d\n",LP->n);
4512  Print("m1 (<=) %d\n",LP->m1);
4513  Print("m2 (>=) %d\n",LP->m2);
4514  Print("m3 (==) %d\n",LP->m3);
4515 #endif
4516 
4517  LP->compute();
4518 
4519  lists lres= (lists)omAlloc( sizeof(slists) );
4520  lres->Init( 6 );
4521 
4522  lres->m[0].rtyp= MATRIX_CMD; // output matrix
4523  lres->m[0].data=(void*)LP->mapToMatrix(m);
4524 
4525  lres->m[1].rtyp= INT_CMD; // found a solution?
4526  lres->m[1].data=(void*)(long)LP->icase;
4527 
4528  lres->m[2].rtyp= INTVEC_CMD;
4529  lres->m[2].data=(void*)LP->posvToIV();
4530 
4531  lres->m[3].rtyp= INTVEC_CMD;
4532  lres->m[3].data=(void*)LP->zrovToIV();
4533 
4534  lres->m[4].rtyp= INT_CMD;
4535  lres->m[4].data=(void*)(long)LP->m;
4536 
4537  lres->m[5].rtyp= INT_CMD;
4538  lres->m[5].data=(void*)(long)LP->n;
4539 
4540  res->data= (void*)lres;
4541 
4542  return FALSE;
4543 }
4544 
4545 BOOLEAN nuMPResMat( leftv res, leftv arg1, leftv arg2 )
4546 {
4547  ideal gls = (ideal)(arg1->Data());
4548  int imtype= (int)(long)arg2->Data();
4549 
4550  uResultant::resMatType mtype= determineMType( imtype );
4551 
4552  // check input ideal ( = polynomial system )
4553  if ( mprIdealCheck( gls, arg1->Name(), mtype, true ) != mprOk )
4554  {
4555  return TRUE;
4556  }
4557 
4558  uResultant *resMat= new uResultant( gls, mtype, false );
4559  if (resMat!=NULL)
4560  {
4561  res->rtyp = MODUL_CMD;
4562  res->data= (void*)resMat->accessResMat()->getMatrix();
4563  if (!errorreported) delete resMat;
4564  }
4565  return errorreported;
4566 }
4567 
4568 BOOLEAN nuLagSolve( leftv res, leftv arg1, leftv arg2, leftv arg3 )
4569 {
4570 
4571  poly gls;
4572  gls= (poly)(arg1->Data());
4573  int howclean= (int)(long)arg3->Data();
4574 
4575  if ( !(rField_is_R(currRing) ||
4576  rField_is_Q(currRing) ||
4579  {
4580  WerrorS("Ground field not implemented!");
4581  return TRUE;
4582  }
4583 
4586  {
4587  unsigned long int ii = (unsigned long int)arg2->Data();
4588  setGMPFloatDigits( ii, ii );
4589  }
4590 
4591  if ( gls == NULL || pIsConstant( gls ) )
4592  {
4593  WerrorS("Input polynomial is constant!");
4594  return TRUE;
4595  }
4596 
4597  int ldummy;
4598  int deg= currRing->pLDeg( gls, &ldummy, currRing );
4599  int i,vpos=0;
4600  poly piter;
4601  lists elist;
4602  lists rlist;
4603 
4604  elist= (lists)omAlloc( sizeof(slists) );
4605  elist->Init( 0 );
4606 
4607  if ( rVar(currRing) > 1 )
4608  {
4609  piter= gls;
4610  for ( i= 1; i <= rVar(currRing); i++ )
4611  if ( pGetExp( piter, i ) )
4612  {
4613  vpos= i;
4614  break;
4615  }
4616  while ( piter )
4617  {
4618  for ( i= 1; i <= rVar(currRing); i++ )
4619  if ( (vpos != i) && (pGetExp( piter, i ) != 0) )
4620  {
4621  WerrorS("The input polynomial must be univariate!");
4622  return TRUE;
4623  }
4624  pIter( piter );
4625  }
4626  }
4627 
4628  rootContainer * roots= new rootContainer();
4629  number * pcoeffs= (number *)omAlloc( (deg+1) * sizeof( number ) );
4630  piter= gls;
4631  for ( i= deg; i >= 0; i-- )
4632  {
4633  if ( piter && pTotaldegree(piter) == i )
4634  {
4635  pcoeffs[i]= nCopy( pGetCoeff( piter ) );
4636  //nPrint( pcoeffs[i] );PrintS(" ");
4637  pIter( piter );
4638  }
4639  else
4640  {
4641  pcoeffs[i]= nInit(0);
4642  }
4643  }
4644 
4645 #ifdef mprDEBUG_PROT
4646  for (i=deg; i >= 0; i--)
4647  {
4648  nPrint( pcoeffs[i] );PrintS(" ");
4649  }
4650  PrintLn();
4651 #endif
4652 
4653  roots->fillContainer( pcoeffs, NULL, 1, deg, rootContainer::onepoly, 1 );
4654  roots->solver( howclean );
4655 
4656  int elem= roots->getAnzRoots();
4657  char *dummy;
4658  int j;
4659 
4660  rlist= (lists)omAlloc( sizeof(slists) );
4661  rlist->Init( elem );
4662 
4664  {
4665  for ( j= 0; j < elem; j++ )
4666  {
4667  rlist->m[j].rtyp=NUMBER_CMD;
4668  rlist->m[j].data=(void *)nCopy((number)(roots->getRoot(j)));
4669  //rlist->m[j].data=(void *)(number)(roots->getRoot(j));
4670  }
4671  }
4672  else
4673  {
4674  for ( j= 0; j < elem; j++ )
4675  {
4676  dummy = complexToStr( (*roots)[j], gmp_output_digits, currRing->cf );
4677  rlist->m[j].rtyp=STRING_CMD;
4678  rlist->m[j].data=(void *)dummy;
4679  }
4680  }
4681 
4682  elist->Clean();
4683  //omFreeSize( (ADDRESS) elist, sizeof(slists) );
4684 
4685  // this is (via fillContainer) the same data as in root
4686  //for ( i= deg; i >= 0; i-- ) nDelete( &pcoeffs[i] );
4687  //omFreeSize( (ADDRESS) pcoeffs, (deg+1) * sizeof( number ) );
4688 
4689  delete roots;
4690 
4691  res->rtyp= LIST_CMD;
4692  res->data= (void*)rlist;
4693 
4694  return FALSE;
4695 }
4696 
4697 BOOLEAN nuVanderSys( leftv res, leftv arg1, leftv arg2, leftv arg3)
4698 {
4699  int i;
4700  ideal p,w;
4701  p= (ideal)arg1->Data();
4702  w= (ideal)arg2->Data();
4703 
4704  // w[0] = f(p^0)
4705  // w[1] = f(p^1)
4706  // ...
4707  // p can be a vector of numbers (multivariate polynom)
4708  // or one number (univariate polynom)
4709  // tdg = deg(f)
4710 
4711  int n= IDELEMS( p );
4712  int m= IDELEMS( w );
4713  int tdg= (int)(long)arg3->Data();
4714 
4715  res->data= (void*)NULL;
4716 
4717  // check the input
4718  if ( tdg < 1 )
4719  {
4720  WerrorS("Last input parameter must be > 0!");
4721  return TRUE;
4722  }
4723  if ( n != rVar(currRing) )
4724  {
4725  Werror("Size of first input ideal must be equal to %d!",rVar(currRing));
4726  return TRUE;
4727  }
4728  if ( m != (int)pow((double)tdg+1,(double)n) )
4729  {
4730  Werror("Size of second input ideal must be equal to %d!",
4731  (int)pow((double)tdg+1,(double)n));
4732  return TRUE;
4733  }
4734  if ( !(rField_is_Q(currRing) /* ||
4735  rField_is_R() || rField_is_long_R() ||
4736  rField_is_long_C()*/ ) )
4737  {
4738  WerrorS("Ground field not implemented!");
4739  return TRUE;
4740  }
4741 
4742  number tmp;
4743  number *pevpoint= (number *)omAlloc( n * sizeof( number ) );
4744  for ( i= 0; i < n; i++ )
4745  {
4746  pevpoint[i]=nInit(0);
4747  if ( (p->m)[i] )
4748  {
4749  tmp = pGetCoeff( (p->m)[i] );
4750  if ( nIsZero(tmp) || nIsOne(tmp) || nIsMOne(tmp) )
4751  {
4752  omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4753  WerrorS("Elements of first input ideal must not be equal to -1, 0, 1!");
4754  return TRUE;
4755  }
4756  } else tmp= NULL;
4757  if ( !nIsZero(tmp) )
4758  {
4759  if ( !pIsConstant((p->m)[i]))
4760  {
4761  omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4762  WerrorS("Elements of first input ideal must be numbers!");
4763  return TRUE;
4764  }
4765  pevpoint[i]= nCopy( tmp );
4766  }
4767  }
4768 
4769  number *wresults= (number *)omAlloc( m * sizeof( number ) );
4770  for ( i= 0; i < m; i++ )
4771  {
4772  wresults[i]= nInit(0);
4773  if ( (w->m)[i] && !nIsZero(pGetCoeff((w->m)[i])) )
4774  {
4775  if ( !pIsConstant((w->m)[i]))
4776  {
4777  omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4778  omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
4779  WerrorS("Elements of second input ideal must be numbers!");
4780  return TRUE;
4781  }
4782  wresults[i]= nCopy(pGetCoeff((w->m)[i]));
4783  }
4784  }
4785 
4786  vandermonde vm( m, n, tdg, pevpoint, FALSE );
4787  number *ncpoly= vm.interpolateDense( wresults );
4788  // do not free ncpoly[]!!
4789  poly rpoly= vm.numvec2poly( ncpoly );
4790 
4791  omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4792  omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
4793 
4794  res->data= (void*)rpoly;
4795  return FALSE;
4796 }
4797 
4799 {
4800  leftv v= args;
4801 
4802  ideal gls;
4803  int imtype;
4804  int howclean;
4805 
4806  // get ideal
4807  if ( v->Typ() != IDEAL_CMD )
4808  return TRUE;
4809  else gls= (ideal)(v->Data());
4810  v= v->next;
4811 
4812  // get resultant matrix type to use (0,1)
4813  if ( v->Typ() != INT_CMD )
4814  return TRUE;
4815  else imtype= (int)(long)v->Data();
4816  v= v->next;
4817 
4818  if (imtype==0)
4819  {
4820  ideal test_id=idInit(1,1);
4821  int j;
4822  for(j=IDELEMS(gls)-1;j>=0;j--)
4823  {
4824  if (gls->m[j]!=NULL)
4825  {
4826  test_id->m[0]=gls->m[j];
4827  intvec *dummy_w=id_QHomWeight(test_id, currRing);
4828  if (dummy_w!=NULL)
4829  {
4830  WerrorS("Newton polytope not of expected dimension");
4831  delete dummy_w;
4832  return TRUE;
4833  }
4834  }
4835  }
4836  }
4837 
4838  // get and set precision in digits ( > 0 )
4839  if ( v->Typ() != INT_CMD )
4840  return TRUE;
4841  else if ( !(rField_is_R(currRing) || rField_is_long_R(currRing) || \
4843  {
4844  unsigned long int ii=(unsigned long int)v->Data();
4845  setGMPFloatDigits( ii, ii );
4846  }
4847  v= v->next;
4848 
4849  // get interpolation steps (0,1,2)
4850  if ( v->Typ() != INT_CMD )
4851  return TRUE;
4852  else howclean= (int)(long)v->Data();
4853 
4854  uResultant::resMatType mtype= determineMType( imtype );
4855  int i,count;
4856  lists listofroots= NULL;
4857  number smv= NULL;
4858  BOOLEAN interpolate_det= (mtype==uResultant::denseResMat)?TRUE:FALSE;
4859 
4860  //emptylist= (lists)omAlloc( sizeof(slists) );
4861  //emptylist->Init( 0 );
4862 
4863  //res->rtyp = LIST_CMD;
4864  //res->data= (void *)emptylist;
4865 
4866  // check input ideal ( = polynomial system )
4867  if ( mprIdealCheck( gls, args->Name(), mtype ) != mprOk )
4868  {
4869  return TRUE;
4870  }
4871 
4872  uResultant * ures;
4873  rootContainer ** iproots;
4874  rootContainer ** muiproots;
4875  rootArranger * arranger;
4876 
4877  // main task 1: setup of resultant matrix
4878  ures= new uResultant( gls, mtype );
4879  if ( ures->accessResMat()->initState() != resMatrixBase::ready )
4880  {
4881  WerrorS("Error occurred during matrix setup!");
4882  return TRUE;
4883  }
4884 
4885  // if dense resultant, check if minor nonsingular
4886  if ( mtype == uResultant::denseResMat )
4887  {
4888  smv= ures->accessResMat()->getSubDet();
4889 #ifdef mprDEBUG_PROT
4890  PrintS("// Determinant of submatrix: ");nPrint(smv);PrintLn();
4891 #endif
4892  if ( nIsZero(smv) )
4893  {
4894  WerrorS("Unsuitable input ideal: Minor of resultant matrix is singular!");
4895  return TRUE;
4896  }
4897  }
4898 
4899  // main task 2: Interpolate specialized resultant polynomials
4900  if ( interpolate_det )
4901  iproots= ures->interpolateDenseSP( false, smv );
4902  else
4903  iproots= ures->specializeInU( false, smv );
4904 
4905  // main task 3: Interpolate specialized resultant polynomials
4906  if ( interpolate_det )
4907  muiproots= ures->interpolateDenseSP( true, smv );
4908  else
4909  muiproots= ures->specializeInU( true, smv );
4910 
4911 #ifdef mprDEBUG_PROT
4912  int c= iproots[0]->getAnzElems();
4913  for (i=0; i < c; i++) pWrite(iproots[i]->getPoly());
4914  c= muiproots[0]->getAnzElems();
4915  for (i=0; i < c; i++) pWrite(muiproots[i]->getPoly());
4916 #endif
4917 
4918  // main task 4: Compute roots of specialized polys and match them up
4919  arranger= new rootArranger( iproots, muiproots, howclean );
4920  arranger->solve_all();
4921 
4922  // get list of roots
4923  if ( arranger->success() )
4924  {
4925  arranger->arrange();
4926  listofroots= listOfRoots(arranger, gmp_output_digits );
4927  }
4928  else
4929  {
4930  WerrorS("Solver was unable to find any roots!");
4931  return TRUE;
4932  }
4933 
4934  // free everything
4935  count= iproots[0]->getAnzElems();
4936  for (i=0; i < count; i++) delete iproots[i];
4937  omFreeSize( (ADDRESS) iproots, count * sizeof(rootContainer*) );
4938  count= muiproots[0]->getAnzElems();
4939  for (i=0; i < count; i++) delete muiproots[i];
4940  omFreeSize( (ADDRESS) muiproots, count * sizeof(rootContainer*) );
4941 
4942  delete ures;
4943  delete arranger;
4944  nDelete( &smv );
4945 
4946  res->data= (void *)listofroots;
4947 
4948  //emptylist->Clean();
4949  // omFreeSize( (ADDRESS) emptylist, sizeof(slists) );
4950 
4951  return FALSE;
4952 }
4953 
4954 // from mpr_numeric.cc
4955 lists listOfRoots( rootArranger* self, const unsigned int oprec )
4956 {
4957  int i,j;
4958  int count= self->roots[0]->getAnzRoots(); // number of roots
4959  int elem= self->roots[0]->getAnzElems(); // number of koordinates per root
4960 
4961  lists listofroots= (lists)omAlloc( sizeof(slists) ); // must be done this way!
4962 
4963  if ( self->found_roots )
4964  {
4965  listofroots->Init( count );
4966 
4967  for (i=0; i < count; i++)
4968  {
4969  lists onepoint= (lists)omAlloc(sizeof(slists)); // must be done this way!
4970  onepoint->Init(elem);
4971  for ( j= 0; j < elem; j++ )
4972  {
4973  if ( !rField_is_long_C(currRing) )
4974  {
4975  onepoint->m[j].rtyp=STRING_CMD;
4976  onepoint->m[j].data=(void *)complexToStr((*self->roots[j])[i],oprec, currRing->cf);
4977  }
4978  else
4979  {
4980  onepoint->m[j].rtyp=NUMBER_CMD;
4981  onepoint->m[j].data=(void *)n_Copy((number)(self->roots[j]->getRoot(i)), currRing->cf);
4982  }
4983  onepoint->m[j].next= NULL;
4984  onepoint->m[j].name= NULL;
4985  }
4986  listofroots->m[i].rtyp=LIST_CMD;
4987  listofroots->m[i].data=(void *)onepoint;
4988  listofroots->m[j].next= NULL;
4989  listofroots->m[j].name= NULL;
4990  }
4991 
4992  }
4993  else
4994  {
4995  listofroots->Init( 0 );
4996  }
4997 
4998  return listofroots;
4999 }
5000 
5001 // from ring.cc
5003 {
5004  ring rg = NULL;
5005  if (h!=NULL)
5006  {
5007 // Print(" new ring:%s (l:%d)\n",IDID(h),IDLEV(h));
5008  rg = IDRING(h);
5009  if (rg==NULL) return; //id <>NULL, ring==NULL
5010  omCheckAddrSize((ADDRESS)h,sizeof(idrec));
5011  if (IDID(h)) // OB: ????
5012  omCheckAddr((ADDRESS)IDID(h));
5013  rTest(rg);
5014  }
5015 
5016  // clean up history
5018  {
5020  memset(&sLastPrinted,0,sizeof(sleftv));
5021  }
5022 
5023  if ((rg!=currRing)&&(currRing!=NULL))
5024  {
5026  if (DENOMINATOR_LIST!=NULL)
5027  {
5028  if (TEST_V_ALLWARN)
5029  Warn("deleting denom_list for ring change to %s",IDID(h));
5030  do
5031  {
5032  n_Delete(&(dd->n),currRing->cf);
5033  dd=dd->next;
5035  DENOMINATOR_LIST=dd;
5036  } while(DENOMINATOR_LIST!=NULL);
5037  }
5038  }
5039 
5040  // test for valid "currRing":
5041  if ((rg!=NULL) && (rg->idroot==NULL))
5042  {
5043  ring old=rg;
5044  rg=rAssure_HasComp(rg);
5045  if (old!=rg)
5046  {
5047  rKill(old);
5048  IDRING(h)=rg;
5049  }
5050  }
5051  /*------------ change the global ring -----------------------*/
5052  rChangeCurrRing(rg);
5053  currRingHdl = h;
5054 }
5055 
5057 {
5058  // change some bad orderings/combination into better ones
5059  leftv h=ord;
5060  while(h!=NULL)
5061  {
5062  BOOLEAN change=FALSE;
5063  intvec *iv = (intvec *)(h->data);
5064  // ws(-i) -> wp(i)
5065  if ((*iv)[1]==ringorder_ws)
5066  {
5067  BOOLEAN neg=TRUE;
5068  for(int i=2;i<iv->length();i++)
5069  if((*iv)[i]>=0) { neg=FALSE; break; }
5070  if (neg)
5071  {
5072  (*iv)[1]=ringorder_wp;
5073  for(int i=2;i<iv->length();i++)
5074  (*iv)[i]= - (*iv)[i];
5075  change=TRUE;
5076  }
5077  }
5078  // Ws(-i) -> Wp(i)
5079  if ((*iv)[1]==ringorder_Ws)
5080  {
5081  BOOLEAN neg=TRUE;
5082  for(int i=2;i<iv->length();i++)
5083  if((*iv)[i]>=0) { neg=FALSE; break; }
5084  if (neg)
5085  {
5086  (*iv)[1]=ringorder_Wp;
5087  for(int i=2;i<iv->length();i++)
5088  (*iv)[i]= -(*iv)[i];
5089  change=TRUE;
5090  }
5091  }
5092  // wp(1) -> dp
5093  if ((*iv)[1]==ringorder_wp)
5094  {
5095  BOOLEAN all_one=TRUE;
5096  for(int i=2;i<iv->length();i++)
5097  if((*iv)[i]!=1) { all_one=FALSE; break; }
5098  if (all_one)
5099  {
5100  intvec *iv2=new intvec(3);
5101  (*iv2)[0]=1;
5102  (*iv2)[1]=ringorder_dp;
5103  (*iv2)[2]=iv->length()-2;
5104  delete iv;
5105  iv=iv2;
5106  h->data=iv2;
5107  change=TRUE;
5108  }
5109  }
5110  // Wp(1) -> Dp
5111  if ((*iv)[1]==ringorder_Wp)
5112  {
5113  BOOLEAN all_one=TRUE;
5114  for(int i=2;i<iv->length();i++)
5115  if((*iv)[i]!=1) { all_one=FALSE; break; }
5116  if (all_one)
5117  {
5118  intvec *iv2=new intvec(3);
5119  (*iv2)[0]=1;
5120  (*iv2)[1]=ringorder_Dp;
5121  (*iv2)[2]=iv->length()-2;
5122  delete iv;
5123  iv=iv2;
5124  h->data=iv2;
5125  change=TRUE;
5126  }
5127  }
5128  // dp(1)/Dp(1)/rp(1) -> lp(1)
5129  if (((*iv)[1]==ringorder_dp)
5130  || ((*iv)[1]==ringorder_Dp)
5131  || ((*iv)[1]==ringorder_rp))
5132  {
5133  if (iv->length()==3)
5134  {
5135  if ((*iv)[2]==1)
5136  {
5137  (*iv)[1]=ringorder_lp;
5138  change=TRUE;
5139  }
5140  }
5141  }
5142  // lp(i),lp(j) -> lp(i+j)
5143  if(((*iv)[1]==ringorder_lp)
5144  && (h->next!=NULL))
5145  {
5146  intvec *iv2 = (intvec *)(h->next->data);
5147  if ((*iv2)[1]==ringorder_lp)
5148  {
5149  leftv hh=h->next;
5150  h->next=hh->next;
5151  hh->next=NULL;
5152  if ((*iv2)[0]==1)
5153  (*iv)[2] += 1; // last block unspecified, at least 1
5154  else
5155  (*iv)[2] += (*iv2)[2];
5156  hh->CleanUp();
5157  omFree(hh);
5158  change=TRUE;
5159  }
5160  }
5161  // -------------------
5162  if (!change) h=h->next;
5163  }
5164  return ord;
5165 }
5166 
5167 
5169 {
5170  int last = 0, o=0, n = 1, i=0, typ = 1, j;
5171  ord=rOptimizeOrdAsSleftv(ord);
5172  sleftv *sl = ord;
5173 
5174  // determine nBlocks
5175  while (sl!=NULL)
5176  {
5177  intvec *iv = (intvec *)(sl->data);
5178  if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C))
5179  i++;
5180  else if ((*iv)[1]==ringorder_L)
5181  {
5182  R->bitmask=(*iv)[2];
5183  n--;
5184  }
5185  else if (((*iv)[1]!=ringorder_a)
5186  && ((*iv)[1]!=ringorder_a64)
5187  && ((*iv)[1]!=ringorder_am))
5188  o++;
5189  n++;
5190  sl=sl->next;
5191  }
5192  // check whether at least one real ordering
5193  if (o==0)
5194  {
5195  WerrorS("invalid combination of orderings");
5196  return TRUE;
5197  }
5198  // if no c/C ordering is given, increment n
5199  if (i==0) n++;
5200  else if (i != 1)
5201  {
5202  // throw error if more than one is given
5203  WerrorS("more than one ordering c/C specified");
5204  return TRUE;
5205  }
5206 
5207  // initialize fields of R
5208  R->order=(int *)omAlloc0(n*sizeof(int));
5209  R->block0=(int *)omAlloc0(n*sizeof(int));
5210  R->block1=(int *)omAlloc0(n*sizeof(int));
5211  R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
5212 
5213  int *weights=(int*)omAlloc0((R->N+1)*sizeof(int));
5214 
5215  // init order, so that rBlocks works correctly
5216  for (j=0; j < n-1; j++)
5217  R->order[j] = (int) ringorder_unspec;
5218  // set last _C order, if no c/C order was given
5219  if (i == 0) R->order[n-2] = ringorder_C;
5220 
5221  /* init orders */
5222  sl=ord;
5223  n=-1;
5224  while (sl!=NULL)
5225  {
5226  intvec *iv;
5227  iv = (intvec *)(sl->data);
5228  if ((*iv)[1]!=ringorder_L)
5229  {
5230  n++;
5231 
5232  /* the format of an ordering:
5233  * iv[0]: factor
5234  * iv[1]: ordering
5235  * iv[2..end]: weights
5236  */
5237  R->order[n] = (*iv)[1];
5238  typ=1;
5239  switch ((*iv)[1])
5240  {
5241  case ringorder_ws:
5242  case ringorder_Ws:
5243  typ=-1;
5244  case ringorder_wp:
5245  case ringorder_Wp:
5246  R->wvhdl[n]=(int*)omAlloc((iv->length()-1)*sizeof(int));
5247  R->block0[n] = last+1;
5248  for (i=2; i<iv->length(); i++)
5249  {
5250  R->wvhdl[n][i-2] = (*iv)[i];
5251  last++;
5252  if (weights[last]==0) weights[last]=(*iv)[i]*typ;
5253  }
5254  R->block1[n] = si_min(last,R->N);
5255  break;
5256  case ringorder_ls:
5257  case ringorder_ds:
5258  case ringorder_Ds:
5259  case ringorder_rs:
5260  typ=-1;
5261  case ringorder_lp:
5262  case ringorder_dp:
5263  case ringorder_Dp:
5264  case ringorder_rp:
5265  R->block0[n] = last+1;
5266  if (iv->length() == 3) last+=(*iv)[2];
5267  else last += (*iv)[0];
5268  R->block1[n] = si_min(last,R->N);
5269  if (rCheckIV(iv)) return TRUE;
5270  for(i=si_min(rVar(R),R->block1[n]);i>=R->block0[n];i--)
5271  {
5272  if (weights[i]==0) weights[i]=typ;
5273  }
5274  break;
5275 
5276  case ringorder_s: // no 'rank' params!
5277  {
5278 
5279  if(iv->length() > 3)
5280  return TRUE;
5281 
5282  if(iv->length() == 3)
5283  {
5284  const int s = (*iv)[2];
5285  R->block0[n] = s;
5286  R->block1[n] = s;
5287  }
5288  break;
5289  }
5290  case ringorder_IS:
5291  {
5292  if(iv->length() != 3) return TRUE;
5293 
5294  const int s = (*iv)[2];
5295 
5296  if( 1 < s || s < -1 ) return TRUE;
5297 
5298  R->block0[n] = s;
5299  R->block1[n] = s;
5300  break;
5301  }
5302  case ringorder_S:
5303  case ringorder_c:
5304  case ringorder_C:
5305  {
5306  if (rCheckIV(iv)) return TRUE;
5307  break;
5308  }
5309  case ringorder_aa:
5310  case ringorder_a:
5311  {
5312  R->block0[n] = last+1;
5313  R->block1[n] = si_min(last+iv->length()-2 , R->N);
5314  R->wvhdl[n] = (int*)omAlloc((iv->length()-1)*sizeof(int));
5315  for (i=2; i<iv->length(); i++)
5316  {
5317  R->wvhdl[n][i-2]=(*iv)[i];
5318  last++;
5319  if (weights[last]==0) weights[last]=(*iv)[i]*typ;
5320  }
5321  last=R->block0[n]-1;
5322  break;
5323  }
5324  case ringorder_am:
5325  {
5326  R->block0[n] = last+1;
5327  R->block1[n] = si_min(last+iv->length()-2 , R->N);
5328  R->wvhdl[n] = (int*)omAlloc(iv->length()*sizeof(int));
5329  if (R->block1[n]- R->block0[n]+2>=iv->length())
5330  WarnS("missing module weights");
5331  for (i=2; i<=(R->block1[n]-R->block0[n]+2); i++)
5332  {
5333  R->wvhdl[n][i-2]=(*iv)[i];
5334  last++;
5335  if (weights[last]==0) weights[last]=(*iv)[i]*typ;
5336  }
5337  R->wvhdl[n][i-2]=iv->length() -3 -(R->block1[n]- R->block0[n]);
5338  for (; i<iv->length(); i++)
5339  {
5340  R->wvhdl[n][i-1]=(*iv)[i];
5341  }
5342  last=R->block0[n]-1;
5343  break;
5344  }
5345  case ringorder_a64:
5346  {
5347  R->block0[n] = last+1;
5348  R->block1[n] = si_min(last+iv->length()-2 , R->N);
5349  R->wvhdl[n] = (int*)omAlloc((iv->length()-1)*sizeof(int64));
5350  int64 *w=(int64 *)R->wvhdl[n];
5351  for (i=2; i<iv->length(); i++)
5352  {
5353  w[i-2]=(*iv)[i];
5354  last++;
5355  if (weights[last]==0) weights[last]=(*iv)[i]*typ;
5356  }
5357  last=R->block0[n]-1;
5358  break;
5359  }
5360  case ringorder_M:
5361  {
5362  int Mtyp=rTypeOfMatrixOrder(iv);
5363  if (Mtyp==0) return TRUE;
5364  if (Mtyp==-1) typ = -1;
5365 
5366  R->wvhdl[n] =( int *)omAlloc((iv->length()-1)*sizeof(int));
5367  for (i=2; i<iv->length();i++)
5368  R->wvhdl[n][i-2]=(*iv)[i];
5369 
5370  R->block0[n] = last+1;
5371  last += (int)sqrt((double)(iv->length()-2));
5372  R->block1[n] = si_min(last,R->N);
5373  for(i=R->block1[n];i>=R->block0[n];i--)
5374  {
5375  if (weights[i]==0) weights[i]=typ;
5376  }
5377  break;
5378  }
5379 
5380  case ringorder_no:
5381  R->order[n] = ringorder_unspec;
5382  return TRUE;
5383 
5384  default:
5385  Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
5386  R->order[n] = ringorder_unspec;
5387  return TRUE;
5388  }
5389  }
5390  if (last>R->N)
5391  {
5392  Werror("mismatch of number of vars (%d) and ordering (>=%d vars)",
5393  R->N,last);
5394  return TRUE;
5395  }
5396  sl=sl->next;
5397  }
5398  // find OrdSgn:
5399  R->OrdSgn = 1;
5400  for(i=1;i<=R->N;i++)
5401  { if (weights[i]<0) { R->OrdSgn=-1;break; }}
5402  omFree(weights);
5403 
5404  // check for complete coverage
5405  while ( n >= 0 && (
5406  (R->order[n]==ringorder_c)
5407  || (R->order[n]==ringorder_C)
5408  || (R->order[n]==ringorder_s)
5409  || (R->order[n]==ringorder_S)
5410  || (R->order[n]==ringorder_IS)
5411  )) n--;
5412 
5413  assume( n >= 0 );
5414 
5415  if (R->block1[n] != R->N)
5416  {
5417  if (((R->order[n]==ringorder_dp) ||
5418  (R->order[n]==ringorder_ds) ||
5419  (R->order[n]==ringorder_Dp) ||
5420  (R->order[n]==ringorder_Ds) ||
5421  (R->order[n]==ringorder_rp) ||
5422  (R->order[n]==ringorder_rs) ||
5423  (R->order[n]==ringorder_lp) ||
5424  (R->order[n]==ringorder_ls))
5425  &&
5426  R->block0[n] <= R->N)
5427  {
5428  R->block1[n] = R->N;
5429  }
5430  else
5431  {
5432  Werror("mismatch of number of vars (%d) and ordering (%d vars)",
5433  R->N,R->block1[n]);
5434  return TRUE;
5435  }
5436  }
5437  return FALSE;
5438 }
5439 
5441 {
5442 
5443  while(sl!=NULL)
5444  {
5445  if ((sl->rtyp == IDHDL)||(sl->rtyp==ALIAS_CMD))
5446  {
5447  *p = omStrDup(sl->Name());
5448  }
5449  else if (sl->name!=NULL)
5450  {
5451  *p = (char*)sl->name;
5452  sl->name=NULL;
5453  }
5454  else if (sl->rtyp==POLY_CMD)
5455  {
5456  sleftv s_sl;
5457  iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
5458  if (s_sl.name != NULL)
5459  {
5460  *p = (char*)s_sl.name; s_sl.name=NULL;
5461  }
5462  else
5463  *p = NULL;
5464  sl->next = s_sl.next;
5465  s_sl.next = NULL;
5466  s_sl.CleanUp();
5467  if (*p == NULL) return TRUE;
5468  }
5469  else return TRUE;
5470  p++;
5471  sl=sl->next;
5472  }
5473  return FALSE;
5474 }
5475 
5476 const short MAX_SHORT = 32767; // (1 << (sizeof(short)*8)) - 1;
5477 
5478 ////////////////////
5479 //
5480 // rInit itself:
5481 //
5482 // INPUT: pn: ch & parameter (names), rv: variable (names)
5483 // ord: ordering (all !=NULL)
5484 // RETURN: currRingHdl on success
5485 // NULL on error
5486 // NOTE: * makes new ring to current ring, on success
5487 // * considers input sleftv's as read-only
5488 ring rInit(leftv pn, leftv rv, leftv ord)
5489 {
5490 #ifdef HAVE_RINGS
5491  //unsigned int ringtype = 0;
5492  mpz_ptr modBase = NULL;
5493  unsigned int modExponent = 1;
5494 #endif
5495  int float_len=0;
5496  int float_len2=0;
5497  ring R = NULL;
5498  //BOOLEAN ffChar=FALSE;
5499 
5500  /* ch -------------------------------------------------------*/
5501  // get ch of ground field
5502 
5503  // allocated ring
5504  R = (ring) omAlloc0Bin(sip_sring_bin);
5505 
5506  coeffs cf = NULL;
5507 
5508  assume( pn != NULL );
5509  const int P = pn->listLength();
5510 
5511  if (pn->Typ()==CRING_CMD)
5512  {
5513  cf=(coeffs)pn->CopyD();
5514  leftv pnn=pn;
5515  if(P>1) /*parameter*/
5516  {
5517  pnn = pnn->next;
5518  const int pars = pnn->listLength();
5519  assume( pars > 0 );
5520  char ** names = (char**)omAlloc0(pars * sizeof(char_ptr));
5521 
5522  if (rSleftvList2StringArray(pnn, names))
5523  {
5524  WerrorS("parameter expected");
5525  goto rInitError;
5526  }
5527 
5528  TransExtInfo extParam;
5529 
5530  extParam.r = rDefault( cf, pars, names); // Q/Zp [ p_1, ... p_pars ]
5531  for(int i=pars-1; i>=0;i--)
5532  {
5533  omFree(names[i]);
5534  }
5535  omFree(names);
5536 
5537  cf = nInitChar(n_transExt, &extParam);
5538  }
5539  assume( cf != NULL );
5540  }
5541  else if (pn->Typ()==INT_CMD)
5542  {
5543  int ch = (int)(long)pn->Data();
5544  leftv pnn=pn;
5545 
5546  /* parameter? -------------------------------------------------------*/
5547  pnn = pnn->next;
5548 
5549  if (pnn == NULL) // no params!?
5550  {
5551  if (ch!=0)
5552  {
5553  int ch2=IsPrime(ch);
5554  if ((ch<2)||(ch!=ch2))
5555  {
5556  Warn("%d is invalid as characteristic of the ground field. 32003 is used.", ch);
5557  ch=32003;
5558  }
5559  cf = nInitChar(n_Zp, (void*)(long)ch);
5560  }
5561  else
5562  cf = nInitChar(n_Q, (void*)(long)ch);
5563  }
5564  else
5565  {
5566  const int pars = pnn->listLength();
5567 
5568  assume( pars > 0 );
5569 
5570  // predefined finite field: (p^k, a)
5571  if ((ch!=0) && (ch!=IsPrime(ch)) && (pars == 1))
5572  {
5573  GFInfo param;
5574 
5575  param.GFChar = ch;
5576  param.GFDegree = 1;
5577  param.GFPar_name = pnn->name;
5578 
5579  cf = nInitChar(n_GF, &param);
5580  }
5581  else // (0/p, a, b, ..., z)
5582  {
5583  if ((ch!=0) && (ch!=IsPrime(ch)))
5584  {
5585  WerrorS("too many parameters");
5586  goto rInitError;
5587  }
5588 
5589  char ** names = (char**)omAlloc0(pars * sizeof(char_ptr));
5590 
5591  if (rSleftvList2StringArray(pnn, names))
5592  {
5593  WerrorS("parameter expected");
5594  goto rInitError;
5595  }
5596 
5597  TransExtInfo extParam;
5598 
5599  extParam.r = rDefault( ch, pars, names); // Q/Zp [ p_1, ... p_pars ]
5600  for(int i=pars-1; i>=0;i--)
5601  {
5602  omFree(names[i]);
5603  }
5604  omFree(names);
5605 
5606  cf = nInitChar(n_transExt, &extParam);
5607  }
5608  }
5609 
5610  //if (cf==NULL) ->Error: Invalid ground field specification
5611  }
5612  else if ((pn->name != NULL)
5613  && ((strcmp(pn->name,"real")==0) || (strcmp(pn->name,"complex")==0)))
5614  {
5615  leftv pnn=pn->next;
5616  BOOLEAN complex_flag=(strcmp(pn->name,"complex")==0);
5617  if ((pnn!=NULL) && (pnn->Typ()==INT_CMD))
5618  {
5619  float_len=(int)(long)pnn->Data();
5620  float_len2=float_len;
5621  pnn=pnn->next;
5622  if ((pnn!=NULL) && (pnn->Typ()==INT_CMD))
5623  {
5624  float_len2=(int)(long)pnn->Data();
5625  pnn=pnn->next;
5626  }
5627  }
5628 
5629  if (!complex_flag)
5630  complex_flag= (pnn!=NULL) && (pnn->name!=NULL);
5631  if( !complex_flag && (float_len2 <= (short)SHORT_REAL_LENGTH))
5632  cf=nInitChar(n_R, NULL);
5633  else // longR or longC?
5634  {
5635  LongComplexInfo param;
5636 
5637  param.float_len = si_min (float_len, 32767);
5638  param.float_len2 = si_min (float_len2, 32767);
5639 
5640  // set the parameter name
5641  if (complex_flag)
5642  {
5643  if (param.float_len < SHORT_REAL_LENGTH)
5644  {
5647  }
5648  if ((pnn == NULL) || (pnn->name == NULL))
5649  param.par_name=(const char*)"i"; //default to i
5650  else
5651  param.par_name = (const char*)pnn->name;
5652  }
5653 
5654  cf = nInitChar(complex_flag ? n_long_C: n_long_R, (void*)&param);
5655  }
5656  assume( cf != NULL );
5657  }
5658 #ifdef HAVE_RINGS
5659  else if ((pn->name != NULL) && (strcmp(pn->name, "integer") == 0))
5660  {
5661  // TODO: change to use coeffs_BIGINT!?
5662  modBase = (mpz_ptr) omAlloc(sizeof(mpz_t));
5663  mpz_init_set_si(modBase, 0);
5664  if (pn->next!=NULL)
5665  {
5666  leftv pnn=pn;
5667  if (pnn->next->Typ()==INT_CMD)
5668  {
5669  pnn=pnn->next;
5670  mpz_set_ui(modBase, (int)(long) pnn->Data());
5671  if ((pnn->next!=NULL) && (pnn->next->Typ()==INT_CMD))
5672  {
5673  pnn=pnn->next;
5674  modExponent = (long) pnn->Data();
5675  }
5676  while ((pnn->next!=NULL) && (pnn->next->Typ()==INT_CMD))
5677  {
5678  pnn=pnn->next;
5679  mpz_mul_ui(modBase, modBase, (int)(long) pnn->Data());
5680  }
5681  }
5682  else if (pnn->next->Typ()==BIGINT_CMD)
5683  {
5684  number p=(number)pnn->next->CopyD();
5685  nlGMP(p,(number)modBase,coeffs_BIGINT); // TODO? // extern void nlGMP(number &i, number n, const coeffs r); // FIXME: n_MPZ( modBase, p, coeffs_BIGINT); ?
5686  n_Delete(&p,coeffs_BIGINT);
5687  }
5688  }
5689  else
5690  cf=nInitChar(n_Z,NULL);
5691 
5692  if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_cmp_ui(modBase, 0) < 0))
5693  {
5694  WerrorS("Wrong ground ring specification (module is 1)");
5695  goto rInitError;
5696  }
5697  if (modExponent < 1)
5698  {
5699  WerrorS("Wrong ground ring specification (exponent smaller than 1");
5700  goto rInitError;
5701  }
5702  // module is 0 ---> integers ringtype = 4;
5703  // we have an exponent
5704  if (modExponent > 1 && cf == NULL)
5705  {
5706  if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(unsigned long)))
5707  {
5708  /* this branch should be active for modExponent = 2..32 resp. 2..64,
5709  depending on the size of a long on the respective platform */
5710  //ringtype = 1; // Use Z/2^ch
5711  cf=nInitChar(n_Z2m,(void*)(long)modExponent);
5712  mpz_clear(modBase);
5713  omFreeSize (modBase, sizeof (mpz_t));
5714  }
5715  else
5716  {
5717  if (mpz_cmp_ui(modBase,0)==0)
5718  {
5719  WerrorS("modulus must not be 0 or parameter not allowed");
5720  goto rInitError;
5721  }
5722  //ringtype = 3;
5723  ZnmInfo info;
5724  info.base= modBase;
5725  info.exp= modExponent;
5726  cf=nInitChar(n_Znm,(void*) &info); //exponent is missing
5727  }
5728  }
5729  // just a module m > 1
5730  else if (cf == NULL)
5731  {
5732  if (mpz_cmp_ui(modBase,0)==0)
5733  {
5734  WerrorS("modulus must not be 0 or parameter not allowed");
5735  goto rInitError;
5736  }
5737  //ringtype = 2;
5738  ZnmInfo info;
5739  info.base= modBase;
5740  info.exp= modExponent;
5741  cf=nInitChar(n_Zn,(void*) &info);
5742  }
5743  assume( cf != NULL );
5744  }
5745 #endif
5746  // ring NEW = OLD, (), (); where OLD is a polynomial ring...
5747  else if ((pn->Typ()==RING_CMD) && (P == 1))
5748  {
5749  TransExtInfo extParam;
5750  extParam.r = (ring)pn->Data();
5751  cf = nInitChar(n_transExt, &extParam);
5752  }
5753  //else if ((pn->Typ()==QRING_CMD) && (P == 1)) // same for qrings - which should be fields!?
5754  //{
5755  // AlgExtInfo extParam;
5756  // extParam.r = (ring)pn->Data();
5757 
5758  // cf = nInitChar(n_algExt, &extParam); // Q[a]/<minideal>
5759  //}
5760  else
5761  {
5762  WerrorS("Wrong or unknown ground field specification");
5763 #if 0
5764 // debug stuff for unknown cf descriptions:
5765  sleftv* p = pn;
5766  while (p != NULL)
5767  {
5768  Print( "pn[%p]: type: %d [%s]: %p, name: %s", (void*)p, p->Typ(), Tok2Cmdname(p->Typ()), p->Data(), (p->name == NULL? "NULL" : p->name) );
5769  PrintLn();
5770  p = p->next;
5771  }
5772 #endif
5773  goto rInitError;
5774  }
5775 
5776  /*every entry in the new ring is initialized to 0*/
5777 
5778  /* characteristic -----------------------------------------------*/
5779  /* input: 0 ch=0 : Q parameter=NULL ffChar=FALSE float_len
5780  * 0 1 : Q(a,...) *names FALSE
5781  * 0 -1 : R NULL FALSE 0
5782  * 0 -1 : R NULL FALSE prec. >6
5783  * 0 -1 : C *names FALSE prec. 0..?
5784  * p p : Fp NULL FALSE
5785  * p -p : Fp(a) *names FALSE
5786  * q q : GF(q=p^n) *names TRUE
5787  */
5788  if (cf==NULL)
5789  {
5790  WerrorS("Invalid ground field specification");
5791  goto rInitError;
5792 // const int ch=32003;
5793 // cf=nInitChar(n_Zp, (void*)(long)ch);
5794  }
5795 
5796  assume( R != NULL );
5797 
5798  R->cf = cf;
5799 
5800  /* names and number of variables-------------------------------------*/
5801  {
5802  int l=rv->listLength();
5803 
5804  if (l>MAX_SHORT)
5805  {
5806  Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
5807  goto rInitError;
5808  }
5809  R->N = l; /*rv->listLength();*/
5810  }
5811  R->names = (char **)omAlloc0(R->N * sizeof(char_ptr));
5812  if (rSleftvList2StringArray(rv, R->names))
5813  {
5814  WerrorS("name of ring variable expected");
5815  goto rInitError;
5816  }
5817 
5818  /* check names and parameters for conflicts ------------------------- */
5819  rRenameVars(R); // conflicting variables will be renamed
5820  /* ordering -------------------------------------------------------------*/
5821  if (rSleftvOrdering2Ordering(ord, R))
5822  goto rInitError;
5823 
5824  // Complete the initialization
5825  if (rComplete(R,1))
5826  goto rInitError;
5827 
5828 /*#ifdef HAVE_RINGS
5829 // currently, coefficients which are ring elements require a global ordering:
5830  if (rField_is_Ring(R) && (R->OrdSgn==-1))
5831  {
5832  WerrorS("global ordering required for these coefficients");
5833  goto rInitError;
5834  }
5835 #endif*/
5836 
5837  rTest(R);
5838 
5839  // try to enter the ring into the name list
5840  // need to clean up sleftv here, before this ring can be set to
5841  // new currRing or currRing can be killed beacuse new ring has
5842  // same name
5843  pn->CleanUp();
5844  rv->CleanUp();
5845  ord->CleanUp();
5846  //if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
5847  // goto rInitError;
5848 
5849  //memcpy(IDRING(tmp),R,sizeof(*R));
5850  // set current ring
5851  //omFreeBin(R, ip_sring_bin);
5852  //return tmp;
5853  return R;
5854 
5855  // error case:
5856  rInitError:
5857  if ((R != NULL)&&(R->cf!=NULL)) rDelete(R);
5858  pn->CleanUp();
5859  rv->CleanUp();
5860  ord->CleanUp();
5861  return NULL;
5862 }
5863 
5864 ring rSubring(ring org_ring, sleftv* rv)
5865 {
5866  ring R = rCopy0(org_ring);
5867  int *perm=(int *)omAlloc0((org_ring->N+1)*sizeof(int));
5868  int n = rBlocks(org_ring), i=0, j;
5869 
5870  /* names and number of variables-------------------------------------*/
5871  {
5872  int l=rv->listLength();
5873  if (l>MAX_SHORT)
5874  {
5875  Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
5876  goto rInitError;
5877  }
5878  R->N = l; /*rv->listLength();*/
5879  }
5880  omFree(R->names);
5881  R->names = (char **)omAlloc0(R->N * sizeof(char_ptr));
5882  if (rSleftvList2StringArray(rv, R->names))
5883  {
5884  WerrorS("name of ring variable expected");
5885  goto rInitError;
5886  }
5887 
5888  /* check names for subring in org_ring ------------------------- */
5889  {
5890  i=0;
5891 
5892  for(j=0;j<R->N;j++)
5893  {
5894  for(;i<org_ring->N;i++)
5895  {
5896  if (strcmp(org_ring->names[i],R->names[j])==0)
5897  {
5898  perm[i+1]=j+1;
5899  break;
5900  }
5901  }
5902  if (i>org_ring->N)
5903  {
5904  Werror("variable %d (%s) not in basering",j+1,R->names[j]);
5905  break;
5906  }
5907  }
5908  }
5909  //Print("perm=");
5910  //for(i=1;i<org_ring->N;i++) Print("v%d -> v%d\n",i,perm[i]);
5911  /* ordering -------------------------------------------------------------*/
5912 
5913  for(i=0;i<n;i++)
5914  {
5915  int min_var=-1;
5916  int max_var=-1;
5917  for(j=R->block0[i];j<=R->block1[i];j++)
5918  {
5919  if (perm[j]>0)
5920  {
5921  if (min_var==-1) min_var=perm[j];
5922  max_var=perm[j];
5923  }
5924  }
5925  if (min_var!=-1)
5926  {
5927  //Print("block %d: old %d..%d, now:%d..%d\n",
5928  // i,R->block0[i],R->block1[i],min_var,max_var);
5929  R->block0[i]=min_var;
5930  R->block1[i]=max_var;
5931  if (R->wvhdl[i]!=NULL)
5932  {
5933  omFree(R->wvhdl[i]);
5934  R->wvhdl[i]=(int*)omAlloc0((max_var-min_var+1)*sizeof(int));
5935  for(j=org_ring->block0[i];j<=org_ring->block1[i];j++)
5936  {
5937  if (perm[j]>0)
5938  {
5939  R->wvhdl[i][perm[j]-R->block0[i]]=
5940  org_ring->wvhdl[i][j-org_ring->block0[i]];
5941  //Print("w%d=%d (orig_w%d)\n",perm[j],R->wvhdl[i][perm[j]-R->block0[i]],j);
5942  }
5943  }
5944  }
5945  }
5946  else
5947  {
5948  if(R->block0[i]>0)
5949  {
5950  //Print("skip block %d\n",i);
5951  R->order[i]=ringorder_unspec;
5952  if (R->wvhdl[i] !=NULL) omFree(R->wvhdl[i]);
5953  R->wvhdl[i]=NULL;
5954  }
5955  //else Print("keep block %d\n",i);
5956  }
5957  }
5958  i=n-1;
5959  while(i>0)
5960  {
5961  // removed unneded blocks
5962  if(R->order[i-1]==ringorder_unspec)
5963  {
5964  for(j=i;j<=n;j++)
5965  {
5966  R->order[j-1]=R->order[j];
5967  R->block0[j-1]=R->block0[j];
5968  R->block1[j-1]=R->block1[j];
5969  if (R->wvhdl[j-1] !=NULL) omFree(R->wvhdl[j-1]);
5970  R->wvhdl[j-1]=R->wvhdl[j];
5971  }
5972  R->order[n]=ringorder_unspec;
5973  n--;
5974  }
5975  i--;
5976  }
5977  n=rBlocks(org_ring)-1;
5978  while (R->order[n]==0) n--;
5979  while (R->order[n]==ringorder_unspec) n--;
5980  if ((R->order[n]==ringorder_c) || (R->order[n]==ringorder_C)) n--;
5981  if (R->block1[n] != R->N)
5982  {
5983  if (((R->order[n]==ringorder_dp) ||
5984  (R->order[n]==ringorder_ds) ||
5985  (R->order[n]==ringorder_Dp) ||
5986  (R->order[n]==ringorder_Ds) ||
5987  (R->order[n]==ringorder_rp) ||
5988  (R->order[n]==ringorder_rs) ||
5989  (R->order[n]==ringorder_lp) ||
5990  (R->order[n]==ringorder_ls))
5991  &&
5992  R->block0[n] <= R->N)
5993  {
5994  R->block1[n] = R->N;
5995  }
5996  else
5997  {
5998  Werror("mismatch of number of vars (%d) and ordering (%d vars) in block %d",
5999  R->N,R->block1[n],n);
6000  return NULL;
6001  }
6002  }
6003  omFree(perm);
6004  // find OrdSgn:
6005  R->OrdSgn = org_ring->OrdSgn; // IMPROVE!
6006  //for(i=1;i<=R->N;i++)
6007  //{ if (weights[i]<0) { R->OrdSgn=-1;break; }}
6008  //omFree(weights);
6009  // Complete the initialization
6010  if (rComplete(R,1))
6011  goto rInitError;
6012 
6013  rTest(R);
6014 
6015  if (rv != NULL) rv->CleanUp();
6016 
6017  return R;
6018 
6019  // error case:
6020  rInitError:
6021  if (R != NULL) rDelete(R);
6022  if (rv != NULL) rv->CleanUp();
6023  return NULL;
6024 }
6025 
6026 void rKill(ring r)
6027 {
6028  if ((r->ref<=0)&&(r->order!=NULL))
6029  {
6030 #ifdef RDEBUG
6031  if (traceit &TRACE_SHOW_RINGS) Print("kill ring %lx\n",(long)r);
6032 #endif
6033  if (r->qideal!=NULL)
6034  {
6035  id_Delete(&r->qideal, r);
6036  r->qideal = NULL;
6037  }
6038  int j;
6039  for (j=0;j<myynest;j++)
6040  {
6041  if (iiLocalRing[j]==r)
6042  {
6043  if (j==0) WarnS("killing the basering for level 0");
6044  iiLocalRing[j]=NULL;
6045  }
6046  }
6047 // any variables depending on r ?
6048  while (r->idroot!=NULL)
6049  {
6050  r->idroot->lev=myynest; // avoid warning about kill global objects
6051  killhdl2(r->idroot,&(r->idroot),r);
6052  }
6053  if (r==currRing)
6054  {
6055  // all dependend stuff is done, clean global vars:
6056  if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
6058  {
6060  }
6061  //if ((myynest>0) && (iiRETURNEXPR.RingDependend()))
6062  //{
6063  // WerrorS("return value depends on local ring variable (export missing ?)");
6064  // iiRETURNEXPR.CleanUp();
6065  //}
6066  currRing=NULL;
6067  currRingHdl=NULL;
6068  }
6069 
6070  /* nKillChar(r); will be called from inside of rDelete */
6071  rDelete(r);
6072  return;
6073  }
6074  r->ref--;
6075 }
6076 
6077 void rKill(idhdl h)
6078 {
6079  ring r = IDRING(h);
6080  int ref=0;
6081  if (r!=NULL)
6082  {
6083  // avoid, that sLastPrinted is the last reference to the base ring:
6084  // clean up before killing the last "named" refrence:
6085  if ((sLastPrinted.rtyp==RING_CMD)
6086  && (sLastPrinted.data==(void*)r))
6087  {
6088  sLastPrinted.CleanUp(r);
6089  }
6090  ref=r->ref;
6091  rKill(r);
6092  }
6093  if (h==currRingHdl)
6094  {
6095  if (ref<=0) { currRing=NULL; currRingHdl=NULL;}
6096  else
6097  {
6099  }
6100  }
6101 }
6102 
6104 {
6105  idhdl h=root;
6106  while (h!=NULL)
6107  {
6108  if ((IDTYP(h)==RING_CMD)
6109  && (h!=n)
6110  && (IDRING(h)==r)
6111  )
6112  {
6113  return h;
6114  }
6115  h=IDNEXT(h);
6116  }
6117  return NULL;
6118 }
6119 
6120 extern BOOLEAN jjPROC(leftv res, leftv u, leftv v);
6121 ideal kGroebner(ideal F, ideal Q)
6122 {
6123  //test|=Sy_bit(OPT_PROT);
6124  idhdl save_ringhdl=currRingHdl;
6125  ideal resid;
6126  idhdl new_ring=NULL;
6127  if ((currRingHdl==NULL) || (IDRING(currRingHdl)!=currRing))
6128  {
6129  currRingHdl=enterid(omStrDup(" GROEBNERring"),0,RING_CMD,&IDROOT,FALSE);
6130  new_ring=currRingHdl;
6132  }
6133  sleftv v; memset(&v,0,sizeof(v)); v.rtyp=IDEAL_CMD; v.data=(char *) F;
6134  idhdl h=ggetid("groebner");
6135  sleftv u; memset(&u,0,sizeof(u)); u.rtyp=IDHDL; u.data=(char *) h;
6136  u.name=IDID(h);
6137 
6138  sleftv res; memset(&res,0,sizeof(res));
6139  if(jjPROC(&res,&u,&v))
6140  {
6141  resid=kStd(F,Q,testHomog,NULL);
6142  }
6143  else
6144  {
6145  //printf("typ:%d\n",res.rtyp);
6146  resid=(ideal)(res.data);
6147  }
6148  // cleanup GROEBNERring, save_ringhdl, u,v,(res )
6149  if (new_ring!=NULL)
6150  {
6151  idhdl h=IDROOT;
6152  if (h==new_ring) IDROOT=h->next;
6153  else
6154  {
6155  while ((h!=NULL) &&(h->next!=new_ring)) h=h->next;
6156  if (h!=NULL) h->next=h->next->next;
6157  }
6158  if (h!=NULL) omFreeSize(h,sizeof(*h));
6159  }
6160  currRingHdl=save_ringhdl;
6161  u.CleanUp();
6162  v.CleanUp();
6163  return resid;
6164 }
6165 
6166 static void jjINT_S_TO_ID(int n,int *e, leftv res)
6167 {
6168  if (n==0) n=1;
6169  ideal l=idInit(n,1);
6170  int i;
6171  poly p;
6172  for(i=rVar(currRing);i>0;i--)
6173  {
6174  if (e[i]>0)
6175  {
6176  n--;
6177  p=pOne();
6178  pSetExp(p,i,1);
6179  pSetm(p);
6180  l->m[n]=p;
6181  if (n==0) break;
6182  }
6183  }
6184  res->data=(char*)l;
6185  setFlag(res,FLAG_STD);
6186  omFreeSize((ADDRESS)e,(rVar(currRing)+1)*sizeof(int));
6187 }
6189 {
6190  int *e=(int *)omAlloc0((rVar(currRing)+1)*sizeof(int));
6191  int n=pGetVariables((poly)u->Data(),e);
6192  jjINT_S_TO_ID(n,e,res);
6193  return FALSE;
6194 }
6195 
6197 {
6198  int *e=(int *)omAlloc0((rVar(currRing)+1)*sizeof(int));
6199  ideal I=(ideal)u->Data();
6200  int i;
6201  int n=0;
6202  for(i=I->nrows*I->ncols-1;i>=0;i--)
6203  {
6204  int n0=pGetVariables(I->m[i],e);
6205  if (n0>n) n=n0;
6206  }
6207  jjINT_S_TO_ID(n,e,res);
6208  return FALSE;
6209 }
6210 
6211 void paPrint(const char *n,package p)
6212 {
6213  Print(" %s (",n);
6214  switch (p->language)
6215  {
6216  case LANG_SINGULAR: PrintS("S"); break;
6217  case LANG_C: PrintS("C"); break;
6218  case LANG_TOP: PrintS("T"); break;
6219  case LANG_NONE: PrintS("N"); break;
6220  default: PrintS("U");
6221  }
6222  if(p->libname!=NULL)
6223  Print(",%s", p->libname);
6224  PrintS(")");
6225 }
6226 
6228 {
6229  intvec *aa=(intvec*)a->Data();
6230  sleftv tmp_out;
6231  sleftv tmp_in;
6232  leftv curr=res;
6233  BOOLEAN bo=FALSE;
6234  for(int i=0;i<aa->length(); i++)
6235  {
6236  memset(&tmp_in,0,sizeof(tmp_in));
6237  tmp_in.rtyp=INT_CMD;
6238  tmp_in.data=(void*)(long)(*aa)[i];
6239  if (proc==NULL)
6240  bo=iiExprArith1(&tmp_out,&tmp_in,op);
6241  else
6242  bo=jjPROC(&tmp_out,proc,&tmp_in);
6243  if (bo)
6244  {
6245  res->CleanUp(currRing);
6246  Werror("apply fails at index %d",i+1);
6247  return TRUE;
6248  }
6249  if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6250  else
6251  {
6252  curr->next=(leftv)omAllocBin(sleftv_bin);
6253  curr=curr->next;
6254  memcpy(curr,&tmp_out,sizeof(tmp_out));
6255  }
6256  }
6257  return FALSE;
6258 }
6260 {
6261  WerrorS("not implemented");
6262  return TRUE;
6263 }
6265 {
6266  WerrorS("not implemented");
6267  return TRUE;
6268 }
6269 BOOLEAN iiApplyLIST(leftv res, leftv a, int op, leftv proc)
6270 {
6271  lists aa=(lists)a->Data();
6272  sleftv tmp_out;
6273  sleftv tmp_in;
6274  leftv curr=res;
6275  BOOLEAN bo=FALSE;
6276  for(int i=0;i<=aa->nr; i++)
6277  {
6278  memset(&tmp_in,0,sizeof(tmp_in));
6279  tmp_in.Copy(&(aa->m[i]));
6280  if (proc==NULL)
6281  bo=iiExprArith1(&tmp_out,&tmp_in,op);
6282  else
6283  bo=jjPROC(&tmp_out,proc,&tmp_in);
6284  tmp_in.CleanUp();
6285  if (bo)
6286  {
6287  res->CleanUp(currRing);
6288  Werror("apply fails at index %d",i+1);
6289  return TRUE;
6290  }
6291  if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6292  else
6293  {
6294  curr->next=(leftv)omAllocBin(sleftv_bin);
6295  curr=curr->next;
6296  memcpy(curr,&tmp_out,sizeof(tmp_out));
6297  }
6298  }
6299  return FALSE;
6300 }
6301 BOOLEAN iiApply(leftv res, leftv a, int op, leftv proc)
6302 {
6303  memset(res,0,sizeof(sleftv));
6304  res->rtyp=a->Typ();
6305  switch (res->rtyp /*a->Typ()*/)
6306  {
6307  case INTVEC_CMD:
6308  case INTMAT_CMD:
6309  return iiApplyINTVEC(res,a,op,proc);
6310  case BIGINTMAT_CMD:
6311  return iiApplyBIGINTMAT(res,a,op,proc);
6312  case IDEAL_CMD:
6313  case MODUL_CMD:
6314  case MATRIX_CMD:
6315  return iiApplyIDEAL(res,a,op,proc);
6316  case LIST_CMD:
6317  return iiApplyLIST(res,a,op,proc);
6318  }
6319  WerrorS("first argument to `apply` must allow an index");
6320  return TRUE;
6321 }
6322 
6324 {
6325  // assume a: level
6326  if ((a->Typ()==INT_CMD)&&((long)a->Data()>=0))
6327  {
6328  if ((TEST_V_ALLWARN) && (myynest==0)) WarnS("ASSUME at top level is of no use: see documentation");
6329  char assume_yylinebuf[80];
6330  strncpy(assume_yylinebuf,my_yylinebuf,79);
6331  int lev=(long)a->Data();
6332  int startlev=0;
6333  idhdl h=ggetid("assumeLevel");
6334  if ((h!=NULL)&&(IDTYP(h)==INT_CMD)) startlev=(long)IDINT(h);
6335  if(lev <=startlev)
6336  {
6337  BOOLEAN bo=b->Eval();
6338  if (bo) { WerrorS("syntax error in ASSUME");return TRUE;}
6339  if (b->Typ()!=INT_CMD) { WerrorS("ASUMME(<level>,<int expr>)");return TRUE; }
6340  if (b->Data()==NULL) { Werror("ASSUME failed:%s",assume_yylinebuf);return TRUE;}
6341  }
6342  }
6343  b->CleanUp();
6344  a->CleanUp();
6345  return FALSE;
6346 }
6347 
6348 #include "libparse.h"
6349 
6350 BOOLEAN iiARROW(leftv r, char* a, char *s)
6351 {
6352  char *ss=(char*)omAlloc(strlen(a)+strlen(s)+30); /* max. 27 currently */
6353  // find end of s:
6354  int end_s=strlen(s);
6355  while ((end_s>0) && ((s[end_s]<=' ')||(s[end_s]==';'))) end_s--;
6356  s[end_s+1]='\0';
6357  char *name=(char *)omAlloc(strlen(a)+strlen(s)+30);
6358  sprintf(name,"%s->%s",a,s);
6359  // find start of last expression
6360  int start_s=end_s-1;
6361  while ((start_s>=0) && (s[start_s]!=';')) start_s--;
6362  if (start_s<0) // ';' not found
6363  {
6364  sprintf(ss,"parameter def %s;return(%s);\n",a,s);
6365  }
6366  else // s[start_s] is ';'
6367  {
6368  s[start_s]='\0';
6369  sprintf(ss,"parameter def %s;%s;return(%s);\n",a,s,s+start_s+1);
6370  }
6371  memset(r,0,sizeof(*r));
6372  // now produce procinfo for PROC_CMD:
6373  r->data = (void *)omAlloc0Bin(procinfo_bin);
6374  ((procinfo *)(r->data))->language=LANG_NONE;
6375  iiInitSingularProcinfo((procinfo *)r->data,"",name,0,0);
6376  ((procinfo *)r->data)->data.s.body=ss;
6377  omFree(name);
6378  r->rtyp=PROC_CMD;
6379  //r->rtyp=STRING_CMD;
6380  //r->data=ss;
6381  return FALSE;
6382 }
6383 
6385 {
6386  char* ring_name=omStrDup((char*)r->Name());
6387  int t=arg->Typ();
6388  if (t==RING_CMD)
6389  {
6390  sleftv tmp;
6391  memset(&tmp,0,sizeof(tmp));
6392  tmp.rtyp=IDHDL;
6393  tmp.data=(char*)rDefault(ring_name);
6394  if (tmp.data!=NULL)
6395  {
6396  BOOLEAN b=iiAssign(&tmp,arg);
6397  if (b) return TRUE;
6398  rSetHdl(ggetid(ring_name));
6399  omFree(ring_name);
6400  return FALSE;
6401  }
6402  else
6403  return TRUE;
6404  }
6405  else if (t==CRING_CMD)
6406  {
6407  sleftv tmp;
6408  sleftv n;
6409  memset(&n,0,sizeof(n));
6410  n.name=ring_name;
6411  if (iiDeclCommand(&tmp,&n,myynest,CRING_CMD,&IDROOT)) return TRUE;
6412  if (iiAssign(&tmp,arg)) return TRUE;
6413  //Print("create %s\n",r->Name());
6414  //Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6415  return FALSE;
6416  }
6417  //Print("create %s\n",r->Name());
6418  //Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6419  return TRUE;// not handled -> error for now
6420 }
6421 
6422 static void iiReportTypes(int nr,int t,const short *T)
6423 {
6424  char *buf=(char*)omAlloc(250);
6425  buf[0]='\0';
6426  if (nr==0)
6427  sprintf(buf,"wrong length of parameters(%d), expected ",t);
6428  else
6429  sprintf(buf,"par. %d is of type `%s`, expected ",nr,Tok2Cmdname(t));
6430  for(int i=1;i<=T[0];i++)
6431  {
6432  strcat(buf,"`");
6433  strcat(buf,Tok2Cmdname(T[i]));
6434  strcat(buf,"`");
6435  if (i<T[0]) strcat(buf,",");
6436  }
6437  WerrorS(buf);
6438 }
6439 
6440 BOOLEAN iiCheckTypes(leftv args, const short *type_list, int report)
6441 {
6442  if (args==NULL)
6443  {
6444  if (type_list[0]==0) return TRUE;
6445  else
6446  {
6447  if (report) WerrorS("no arguments expected");
6448  return FALSE;
6449  }
6450  }
6451  int l=args->listLength();
6452  if (l!=(int)type_list[0])
6453  {
6454  if (report) iiReportTypes(0,l,type_list);
6455  return FALSE;
6456  }
6457  for(int i=1;i<=l;i++,args=args->next)
6458  {
6459  short t=type_list[i];
6460  if (t!=ANY_TYPE)
6461  {
6462  if (((t==IDHDL)&&(args->rtyp!=IDHDL))
6463  || (t!=args->Typ()))
6464  {
6465  if (report) iiReportTypes(i,args->Typ(),type_list);
6466  return FALSE;
6467  }
6468  }
6469  }
6470  return TRUE;
6471 }
mpz_ptr base
Definition: rmodulon.h:19
int status int void size_t count
Definition: si_signals.h:59
int & rows()
Definition: matpol.h:24
int length
Definition: syz.h:60
BOOLEAN jjCHARSERIES(leftv res, leftv u)
Definition: ipshell.cc:3237
intvec ** weights
Definition: syz.h:45
#define omAllocBin(bin)
Definition: omAllocDecl.h:205
for idElimination, like a, except pFDeg, pWeigths ignore it
Definition: ring.h:99
CanonicalForm map(const CanonicalForm &primElem, const Variable &alpha, const CanonicalForm &F, const Variable &beta)
map from to such that is mapped onto
Definition: cf_map_ext.cc:400
int iiRETURNEXPR_len
Definition: iplib.cc:472
int hMu2
Definition: hdegree.cc:22
complex root finder for univariate polynomials based on laguers algorithm
Definition: mpr_numeric.h:65
#define IDLIST(a)
Definition: ipid.h:134
void VoiceBackTrack()
Definition: fevoices.cc:77
ip_package * package
Definition: structs.h:46
#define omRealloc0Size(addr, o_size, size)
Definition: omAllocDecl.h:221
#define pIsPurePower(p)
Definition: polys.h:231
static FORCE_INLINE char const ** n_ParameterNames(const coeffs r)
Returns a (const!) pointer to (const char*) names of parameters.
Definition: coeffs.h:812
#define idMaxIdeal(D)
initialise the maximal ideal (at 0)
Definition: ideals.h:33
const CanonicalForm int s
Definition: facAbsFact.cc:55
unsigned si_opt_1
Definition: options.c:5
int iiTestConvert(int inputType, int outputType)
Definition: gentable.cc:293
sleftv * m
Definition: lists.h:45
char *(* fe_fgets_stdin)(const char *pr, char *s, int size)
Definition: feread.cc:33
#define omCheckAddrSize(addr, size)
Definition: omAllocDecl.h:327
for int64 weights
Definition: ring.h:79
void atSet(idhdl root, const char *name, void *data, int typ)
Definition: attrib.cc:156
Class used for (list of) interpreter objects.
Definition: subexpr.h:83
#define TRACE_SHOW_RINGS
Definition: reporter.h:35
void hDimSolve(scmon pure, int Npure, scfmon rad, int Nrad, varset var, int Nvar)
Definition: hdegree.cc:29
int Eval()
Definition: subexpr.cc:1761
spectrumPolyNode * next
Definition: splist.h:39
#define pSetm(p)
Definition: polys.h:253
static FORCE_INLINE BOOLEAN nCoeff_is_numeric(const coeffs r)
Definition: coeffs.h:849
resolvente syReorder(resolvente res, int length, syStrategy syzstr, BOOLEAN toCopy=TRUE, resolvente totake=NULL)
Definition: syz1.cc:1649
number * interpolateDense(const number *q)
Solves the Vandermode linear system {i=1}^{n} x_i^k-1 w_i = q_k, k=1,..,n.
Definition: mpr_numeric.cc:159
matrix mapToMatrix(matrix m)
ring rSubring(ring org_ring, sleftv *rv)
Definition: ipshell.cc:5864
spectrumState
Definition: ipshell.cc:3440
int yylineno
Definition: febase.cc:45
const poly a
Definition: syzextra.cc:212
int sdb_flags
Definition: sdb.cc:32
void PrintLn()
Definition: reporter.cc:310
void compute()
#define ANY_TYPE
Definition: tok.h:30
#define Print
Definition: emacs.cc:83
Base class for solving 0-dim poly systems using u-resultant.
Definition: mpr_base.h:62
only used if HAVE_RINGS is defined
Definition: coeffs.h:44
scfmon hwork
Definition: hutil.cc:19
void mu(int **points, int sizePoints)
Definition: tok.h:95
ring r
Definition: algext.h:40
void hIndAllMult(scmon pure, int Npure, scfmon rad, int Nrad, varset var, int Nvar)
Definition: hdegree.cc:496
#define SHORT_REAL_LENGTH
Definition: numbers.h:54
int hNexist
Definition: hutil.cc:22
int * varset
Definition: hutil.h:19
idhdl currPackHdl
Definition: ipid.cc:61
vandermonde system solver for interpolating polynomials from their values
Definition: mpr_numeric.h:28
const short MAX_SHORT
Definition: ipshell.cc:5476
int hCo
Definition: hdegree.cc:22
Definition: attrib.h:15
resolvente liFindRes(lists L, int *len, int *typ0, intvec ***weights)
Definition: lists.cc:312
Subexpr e
Definition: subexpr.h:106
#define idDelete(H)
delete an ideal
Definition: ideals.h:29
Rational weight
Definition: splist.h:41
static BOOLEAN rField_is_Zp_a(const ring r)
Definition: ring.h:521
static BOOLEAN rSleftvList2StringArray(leftv sl, char **p)
Definition: ipshell.cc:5440
static BOOLEAN rComposeVar(const lists L, ring R)
Definition: ipshell.cc:2400
Definition: lists.h:22
CanonicalForm num(const CanonicalForm &f)
#define IDINTVEC(a)
Definition: ipid.h:125
ring rCompose(const lists L, const BOOLEAN check_comp)
Definition: ipshell.cc:2695
only used if HAVE_RINGS is defined
Definition: coeffs.h:46
BOOLEAN mpKoszul(leftv res, leftv c, leftv b, leftv id)
Definition: ipshell.cc:2983
used for all transcendental extensions, i.e., the top-most extension in an extension tower is transce...
Definition: coeffs.h:39
loop
Definition: myNF.cc:98
if(0 > strat->sl)
Definition: myNF.cc:73
BOOLEAN iiExprArith1(leftv res, leftv a, int op)
Definition: iparith.cc:8333
#define IDID(a)
Definition: ipid.h:119
#define pSetExp(p, i, v)
Definition: polys.h:42
static int si_min(const int a, const int b)
Definition: auxiliary.h:121
BOOLEAN jjVARIABLES_P(leftv res, leftv u)
Definition: ipshell.cc:6188
idhdl rSimpleFindHdl(ring r, idhdl root, idhdl n)
Definition: ipshell.cc:6103
#define FALSE
Definition: auxiliary.h:94
Linear Programming / Linear Optimization using Simplex - Algorithm.
Definition: mpr_numeric.h:194
Compatiblity layer for legacy polynomial operations (over currRing)
BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
Definition: ipshell.cc:5168
BOOLEAN iiConvert(int inputType, int outputType, int index, leftv input, leftv output, const struct sConvertTypes *dConvertTypes)
Definition: ipconv.cc:401
attr * Attribute()
Definition: subexpr.cc:1393
Definition: tok.h:38
return P p
Definition: myNF.cc:203
opposite of ls
Definition: ring.h:100
int exprlist_length(leftv v)
Definition: ipshell.cc:544
BOOLEAN semicProc3(leftv res, leftv u, leftv v, leftv w)
Definition: ipshell.cc:4401
void syMinimizeResolvente(resolvente res, int length, int first)
Definition: syz.cc:360
Matrices of numbers.
Definition: bigintmat.h:51
f
Definition: cfModGcd.cc:4022
static int rPar(const ring r)
(r->cf->P)
Definition: ring.h:590
Rational * s
Definition: semic.h:70
spectrum spectrumFromList(lists l)
Definition: ipshell.cc:3274
BOOLEAN jjPROC(leftv res, leftv u, leftv v)
Definition: iparith.cc:1600
lists syConvRes(syStrategy syzstr, BOOLEAN toDel, int add_row_shift)
Definition: ipshell.cc:3073
BOOLEAN jjRESULTANT(leftv res, leftv u, leftv v, leftv w)
Definition: ipshell.cc:3230
static BOOLEAN rField_is_R(const ring r)
Definition: ring.h:510
scmon * scfmon
Definition: hutil.h:18
int rows() const
Definition: bigintmat.h:146
#define pTest(p)
Definition: polys.h:398
char * filename
Definition: fevoices.h:62
void list_error(semicState state)
Definition: ipshell.cc:3358
static FORCE_INLINE void nSetChar(const coeffs r)
initialisations after each ring change
Definition: coeffs.h:440
static poly last
Definition: hdegree.cc:1077
#define pDecrExp(p, i)
Definition: polys.h:44
sleftv iiRETURNEXPR
Definition: iplib.cc:471
rational (GMP) numbers
Definition: coeffs.h:31
#define V_DEF_RES
Definition: options.h:48
resMatrixBase * accessResMat()
Definition: mpr_base.h:78
const char * GFPar_name
Definition: coeffs.h:96
static FORCE_INLINE BOOLEAN nCoeff_is_Ring_Z(const coeffs r)
Definition: coeffs.h:759
int rows() const
Definition: intvec.h:88
#define omFreeSize(addr, size)
Definition: omAllocDecl.h:260
#define IDNEXT(a)
Definition: ipid.h:115
int pg
Definition: semic.h:68
scfmon hexist
Definition: hutil.cc:19
Definition: grammar.cc:270
{p < 2^31}
Definition: coeffs.h:30
proclevel * procstack
Definition: ipid.cc:58
procinfo * iiInitSingularProcinfo(procinfov pi, const char *libname, const char *procname, int, long pos, BOOLEAN pstatic)
Definition: iplib.cc:883
BOOLEAN jjBETTI2(leftv res, leftv u, leftv v)
Definition: ipshell.cc:920
#define IDROOT
Definition: ipid.h:20
static short rVar(const ring r)
#define rVar(r) (r->N)
Definition: ring.h:583
void id_Delete(ideal *h, ring r)
deletes an ideal/module/matrix
#define pNeg(p)
Definition: polys.h:181
intvec * ivCopy(const intvec *o)
Definition: intvec.h:126
BOOLEAN siq
Definition: subexpr.cc:58
static int * multiplicity
poly singclap_resultant(poly f, poly g, poly x, const ring r)
Definition: clapsing.cc:317
const char sNoName[]
Definition: subexpr.cc:56
int listLength()
Definition: subexpr.cc:61
monf hCreate(int Nvar)
Definition: hutil.cc:1002
long int64
Definition: auxiliary.h:66
void scComputeHC(ideal S, ideal Q, int ak, poly &hEdge, ring tailRing)
Definition: hdegree.cc:1005
int hNvar
Definition: hutil.cc:22
intvec * id_QHomWeight(ideal id, const ring r)
int get_den_si()
Definition: GMPrat.cc:159
BOOLEAN nuVanderSys(leftv res, leftv arg1, leftv arg2, leftv arg3)
COMPUTE: polynomial p with values given by v at points p1,..,pN derived from p; more precisely: consi...
Definition: ipshell.cc:4697
resolvente res
Definition: syz.h:47
#define pCmp(p1, p2)
pCmp: args may be NULL returns: (p2==NULL ? 1 : (p1 == NULL ? -1 : p_LmCmp(p1, p2))) ...
Definition: polys.h:115
BOOLEAN spectrumProc(leftv result, leftv first)
Definition: ipshell.cc:4023
static BOOLEAN rField_is_Q_a(const ring r)
Definition: ring.h:531
BOOLEAN jjVARIABLES_ID(leftv res, leftv u)
Definition: ipshell.cc:6196
#define TRUE
Definition: auxiliary.h:98
#define nIsOne(n)
Definition: numbers.h:25
denominator_list DENOMINATOR_LIST
Definition: kutil.cc:89
uResultant::resMatType determineMType(int imtype)
ideal kStd(ideal F, ideal Q, tHomog h, intvec **w, intvec *hilb, int syzComp, int newIdeal, intvec *vw, s_poly_proc_t sp)
Definition: kstd1.cc:2231
BOOLEAN maApplyFetch(int what, map theMap, leftv res, leftv w, ring preimage_r, int *perm, int *par_perm, int P, nMapFunc nMap)
Definition: maps_ip.cc:49
void type_cmd(leftv v)
Definition: ipshell.cc:246
BOOLEAN iiAssignCR(leftv r, leftv arg)
Definition: ipshell.cc:6384
#define IDIDEAL(a)
Definition: ipid.h:130
static long p_Totaldegree(poly p, const ring r)
Definition: p_polys.h:1430
poly iiHighCorner(ideal I, int ak)
Definition: ipshell.cc:1481
void * ADDRESS
Definition: auxiliary.h:115
int hNrad
Definition: hutil.cc:22
intvec * zrovToIV()
int hNpure
Definition: hutil.cc:22
sleftv * leftv
Definition: structs.h:60
bool solver(const int polishmode=PM_NONE)
Definition: mpr_numeric.cc:449
void pWrite(poly p)
Definition: polys.h:290
BOOLEAN spmulProc(leftv result, leftv first, leftv second)
Definition: ipshell.cc:4360
BOOLEAN hasConstTerm(poly h, const ring r)
Definition: spectrum.h:28
scmon hpure
Definition: hutil.cc:20
void WerrorS(const char *s)
Definition: feFopen.cc:24
int k
Definition: cfEzgcd.cc:93
#define nIsMOne(n)
Definition: numbers.h:26
int min_in()
Definition: intvec.h:113
static BOOLEAN rField_is_GF(const ring r)
Definition: ring.h:513
static char const ** rParameter(const ring r)
(r->cf->parameter)
Definition: ring.h:616
void nlGMP(number &i, number n, const coeffs r)
Definition: longrat.cc:1467
#define Q
Definition: sirandom.c:25
char * lString(lists l, BOOLEAN typed, int dim)
Definition: lists.cc:377
int getAnzElems()
Definition: mpr_numeric.h:95
ring rAssure_HasComp(const ring r)
Definition: ring.cc:4522
ideal loNewtonPolytope(const ideal id)
Definition: mpr_base.cc:3190
void killlocals_rec(idhdl *root, int v, ring r)
Definition: ipshell.cc:322
syStrategy syConvList(lists li)
Definition: ipshell.cc:3146
int get_num_si()
Definition: GMPrat.cc:145
static number & pGetCoeff(poly p)
return an alias to the leading coefficient of p assumes that p != NULL NOTE: not copy ...
Definition: monomials.h:51
void hRadical(scfmon rad, int *Nrad, int Nvar)
Definition: hutil.cc:417
int traceit
Definition: febase.cc:47
static FORCE_INLINE BOOLEAN nCoeff_is_long_C(const coeffs r)
Definition: coeffs.h:911
#define WarnS
Definition: emacs.cc:81
rootContainer ** specializeInU(BOOLEAN matchUp=false, const number subDetVal=NULL)
Definition: mpr_base.cc:3059
CanonicalForm Lc(const CanonicalForm &f)
coeffs coeffs_BIGINT
Definition: ipid.cc:54
int hasOne(ideal J, const ring r)
Definition: spectrum.cc:96
int Typ()
Definition: subexpr.cc:996
#define omAlloc(size)
Definition: omAllocDecl.h:210
BOOLEAN exitBuffer(feBufferTypes typ)
Definition: fevoices.cc:241
static void list1(const char *s, idhdl h, BOOLEAN c, BOOLEAN fullname)
Definition: ipshell.cc:147
poly numvec2poly(const number *q)
Definition: mpr_numeric.cc:106
void rComposeC(lists L, ring R)
Definition: ipshell.cc:2195
#define Sy_bit(x)
Definition: options.h:30
static void jjINT_S_TO_ID(int n, int *e, leftv res)
Definition: ipshell.cc:6166
const char * Name()
Definition: subexpr.h:121
scfmon hrad
Definition: hutil.cc:19
void Print(leftv store=NULL, int spaces=0)
Called by type_cmd (e.g. "r;") or as default in jPRINT.
Definition: subexpr.cc:73
static FORCE_INLINE BOOLEAN nCoeff_is_Ring(const coeffs r)
Definition: coeffs.h:762
Creation data needed for finite fields.
Definition: coeffs.h:92
BOOLEAN iiExport(leftv v, int toLev)
Definition: ipshell.cc:1383
Definition: idrec.h:34
Definition: semic.h:63
#define IDHDL
Definition: tok.h:31
Definition: mpr_base.h:98
idhdl iiCurrProc
Definition: ipshell.cc:79
idhdl rDefault(const char *s)
Definition: ipshell.cc:1519
static BOOLEAN idIsZeroDim(ideal i)
Definition: ideals.h:161
idhdl get(const char *s, int lev)
Definition: ipid.cc:91
real floating point (GMP) numbers
Definition: coeffs.h:34
BOOLEAN iiApplyBIGINTMAT(leftv, leftv, int, leftv)
Definition: ipshell.cc:6259
BITSET validOpts
Definition: kstd1.cc:63
BOOLEAN iiParameter(leftv p)
Definition: ipshell.cc:1249
short float_len2
additional char-flags, rInit
Definition: coeffs.h:102
#define pGetVariables(p, e)
Definition: polys.h:234
bool found
Definition: facFactorize.cc:56
const char * currid
Definition: grammar.cc:171
void rDecomposeRing_41(leftv h, const coeffs C)
Definition: ipshell.cc:1748
intvec ** hilb_coeffs
Definition: syz.h:46
omBin procinfo_bin
Definition: subexpr.cc:51
#define nPrint(a)
only for debug, over any initalized currRing
Definition: numbers.h:46
lists getList(spectrum &spec)
Definition: ipshell.cc:3286
void ipListFlag(idhdl h)
Definition: ipid.cc:525
int iiRegularity(lists L)
Definition: ipshell.cc:956
void * data
Definition: subexpr.h:89
void rDecomposeCF(leftv h, const ring r, const ring R)
Definition: ipshell.cc:1590
void hDelete(scfmon ev, int ev_length)
Definition: hutil.cc:146
#define pIter(p)
Definition: monomials.h:44
poly res
Definition: myNF.cc:322
BOOLEAN iiTestAssume(leftv a, leftv b)
Definition: ipshell.cc:6323
semicState list_is_spectrum(lists l)
Definition: ipshell.cc:4143
Definition: subexpr.h:21
BOOLEAN kWeight(leftv res, leftv id)
Definition: ipshell.cc:3191
#define IDPACKAGE(a)
Definition: ipid.h:136
int myynest
Definition: febase.cc:46
#define omReallocSize(addr, o_size, size)
Definition: omAllocDecl.h:220
ring currRing
Widely used global variable which specifies the current polynomial ring for Singular interpreter and ...
Definition: polys.cc:10
char * char_ptr
Definition: structs.h:56
#define pGetExp(p, i)
Exponent.
Definition: polys.h:41
#define IDTYP(a)
Definition: ipid.h:116
indset ISet
Definition: hdegree.cc:279
single prescision (6,6) real numbers
Definition: coeffs.h:32
void * CopyA()
Definition: subexpr.cc:1958
void killhdl2(idhdl h, idhdl *ih, ring r)
Definition: ipid.cc:409
idhdl enterid(const char *s, int lev, int t, idhdl *root, BOOLEAN init, BOOLEAN search)
Definition: ipid.cc:259
spectrumPolyNode * root
Definition: splist.h:60
BOOLEAN hasLinearTerm(poly h, const ring r)
Definition: spectrum.h:30
static int rBlocks(ring r)
Definition: ring.h:559
BOOLEAN syBetti1(leftv res, leftv u)
Definition: ipshell.cc:3061
Definition: tok.h:56
int RingDependend(int t)
Definition: gentable.cc:23
spectrumState spectrumStateFromList(spectrumPolyList &speclist, lists *L, int fast)
Definition: ipshell.cc:3459
char my_yylinebuf[80]
Definition: febase.cc:48
BOOLEAN nuLagSolve(leftv res, leftv arg1, leftv arg2, leftv arg3)
find the (complex) roots an univariate polynomial Determines the roots of an univariate polynomial us...
Definition: ipshell.cc:4568
short float_len
additional char-flags, rInit
Definition: coeffs.h:101
const ring r
Definition: syzextra.cc:208
poly p_PermPoly(poly p, const int *perm, const ring oldRing, const ring dst, nMapFunc nMap, const int *par_perm, int OldPar, BOOLEAN use_mult)
Definition: p_polys.cc:3938
Coefficient rings, fields and other domains suitable for Singular polynomials.
resolvente orderedRes
Definition: syz.h:48
BOOLEAN killlocals_list(int v, lists L)
Definition: ipshell.cc:358
BOOLEAN RingDependend()
Definition: subexpr.cc:403
static BOOLEAN rComposeOrder(const lists L, const BOOLEAN check_comp, ring R)
Definition: ipshell.cc:2445
static FORCE_INLINE BOOLEAN nCoeff_is_algExt(const coeffs r)
TRUE iff r represents an algebraic extension field.
Definition: coeffs.h:927
intvec * posvToIV()
Definition: intvec.h:14
#define pSub(a, b)
Definition: polys.h:269
long id_RankFreeModule(ideal s, ring lmRing, ring tailRing)
return the maximal component number found in any polynomial in s
static FORCE_INLINE long n_Int(number &n, const coeffs r)
conversion of n to an int; 0 if not possible in Z/pZ: the representing int lying in (-p/2 ...
Definition: coeffs.h:551
void hKill(monf xmem, int Nvar)
Definition: hutil.cc:1016
void rKill(ring r)
Definition: ipshell.cc:6026
BOOLEAN rComplete(ring r, int force)
this needs to be called whenever a new ring is created: new fields in ring are created (like VarOffse...
Definition: ring.cc:3351
for(int i=0;i< R->ExpL_Size;i++) Print("%09lx "
Definition: cfEzgcd.cc:66
varset hvar
Definition: hutil.cc:21
ideal maMapIdeal(const ideal map_id, const ring preimage_r, const ideal image_id, const ring image_r, const nMapFunc nMap)
polynomial map for ideals/module/matrix map_id: the ideal to map map_r: the base ring for map_id imag...
Definition: gen_maps.cc:88
BOOLEAN mapFromMatrix(matrix m)
void list_cmd(int typ, const char *what, const char *prefix, BOOLEAN iterate, BOOLEAN fullname)
Definition: ipshell.cc:417
void computeNF(ideal stdJ, poly hc, poly wc, spectrumPolyList *NF, const ring r)
Definition: spectrum.cc:309
int j
Definition: myNF.cc:70
only used if HAVE_RINGS is defined
Definition: coeffs.h:45
Definition: tok.h:58
Definition: ipid.h:56
const char * name
Definition: subexpr.h:88
#define omFree(addr)
Definition: omAllocDecl.h:261
static long pTotaldegree(poly p)
Definition: polys.h:264
static leftv rOptimizeOrdAsSleftv(leftv ord)
Definition: ipshell.cc:5056
#define assume(x)
Definition: mod2.h:394
static BOOLEAN rIsPluralRing(const ring r)
we must always have this test!
Definition: ring.h:404
int search(const CFArray &A, const CanonicalForm &F, int i, int j)
search for F in A between index i and j
The main handler for Singular numbers which are suitable for Singular polynomials.
BOOLEAN iiBranchTo(leftv, leftv args)
Definition: ipshell.cc:1179
static BOOLEAN iiNoKeepRing
Definition: ipshell.cc:82
void hIndMult(scmon pure, int Npure, scfmon rad, int Nrad, varset var, int Nvar)
Definition: hdegree.cc:313
double(* wFunctional)(int *degw, int *lpol, int npol, double *rel, double wx, double wNsqr)
Definition: weight.cc:28
int status int void * buf
Definition: si_signals.h:59
ring rCopy0(const ring r, BOOLEAN copy_qideal, BOOLEAN copy_ordering)
Definition: ring.cc:1321
indlist * indset
Definition: hutil.h:31
int GFDegree
Definition: coeffs.h:95
void hPure(scfmon stc, int a, int *Nstc, varset var, int Nvar, scmon pure, int *Npure)
Definition: hutil.cc:627
const ExtensionInfo & info
< [in] sqrfree poly
number(* nMapFunc)(number a, const coeffs src, const coeffs dst)
maps "a", which lives in src, into dst
Definition: coeffs.h:73
static void rDecomposeC(leftv h, const ring R)
Definition: ipshell.cc:1712
BOOLEAN hasAxis(ideal J, int k, const ring r)
Definition: spectrum.cc:81
const ring R
Definition: DebugPrint.cc:36
void killlocals(int v)
Definition: ipshell.cc:378
complex floating point (GMP) numbers
Definition: coeffs.h:42
static FORCE_INLINE char * nCoeffName(const coeffs cf)
Definition: coeffs.h:980
Definition: grammar.cc:269
const char * rSimpleOrdStr(int ord)
Definition: ring.cc:88
ip_smatrix * matrix
int mult_spectrumh(spectrum &)
Definition: semic.cc:425
gmp_float sqrt(const gmp_float &a)
Definition: mpr_complex.cc:329
bool success()
Definition: mpr_numeric.h:162
#define IDSTRING(a)
Definition: ipid.h:133
#define rTest(r)
Definition: ring.h:778
idhdl currRingHdl
Definition: ipid.cc:65
static resolvente iiCopyRes(resolvente r, int l)
Definition: ipshell.cc:855
BOOLEAN nuUResSolve(leftv res, leftv args)
solve a multipolynomial system using the u-resultant Input ideal must be 0-dimensional and (currRing-...
Definition: ipshell.cc:4798
omBin indlist_bin
Definition: hdegree.cc:23
void Copy(leftv e)
Definition: subexpr.cc:689
static void iiReportTypes(int nr, int t, const short *T)
Definition: ipshell.cc:6422
#define setFlag(A, F)
Definition: ipid.h:110
BOOLEAN rCheckIV(const intvec *iv)
Definition: ring.cc:185
indset JSet
Definition: hdegree.cc:279
int cols() const
Definition: bigintmat.h:145
#define pSetComp(p, v)
Definition: polys.h:38
void arrange()
Definition: mpr_numeric.cc:895
int rOrderName(char *ordername)
Definition: ring.cc:508
omBin sip_sring_bin
Definition: ring.cc:54
const unsigned short fftable[]
Definition: ffields.cc:61
int m
Definition: cfEzgcd.cc:119
void idGetNextChoise(int r, int end, BOOLEAN *endch, int *choise)
#define pIsConstant(p)
like above, except that Comp might be != 0
Definition: polys.h:221
proclevel * next
Definition: ipid.h:59
#define pMult_nn(p, n)
Definition: polys.h:183
int * scmon
Definition: hutil.h:17
struct for passing initialization parameters to naInitChar
Definition: transext.h:92
only used if HAVE_RINGS is defined
Definition: coeffs.h:43
BOOLEAN iiApplyLIST(leftv res, leftv a, int op, leftv proc)
Definition: ipshell.cc:6269
void spectrumPrintError(spectrumState state)
Definition: ipshell.cc:3992
void fillContainer(number *_coeffs, number *_ievpoint, const int _var, const int _tdg, const rootType _rt, const int _anz)
Definition: mpr_numeric.cc:312
const char * iiTwoOps(int t)
Definition: ipshell.cc:86
static int si_max(const int a, const int b)
Definition: auxiliary.h:120
unsigned long exp
Definition: rmodulon.h:19
static FORCE_INLINE BOOLEAN nCoeff_is_transExt(const coeffs r)
TRUE iff r represents a transcendental extension field.
Definition: coeffs.h:935
idrec * idhdl
Definition: ring.h:18
virtual ideal getMatrix()
Definition: mpr_base.h:31
omBin sleftv_bin
Definition: subexpr.cc:50
int i
Definition: cfEzgcd.cc:123
ring rInit(leftv pn, leftv rv, leftv ord)
Definition: ipshell.cc:5488
Induced (Schreyer) ordering.
Definition: ring.h:101
void PrintS(const char *s)
Definition: reporter.cc:284
BOOLEAN iiDebugMarker
Definition: ipshell.cc:982
matrix singclap_irrCharSeries(ideal I, const ring r)
Definition: clapsing.cc:1398
static BOOLEAN rField_is_Q(const ring r)
Definition: ring.h:501
lists rDecompose(const ring r)
Definition: ipshell.cc:2010
BOOLEAN iiApplyIDEAL(leftv, leftv, int, leftv)
Definition: ipshell.cc:6264
idhdl next
Definition: idrec.h:38
BOOLEAN spectrumfProc(leftv result, leftv first)
Definition: ipshell.cc:4074
int IsPrime(int p)
Definition: prime.cc:61
S?
Definition: ring.h:83
#define pOne()
Definition: polys.h:297
char name(const Variable &v)
Definition: factory.h:178
gmp_complex * getRoot(const int i)
Definition: mpr_numeric.h:88
idhdl rFindHdl(ring r, idhdl n)
Definition: ipshell.cc:1564
void iiDebug()
Definition: ipshell.cc:984
void solve_all()
Definition: mpr_numeric.cc:870
static unsigned pLength(poly a)
Definition: p_polys.h:189
#define IDELEMS(i)
Definition: simpleideals.h:24
BOOLEAN loSimplex(leftv res, leftv args)
Implementation of the Simplex Algorithm.
Definition: ipshell.cc:4459
static FORCE_INLINE BOOLEAN nCoeff_is_GF(const coeffs r)
Definition: coeffs.h:856
BOOLEAN rEqual(ring r1, ring r2, BOOLEAN qr)
returns TRUE, if r1 equals r2 FALSE, otherwise Equality is determined componentwise, if qr == 1, then qrideal equality is tested, as well
Definition: ring.cc:1627
static FORCE_INLINE nMapFunc n_SetMap(const coeffs src, const coeffs dst)
set the mapping function pointers for translating numbers from src to dst
Definition: coeffs.h:725
lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
Definition: ipshell.cc:1022
spectrumState spectrumCompute(poly h, lists *L, int fast)
Definition: ipshell.cc:3700
CFList tmp2
Definition: facFqBivar.cc:70
mprState mprIdealCheck(const ideal theIdeal, const char *name, uResultant::resMatType mtype, BOOLEAN rmatrix=false)
void idSkipZeroes(ideal ide)
gives an ideal/module the minimal possible size
void iiMakeResolv(resolvente r, int length, int rlen, char *name, int typ0, intvec **weights)
Definition: ipshell.cc:766
rootContainer ** interpolateDenseSP(BOOLEAN matchUp=false, const number subDetVal=NULL)
Definition: mpr_base.cc:2921
#define IDLEV(a)
Definition: ipid.h:118
resolvente fullres
Definition: syz.h:57
static void rRenameVars(ring R)
Definition: ipshell.cc:2359
const char * VoiceName()
Definition: fevoices.cc:66
#define nDelete(n)
Definition: numbers.h:16
semicState
Definition: ipshell.cc:3324
#define IDMAP(a)
Definition: ipid.h:132
static void rDecomposeC_41(leftv h, const coeffs C)
Definition: ipshell.cc:1678
#define FLAG_STD
Definition: ipid.h:106
ideal idCopy(ideal A)
Definition: ideals.h:60
short errorreported
Definition: feFopen.cc:23
int n
Definition: semic.h:69
leftv next
Definition: subexpr.h:87
static BOOLEAN rField_is_long_C(const ring r)
Definition: ring.h:537
#define rHasLocalOrMixedOrdering_currRing()
Definition: ring.h:757
void test_cmd(int i)
Definition: ipshell.cc:506
void rChangeCurrRing(ring r)
Definition: polys.cc:12
resolvente minres
Definition: syz.h:58
static BOOLEAN rField_is_Zp(const ring r)
Definition: ring.h:495
void hLexR(scfmon rad, int Nrad, varset var, int Nvar)
Definition: hutil.cc:571
#define BVERBOSE(a)
Definition: options.h:33
INLINE_THIS void Init(int l=0)
matrix mpNew(int r, int c)
create a r x c zero-matrix
Definition: matpol.cc:47
CanonicalForm buf2
Definition: facFqBivar.cc:71
#define nInvers(a)
Definition: numbers.h:33
BOOLEAN syBetti2(leftv res, leftv u, leftv w)
Definition: ipshell.cc:3038
Definition: tok.h:34
int iiDeclCommand(leftv sy, leftv name, int lev, int t, idhdl *root, BOOLEAN isring, BOOLEAN init_b)
Definition: ipshell.cc:1122
#define omAlloc0Bin(bin)
Definition: omAllocDecl.h:206
BOOLEAN iiAllStart(procinfov pi, char *p, feBufferTypes t, int l)
Definition: iplib.cc:311
int GFChar
Definition: coeffs.h:94
#define IDPROC(a)
Definition: ipid.h:137
void paPrint(const char *n, package p)
Definition: ipshell.cc:6211
BOOLEAN iiCheckRing(int i)
Definition: ipshell.cc:1461
#define pi
Definition: libparse.cc:1143
ideal idInit(int idsize, int rank)
initialise an ideal / module
Definition: simpleideals.cc:38
BOOLEAN nc_CallPlural(matrix cc, matrix dd, poly cn, poly dn, ring r, bool bSetupQuotient, bool bCopyInput, bool bBeQuiet, ring curr, bool dummy_ring=false)
returns TRUE if there were errors analyze inputs, check them for consistency detects nc_type...
Definition: old.gring.cc:2746
const Variable & v
< [in] a sqrfree bivariate poly
Definition: facBivar.h:37
BOOLEAN kQHWeight(leftv res, leftv v)
Definition: ipshell.cc:3213
static BOOLEAN iiInternalExport(leftv v, int toLev)
Definition: ipshell.cc:1285
ring * iiLocalRing
Definition: iplib.cc:470
void * atGet(idhdl root, const char *name, int t, void *defaultReturnValue)
Definition: attrib.cc:135
int nr
Definition: lists.h:43
int & cols()
Definition: matpol.h:25
void maFindPerm(char const *const *const preim_names, int preim_n, char const *const *const preim_par, int preim_p, char const *const *const names, int n, char const *const *const par, int nop, int *perm, int *par_perm, n_coeffType ch)
Definition: maps.cc:169
#define ppMult_nn(p, n)
Definition: polys.h:182
void rComposeRing(lists L, ring R)
Definition: ipshell.cc:2266
int mu
Definition: semic.h:67
CanonicalForm cf
Definition: cfModGcd.cc:4024
#define MATCOLS(i)
Definition: matpol.h:28
Definition: tok.h:116
void mult(unsigned long *result, unsigned long *a, unsigned long *b, unsigned long p, int dega, int degb)
Definition: minpoly.cc:649
#define BREAK_LINE_LENGTH
Definition: ipshell.cc:983
#define nIsZero(n)
Definition: numbers.h:19
static BOOLEAN rField_is_Ring(const ring r)
Definition: ring.h:477
void rDecomposeRing(leftv h, const ring R)
Definition: ipshell.cc:1776
#define NULL
Definition: omList.c:10
attr attribute
Definition: idrec.h:41
poly * polyset
Definition: hutil.h:15
slists * lists
Definition: mpr_numeric.h:146
intvec * syBettiOfComputation(syStrategy syzstr, BOOLEAN minim=TRUE, int *row_shift=NULL, intvec *weights=NULL)
Definition: syz1.cc:1763
int getAnzRoots()
Definition: mpr_numeric.h:97
package req_packhdl
Definition: subexpr.h:107
int length() const
Definition: intvec.h:86
BOOLEAN iiDefaultParameter(leftv p)
Definition: ipshell.cc:1166
{p^n < 2^16}
Definition: coeffs.h:33
static FORCE_INLINE number n_Copy(number n, const coeffs r)
return a copy of &#39;n&#39;
Definition: coeffs.h:455
CanonicalForm den(const CanonicalForm &f)
struct for passing initialization parameters to naInitChar
Definition: algext.h:40
void wCall(poly *s, int sl, int *x, double wNsqr, const ring R)
Definition: weight.cc:116
BOOLEAN semicProc(leftv res, leftv u, leftv v)
Definition: ipshell.cc:4441
void rDelete(ring r)
unconditionally deletes fields in r
Definition: ring.cc:448
BOOLEAN nuMPResMat(leftv res, leftv arg1, leftv arg2)
returns module representing the multipolynomial resultant matrix Arguments 2: ideal i...
Definition: ipshell.cc:4545
#define IDINT(a)
Definition: ipid.h:122
const char * Tok2Cmdname(int tok)
Definition: gentable.cc:132
#define IDPOLY(a)
Definition: ipid.h:127
used for all algebraic extensions, i.e., the top-most extension in an extension tower is algebraic ...
Definition: coeffs.h:36
Voice * currentVoice
Definition: fevoices.cc:57
BOOLEAN iiWRITE(leftv, leftv v)
Definition: ipshell.cc:580
BOOLEAN iiCheckTypes(leftv args, const short *type_list, int report)
check a list of arguemys against a given field of types return TRUE if the types match return FALSE (...
Definition: ipshell.cc:6440
BOOLEAN jjBETTI(leftv res, leftv u)
Definition: ipshell.cc:886
package basePack
Definition: ipid.cc:64
coeffs basecoeffs() const
Definition: bigintmat.h:147
void copy_new(int)
Definition: semic.cc:54
static BOOLEAN rField_is_Ring_Z(const ring r)
Definition: ring.h:474
void pNorm(poly p, const ring R=currRing)
Definition: polys.h:345
static BOOLEAN rField_is_long_R(const ring r)
Definition: ring.h:534
lists liMakeResolv(resolvente r, int length, int reallen, int typ0, intvec **weights, int add_row_shift)
Definition: lists.cc:215
denominator_list next
Definition: kutil.h:67
void idInitChoise(int r, int beg, int end, BOOLEAN *endch, int *choise)
monf radmem
Definition: hutil.cc:24
#define IDRING(a)
Definition: ipid.h:124
int rTypeOfMatrixOrder(const intvec *order)
Definition: ring.cc:195
const CanonicalForm & w
Definition: facAbsFact.cc:55
strat ak
Definition: myNF.cc:321
#define pDelete(p_ptr)
Definition: polys.h:169
package currPack
Definition: ipid.cc:63
int iiOpsTwoChar(const char *s)
Definition: ipshell.cc:119
leftv iiCurrArgs
Definition: ipshell.cc:78
Variable x
Definition: cfModGcd.cc:4023
int rtyp
Definition: subexpr.h:92
BOOLEAN jjMINRES(leftv res, leftv v)
Definition: ipshell.cc:865
#define nCopy(n)
Definition: numbers.h:15
sleftv sLastPrinted
Definition: subexpr.cc:55
void CleanUp(ring r=currRing)
Definition: subexpr.cc:333
void Clean(ring r=currRing)
Definition: lists.h:25
#define pNext(p)
Definition: monomials.h:43
void * Data()
Definition: subexpr.cc:1138
int * w
Definition: semic.h:71
#define nSetMap(R)
Definition: numbers.h:43
const char * par_name
parameter name
Definition: coeffs.h:103
ideal idrCopyR(ideal id, ring src_r, ring dest_r)
Definition: prCopy.cc:193
lists rDecompose_list_cf(const ring r)
Definition: ipshell.cc:1879
int typ
Definition: idrec.h:43
short list_length
Definition: syz.h:62
#define pSetCoeff0(p, n)
Definition: monomials.h:67
static int rInternalChar(const ring r)
Definition: ring.h:680
Definition: tok.h:117
matrix mp_Copy(matrix a, const ring r)
copies matrix a (from ring r to r)
Definition: matpol.cc:74
ideal * resolvente
Definition: ideals.h:18
void newBuffer(char *s, feBufferTypes t, procinfo *pi, int lineno)
Definition: fevoices.cc:171
BOOLEAN iiApplyINTVEC(leftv res, leftv a, int op, leftv proc)
Definition: ipshell.cc:6227
number nlMapGMP(number from, const coeffs src, const coeffs dst)
Definition: longrat.cc:206
attr attribute
Definition: subexpr.h:90
omBin slists_bin
Definition: lists.cc:23
BOOLEAN iiARROW(leftv r, char *a, char *s)
Definition: ipshell.cc:6350
BOOLEAN ringIsLocal(const ring r)
Definition: spectrum.cc:461
BOOLEAN spaddProc(leftv result, leftv first, leftv second)
Definition: ipshell.cc:4318
int idGetNumberOfChoise(int t, int d, int begin, int end, int *choise)
attr get(const char *s)
Definition: attrib.cc:96
char * complexToStr(gmp_complex &c, const unsigned int oprec, const coeffs src)
Definition: mpr_complex.cc:706
Definition: tok.h:157
intvec * syBetti(resolvente res, int length, int *regularity, intvec *weights, BOOLEAN tomin, int *row_shift)
Definition: syz.cc:791
int hisModule
Definition: hutil.cc:23
leftv iiMap(map theMap, const char *what)
Definition: ipshell.cc:607
size_t gmp_output_digits
Definition: mpr_complex.cc:44
#define pDiff(a, b)
Definition: polys.h:278
idhdl packFindHdl(package r)
Definition: ipid.cc:739
#define omCheckAddr(addr)
Definition: omAllocDecl.h:328
static FORCE_INLINE void n_Delete(number *p, const coeffs r)
delete &#39;p&#39;
Definition: coeffs.h:459
void iiCheckPack(package &p)
Definition: ipshell.cc:1505
ideal singclap_factorize(poly f, intvec **v, int with_exps, const ring r)
Definition: clapsing.cc:784
#define MATROWS(i)
Definition: matpol.h:27
void wrp(poly p)
Definition: polys.h:292
void setGMPFloatDigits(size_t digits, size_t rest)
Set size of mantissa digits - the number of output digits (basis 10) the size of mantissa consists of...
Definition: mpr_complex.cc:62
int icase
Definition: mpr_numeric.h:201
kBucketDestroy & P
Definition: myNF.cc:191
static jList * T
Definition: janet.cc:37
polyrec * poly
Definition: hilb.h:10
#define IDDATA(a)
Definition: ipid.h:123
virtual IStateType initState() const
Definition: mpr_base.h:41
void rSetHdl(idhdl h)
Definition: ipshell.cc:5002
#define omFreeBin(addr, bin)
Definition: omAllocDecl.h:259
BITSET kOptions
Definition: kstd1.cc:48
BOOLEAN rDecompose_CF(leftv res, const coeffs C)
Definition: ipshell.cc:1808
#define nInit(i)
Definition: numbers.h:24
Rational pow(const Rational &a, int e)
Definition: GMPrat.cc:418
unsigned si_opt_2
Definition: options.c:6
char * iiGetLibProcBuffer(procinfo *pi, int part)
Definition: iplib.cc:210
int * int_ptr
Definition: structs.h:57
static Poly * h
Definition: janet.cc:978
s?
Definition: ring.h:84
int BOOLEAN
Definition: auxiliary.h:85
#define IMATELEM(M, I, J)
Definition: intvec.h:77
static poly p_Init(const ring r, omBin bin)
Definition: p_polys.h:1243
BOOLEAN idIs0(ideal h)
returns true if h is the zero ideal
const poly b
Definition: syzextra.cc:213
BOOLEAN jjBETTI2_ID(leftv res, leftv u, leftv v)
Definition: ipshell.cc:899
void syKillEmptyEntres(resolvente res, int length)
Definition: syz1.cc:2208
BOOLEAN iiApply(leftv res, leftv a, int op, leftv proc)
Definition: ipshell.cc:6301
int mult_spectrum(spectrum &)
Definition: semic.cc:396
package cPack
Definition: ipid.h:61
lists listOfRoots(rootArranger *self, const unsigned int oprec)
Definition: ipshell.cc:4955
static BOOLEAN rField_is_numeric(const ring r)
Definition: ring.h:507
BOOLEAN lRingDependend(lists L)
Definition: lists.cc:199
scfmon hInit(ideal S, ideal Q, int *Nexist, ring tailRing)
Definition: hutil.cc:34
#define V_REDEFINE
Definition: options.h:43
static int sign(int x)
Definition: ring.cc:3328
void copy_deep(spectrum &spec, lists l)
Definition: ipshell.cc:3250
void delete_node(spectrumPolyNode **)
Definition: splist.cc:256
int binom(int n, int r)
void Werror(const char *fmt,...)
Definition: reporter.cc:189
virtual number getSubDet()
Definition: mpr_base.h:37
ideal kGroebner(ideal F, ideal Q)
Definition: ipshell.cc:6121
#define TEST_V_ALLWARN
Definition: options.h:135
void syKillComputation(syStrategy syzstr, ring r=currRing)
Definition: syz1.cc:1503
void * CopyD(int t)
Definition: subexpr.cc:708
const char * lastreserved
Definition: ipshell.cc:80
int hMu
Definition: hdegree.cc:22
idhdl ggetid(const char *n, BOOLEAN, idhdl *packhdl)
Definition: ipid.cc:496
int atyp
Definition: attrib.h:22
static FORCE_INLINE void n_MPZ(mpz_t result, number &n, const coeffs r)
conversion of n to a GMP integer; 0 if not possible
Definition: coeffs.h:555
#define omAlloc0(size)
Definition: omAllocDecl.h:211
static void killlocals0(int v, idhdl *localhdl, const ring r)
Definition: ipshell.cc:287
return result
Definition: facAbsBiFact.cc:76
int l
Definition: cfEzgcd.cc:94
double wFunctionalBuch(int *degw, int *lpol, int npol, double *rel, double wx, double wNsqr)
Definition: weight0.c:78
#define IDMATRIX(a)
Definition: ipid.h:131
BOOLEAN loNewtonP(leftv res, leftv arg1)
compute Newton Polytopes of input polynomials
Definition: ipshell.cc:4453
#define pCopy(p)
return a copy of the poly
Definition: polys.h:168
#define MATELEM(mat, i, j)
Definition: matpol.h:29
poly computeWC(const newtonPolygon &np, Rational max_weight, const ring r)
Definition: spectrum.cc:142
coeffs nInitChar(n_coeffType t, void *parameter)
one-time initialisations for new coeffs in case of an error return NULL
Definition: numbers.cc:334
syStrategy syForceMin(lists li)
Definition: ipshell.cc:3175
ssyStrategy * syStrategy
Definition: syz.h:35
utypes data
Definition: idrec.h:40
int IsCmd(const char *n, int &tok)
Definition: iparith.cc:8746
void hSupp(scfmon stc, int Nstc, varset var, int *Nvar)
Definition: hutil.cc:180
BOOLEAN iiAssign(leftv l, leftv r, BOOLEAN toplevel)
Definition: ipassign.cc:1793
BOOLEAN mpJacobi(leftv res, leftv a)
Definition: ipshell.cc:2961
#define Warn
Definition: emacs.cc:80
#define omStrDup(s)
Definition: omAllocDecl.h:263