source: git/Singular/ipshell.cc @ 0c85f5b

jengelh-datetimespielwiese
Last change on this file since 0c85f5b was 0c85f5b, checked in by Hans Schoenemann <hannes@…>, 10 years ago
fix: float_len2 is the additional, invisible accuracy
  • Property mode set to 100644
File size: 139.0 KB
RevLine 
[0e1846]1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/*
5* ABSTRACT:
6*/
[762407]7#include "config.h"
[77bb59]8#include <kernel/mod2.h>
9#include <misc/auxiliary.h>
[0e1846]10
11
[6cc7f5]12#include <misc/options.h>
[77bb59]13#include <misc/mylimits.h>
14
[6cc7f5]15#ifdef HAVE_FACTORY
16#define SI_DONT_HAVE_GLOBAL_VARS
17#include <factory/factory.h>
18#endif
19
20#include <Singular/maps_ip.h>
[599326]21#include <Singular/tok.h>
[0fb34ba]22#include <misc/options.h>
[599326]23#include <Singular/ipid.h>
[0fb34ba]24#include <misc/intvec.h>
[b1dfaf]25#include <omalloc/omalloc.h>
[599326]26#include <kernel/febase.h>
[737a68]27#include <kernel/polys.h>
[6cc7f5]28#include <coeffs/numbers.h>
[0fb34ba]29#include <polys/prCopy.h>
[599326]30#include <kernel/ideals.h>
[0fb34ba]31#include <polys/matpol.h>
[599326]32#include <kernel/kstd1.h>
[0fb34ba]33#include <polys/monomials/ring.h>
[599326]34#include <Singular/subexpr.h>
[0fb34ba]35#include <polys/monomials/maps.h>
[599326]36#include <kernel/syz.h>
[0fb34ba]37#include <coeffs/numbers.h>
[599326]38#include <kernel/modulop.h>
[b787fb6]39//#include <polys/ext_fields/longalg.h>
[599326]40#include <Singular/lists.h>
41#include <Singular/attrib.h>
42#include <Singular/ipconv.h>
[44ca2f]43#include <Singular/links/silink.h>
[599326]44#include <kernel/stairc.h>
[0fb34ba]45#include <polys/weight.h>
[599326]46#include <kernel/semic.h>
47#include <kernel/splist.h>
48#include <kernel/spectrum.h>
[77bb59]49////// #include <coeffs/gnumpfl.h>
[b5f5444]50//#include <kernel/mpr_base.h>
[77bb59]51////// #include <coeffs/ffields.h>
[47417b]52#include <polys/clapsing.h>
[599326]53#include <kernel/hutil.h>
[0fb34ba]54#include <polys/monomials/ring.h>
[599326]55#include <Singular/ipshell.h>
[6cc7f5]56#include <polys/ext_fields/algext.h>
57#include <coeffs/mpr_complex.h>
[f5bef2]58#include <coeffs/longrat.h>
[2e85a1]59#include <coeffs/rmodulon.h>
[213d64]60
[6cc7f5]61#include <numeric/mpr_base.h>
62#include <numeric/mpr_numeric.h>
[0e1846]63
[77bb59]64#include <math.h>
[06aafe1]65#include <ctype.h>
[77bb59]66
[e7e815]67#include <polys/ext_fields/algext.h>
68#include <polys/ext_fields/transext.h>
69
[33293b6]70// define this if you want to use the fast_map routine for mapping ideals
[b9020c3]71#define FAST_MAP
[33293b6]72
73#ifdef FAST_MAP
[599326]74#include <kernel/fast_maps.h>
[33293b6]75#endif
76
[0e1846]77leftv iiCurrArgs=NULL;
[f71681]78idhdl iiCurrProc=NULL;
[85e68dd]79const char *lastreserved=NULL;
[0e1846]80
81static BOOLEAN iiNoKeepRing=TRUE;
82
83/*0 implementation*/
84
[85e68dd]85const char * iiTwoOps(int t)
[0e1846]86{
87  if (t<127)
88  {
89    static char ch[2];
90    switch (t)
91    {
92      case '&':
93        return "and";
94      case '|':
95        return "or";
96      default:
97        ch[0]=t;
98        ch[1]='\0';
99        return ch;
100    }
101  }
102  switch (t)
103  {
[057e93c]104    case COLONCOLON:  return "::";
[0e1846]105    case DOTDOT:      return "..";
106    //case PLUSEQUAL:   return "+=";
107    //case MINUSEQUAL:  return "-=";
108    case MINUSMINUS:  return "--";
109    case PLUSPLUS:    return "++";
110    case EQUAL_EQUAL: return "==";
111    case LE:          return "<=";
112    case GE:          return ">=";
113    case NOTEQUAL:    return "<>";
114    default:          return Tok2Cmdname(t);
115  }
116}
117
[06c0b3]118int iiOpsTwoChar(const char *s)
119{
120/* not handling: &&, ||, ** */
121  if (s[1]=='\0') return s[0];
122  else if (s[2]!='\0') return 0;
123  switch(s[0])
124  {
125    case '.': if (s[1]=='.') return DOTDOT;
126              else           return 0;
127    case ':': if (s[1]==':') return COLONCOLON;
128              else           return 0;
129    case '-': if (s[1]=='-') return COLONCOLON;
130              else           return 0;
131    case '+': if (s[1]=='+') return PLUSPLUS;
132              else           return 0;
133    case '=': if (s[1]=='=') return EQUAL_EQUAL;
134              else           return 0;
135    case '<': if (s[1]=='=') return LE;
136              else if (s[1]=='>') return NOTEQUAL;
137              else           return 0;
138    case '>': if (s[1]=='=') return GE;
139              else           return 0;
140    case '!': if (s[1]=='=') return NOTEQUAL;
141              else           return 0;
142  }
143  return 0;
144}
145
[7da3cd]146static void list1(const char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
[0e1846]147{
148  char buffer[22];
149  int l;
[daeb6d]150  char buf2[128];
[0e1846]151
[c62170]152  if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
153  else sprintf(buf2, "%s", IDID(h));
[daeb6d]154
[74c52c]155  Print("%s%-30.30s [%d]  ",s,buf2,IDLEV(h));
[0e1846]156  if (h == currRingHdl) PrintS("*");
157  PrintS(Tok2Cmdname((int)IDTYP(h)));
158
159  ipListFlag(h);
160  switch(IDTYP(h))
161  {
[c5f17b]162    case INT_CMD:   Print(" %d",IDINT(h)); break;
163    case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
164    case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
165                    break;
[0e1846]166    case POLY_CMD:
[c5f17b]167    case VECTOR_CMD:if (c)
168                    {
169                      PrintS(" ");wrp(IDPOLY(h));
170                      if(IDPOLY(h) != NULL)
171                      {
172                        Print(", %d monomial(s)",pLength(IDPOLY(h)));
173                      }
174                    }
175                    break;
[d3a49c]176    case MODUL_CMD: Print(", rk %d", (int)(IDIDEAL(h)->rank));
[c5f17b]177    case IDEAL_CMD: Print(", %u generator(s)",
[d3a49c]178                    IDELEMS(IDIDEAL(h))); break;
[0e1846]179    case MAP_CMD:
[c5f17b]180                    Print(" from %s",IDMAP(h)->preimage); break;
181    case MATRIX_CMD:Print(" %u x %u"
182                      ,MATROWS(IDMATRIX(h))
183                      ,MATCOLS(IDMATRIX(h))
184                    );
185                    break;
[daeb6d]186    case PACKAGE_CMD:
[af6ba3]187                    paPrint(IDID(h),IDPACKAGE(h));
[daeb6d]188                    break;
[fe9ee1]189    case PROC_CMD: if((IDPROC(h)->libname!=NULL)
190                   && (strlen(IDPROC(h)->libname)>0))
[c5f17b]191                     Print(" from %s",IDPROC(h)->libname);
192                   if(IDPROC(h)->is_static)
[0c6135]193                     PrintS(" (static)");
[33e521]194                   break;
[0e1846]195    case STRING_CMD:
196                   {
197                     char *s;
198                     l=strlen(IDSTRING(h));
199                     memset(buffer,0,22);
[f43a74]200                     strncpy(buffer,IDSTRING(h),si_min(l,20));
[0e1846]201                     if ((s=strchr(buffer,'\n'))!=NULL)
202                     {
203                       *s='\0';
204                     }
205                     PrintS(" ");
206                     PrintS(buffer);
207                     if((s!=NULL) ||(l>20))
208                     {
209                       Print("..., %d char(s)",l);
210                     }
211                     break;
212                   }
[c5f17b]213    case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
[0e1846]214                   break;
215    case QRING_CMD:
216    case RING_CMD:
[9bc0b8]217                   if ((IDRING(h)==currRing) && (currRingHdl!=h))
218                     PrintS("(*)"); /* this is an alias to currRing */
[0e1846]219#ifdef RDEBUG
[0c6135]220                   if (traceit &TRACE_SHOW_RINGS)
[d3a49c]221                     Print(" <%lx>",(long)(IDRING(h)));
[0e1846]222#endif
223                   break;
224    /*default:     break;*/
225  }
226  PrintLn();
227}
228
[103560]229void type_cmd(leftv v)
[0e1846]230{
[c5f4b9]231  BOOLEAN oldShortOut = FALSE;
[bd4cb92]232
[c5f4b9]233  if (currRing != NULL)
234  {
235    oldShortOut = currRing->ShortOut;
236    currRing->ShortOut = 1;
237  }
[103560]238  int t=v->Typ();
239  Print("// %s %s ",v->Name(),Tok2Cmdname(t));
240  switch (t)
[0e1846]241  {
[103560]242    case MAP_CMD:Print(" from %s\n",((map)(v->Data()))->preimage); break;
243    case INTMAT_CMD: Print(" %d x %d\n",((intvec*)(v->Data()))->rows(),
244                                      ((intvec*)(v->Data()))->cols()); break;
245    case MATRIX_CMD:Print(" %u x %u\n" ,
246       MATROWS((matrix)(v->Data())),
247       MATCOLS((matrix)(v->Data())));break;
248    case MODUL_CMD: Print(", rk %d\n", (int)(((ideal)(v->Data()))->rank));break;
249    case LIST_CMD: Print(", size %d\n",((lists)(v->Data()))->nr+1); break;
250
251    case PROC_CMD:
252    case RING_CMD:
253    case IDEAL_CMD:
254    case QRING_CMD: PrintLn(); break;
255
256    //case INT_CMD:
257    //case STRING_CMD:
258    //case INTVEC_CMD:
259    //case POLY_CMD:
260    //case VECTOR_CMD:
261    //case PACKAGE_CMD:
262
263    default:
264      break;
[0e1846]265  }
[103560]266  v->Print();
[c5f4b9]267  if (currRing != NULL)
268    currRing->ShortOut = oldShortOut;
[0e1846]269}
270
[860475]271static void killlocals0(int v, idhdl * localhdl, const ring r)
[0e1846]272{
273  idhdl h = *localhdl;
274  while (h!=NULL)
275  {
276    int vv;
[fca547]277    //Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
[0e1846]278    if ((vv=IDLEV(h))>0)
279    {
280      if (vv < v)
281      {
[c5f17b]282        if (iiNoKeepRing)
283        {
[fca547]284          //PrintS(" break\n");
[c5f17b]285          return;
286        }
[0e1846]287        h = IDNEXT(h);
[fca547]288        //PrintLn();
[0e1846]289      }
[b99381]290      else //if (vv >= v)
[0e1846]291      {
292        idhdl nexth = IDNEXT(h);
[860475]293        killhdl2(h,localhdl,r);
[0e1846]294        h = nexth;
[fca547]295        //PrintS("kill\n");
[0e1846]296      }
297    }
298    else
[fca547]299    {
[0e1846]300      h = IDNEXT(h);
[fca547]301      //PrintLn();
302    }
[0e1846]303  }
304}
[57f94a]305void killlocals_list(lists l,int v)
306{
307  int i;
308  for(i=l->nr; i>=0; i--)
309  {
310    if (l->m[i].rtyp == LIST_CMD)
311      killlocals_list((lists)l->m[i].data,v);
312    else if ((l->m[i].rtyp == RING_CMD) || (l->m[i].rtyp == QRING_CMD))
313      killlocals0(v,&(((ring)(l->m[i].data))->idroot),currRing);
314  }
315}
[16acb0]316void killlocals_rec(idhdl *root,int v, ring r)
[3b1a83c]317{
318  idhdl h=*root;
319  while (h!=NULL)
320  {
321    if (IDLEV(h)>=v)
322    {
323//      Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
324      idhdl n=IDNEXT(h);
[16acb0]325      killhdl2(h,root,r);
[3b1a83c]326      h=n;
327    }
328    else if (IDTYP(h)==PACKAGE_CMD)
329    {
330 //     Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
331      if (IDPACKAGE(h)!=basePack)
[16acb0]332        killlocals_rec(&(IDRING(h)->idroot),v,r);
[3b1a83c]333      h=IDNEXT(h);
334    }
335    else if ((IDTYP(h)==RING_CMD)
336    ||(IDTYP(h)==QRING_CMD))
337    {
[e2efbe9]338      if ((IDRING(h)!=NULL) && (IDRING(h)->idroot!=NULL))
339      // we have to test IDRING(h)!=NULL: qring Q=groebner(...): killlocals
[3b1a83c]340      {
341  //    Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
[16acb0]342        killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
[3b1a83c]343      }
344      h=IDNEXT(h);
345    }
346    else
347    {
348//      Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
349      h=IDNEXT(h);
350    }
351  }
352}
[0f28d9]353BOOLEAN killlocals_list(int v, lists L)
354{
355  if (L==NULL) return FALSE;
356  BOOLEAN changed=FALSE;
357  int n=L->nr;
358  for(;n>=0;n--)
359  {
360    leftv h=&(L->m[n]);
361    void *d=h->data;
362    if (((h->rtyp==RING_CMD) || (h->rtyp==QRING_CMD))
363    && (((ring)d)->idroot!=NULL))
364    {
365      if (d!=currRing) {changed=TRUE;rChangeCurrRing((ring)d);}
[860475]366      killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
[0f28d9]367    }
368    else if (h->rtyp==LIST_CMD)
369      changed|=killlocals_list(v,(lists)d);
370  }
371  return changed;
372}
[3b1a83c]373void killlocals(int v)
374{
375  BOOLEAN changed=FALSE;
376  idhdl sh=currRingHdl;
[0f28d9]377  ring cr=currRing;
[6f3743]378  if (sh!=NULL) changed=((IDLEV(sh)<v) || (IDRING(sh)->ref>0));
379  //if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
[3b1a83c]380
[16acb0]381  killlocals_rec(&(basePack->idroot),v,currRing);
[3b1a83c]382
[0f28d9]383  if (iiRETURNEXPR_len > myynest)
[3b1a83c]384  {
[f92a39]385    int t=iiRETURNEXPR.Typ();
386    if ((/*iiRETURNEXPR.Typ()*/ t==RING_CMD)
387    || (/*iiRETURNEXPR.Typ()*/ t==QRING_CMD))
[0f28d9]388    {
[f92a39]389      leftv h=&iiRETURNEXPR;
[0f28d9]390      if (((ring)h->data)->idroot!=NULL)
[860475]391        killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
[0f28d9]392    }
[f92a39]393    else if (/*iiRETURNEXPR.Typ()*/ t==LIST_CMD)
[0f28d9]394    {
[f92a39]395      leftv h=&iiRETURNEXPR;
[0f28d9]396      changed |=killlocals_list(v,(lists)h->data);
397    }
[3b1a83c]398  }
399  if (changed)
400  {
[0f28d9]401    currRingHdl=rFindHdl(cr,NULL,NULL);
[7035b2]402    if (currRingHdl==NULL)
[23f2f57]403      currRing=NULL;
404    else
405      rChangeCurrRing(cr);
[3b1a83c]406  }
407
408  if (myynest<=1) iiNoKeepRing=TRUE;
409  //Print("end killlocals  >= %d\n",v);
410  //listall();
411}
[0e1846]412
[7da3cd]413void list_cmd(int typ, const char* what, const char *prefix,BOOLEAN iterate, BOOLEAN fullname)
[0e1846]414{
415  idhdl h,start;
[c62170]416  BOOLEAN all = typ<0;
[0e1846]417  BOOLEAN really_all=FALSE;
[0c6135]418
[0e1846]419  if ( typ==0 )
420  {
421    if (strcmp(what,"all")==0)
422    {
423      really_all=TRUE;
[bd4cb92]424      h=basePack->idroot;
[0e1846]425    }
426    else
427    {
428      h = ggetid(what);
429      if (h!=NULL)
430      {
[daeb6d]431        if (iterate) list1(prefix,h,TRUE,fullname);
[7cbe8e]432        if (IDTYP(h)==ALIAS_CMD) PrintS("A");
[c5f17b]433        if ((IDTYP(h)==RING_CMD)
[bd4cb92]434            || (IDTYP(h)==QRING_CMD)
435            //|| (IDTYP(h)==PACKE_CMD)
436        )
[c5f17b]437        {
438          h=IDRING(h)->idroot;
439        }
[46d09b]440        else if((IDTYP(h)==PACKAGE_CMD) || (IDTYP(h)==POINTER_CMD))
441        {
[2ef280]442          //Print("list_cmd:package or pointer\n");
[d66a7d]443          all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
[bd4cb92]444          h=IDPACKAGE(h)->idroot;
[46d09b]445        }
[c5f17b]446        else
447          return;
[0e1846]448      }
449      else
450      {
451        Werror("%s is undefined",what);
452        return;
453      }
454    }
455    all=TRUE;
456  }
[df5fc1]457  else if (RingDependend(typ))
[0e1846]458  {
459    h = currRing->idroot;
460  }
461  else
[46d09b]462    h = IDROOT;
[0e1846]463  start=h;
464  while (h!=NULL)
465  {
[f2dff02]466    if ((all && (IDTYP(h)!=PROC_CMD) &&(IDTYP(h)!=PACKAGE_CMD))
467    || (typ == IDTYP(h))
[0e1846]468    || ((IDTYP(h)==QRING_CMD) && (typ==RING_CMD)))
469    {
[daeb6d]470      list1(prefix,h,start==currRingHdl, fullname);
[46d09b]471      if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
[0e1846]472        && (really_all || (all && (h==currRingHdl)))
473        && ((IDLEV(h)==0)||(IDLEV(h)==myynest)))
474      {
475        list_cmd(0,IDID(h),"//      ",FALSE);
476      }
[bd4cb92]477      if (IDTYP(h)==PACKAGE_CMD && really_all)
478      {
[925a4b9]479        package save_p=currPack;
480        currPack=IDPACKAGE(h);
[bd4cb92]481        list_cmd(0,IDID(h),"//      ",FALSE);
[925a4b9]482        currPack=save_p;
[bd4cb92]483      }
[0e1846]484    }
485    h = IDNEXT(h);
486  }
487}
488
489void test_cmd(int i)
490{
[7cdf2b1]491  int ii;
[0e1846]492
[7cdf2b1]493  if (i<0)
[0e1846]494  {
[7cdf2b1]495    ii= -i;
496    if (ii < 32)
[0e1846]497    {
[d30a399]498      si_opt_1 &= ~Sy_bit(ii);
[0e1846]499    }
[7cdf2b1]500    else if (ii < 64)
[0e1846]501    {
[d30a399]502      si_opt_2 &= ~Sy_bit(ii-32);
[0e1846]503    }
[7cdf2b1]504    else
505      WerrorS("out of bounds\n");
[0e1846]506  }
[7cdf2b1]507  else if (i<32)
508  {
509    ii=i;
510    if (Sy_bit(ii) & kOptions)
511    {
512      Warn("Gerhard, use the option command");
[d30a399]513      si_opt_1 |= Sy_bit(ii);
[7cdf2b1]514    }
515    else if (Sy_bit(ii) & validOpts)
[d30a399]516      si_opt_1 |= Sy_bit(ii);
[7cdf2b1]517  }
518  else if (i<64)
519  {
520    ii=i-32;
[d30a399]521    si_opt_2 |= Sy_bit(ii);
[7cdf2b1]522  }
523  else
524    WerrorS("out of bounds\n");
[0e1846]525}
526
527int exprlist_length(leftv v)
528{
529  int rc = 0;
530  while (v!=NULL)
531  {
532    switch (v->Typ())
533    {
534      case INT_CMD:
535      case POLY_CMD:
536      case VECTOR_CMD:
537      case NUMBER_CMD:
538        rc++;
539        break;
540      case INTVEC_CMD:
541      case INTMAT_CMD:
542        rc += ((intvec *)(v->Data()))->length();
543        break;
544      case MATRIX_CMD:
545      case IDEAL_CMD:
546      case MODUL_CMD:
547        {
548          matrix mm = (matrix)(v->Data());
549          rc += mm->rows() * mm->cols();
550        }
551        break;
552      case LIST_CMD:
553        rc+=((lists)v->Data())->nr+1;
554        break;
555      default:
556        rc++;
557    }
558    v = v->next;
559  }
560  return rc;
561}
562
[f30fdc]563int iiIsPrime0(unsigned p)  /* brute force !!!! */
[0e1846]564{
[282c8d]565  unsigned i,j=0 /*only to avoid compiler warnings*/;
[2eeb7d]566#ifdef HAVE_FACTORY
[f30fdc]567  if (p<=32749) // max. small prime in factory
[2eeb7d]568  {
[cd22d1a]569    int a=0;
570    int e=cf_getNumSmallPrimes()-1;
571    i=e/2;
572    do
573    {
[282c8d]574      j=cf_getSmallPrime(i);
575      if (p==j) return p;
[cd22d1a]576      if (p<j) e=i-1;
577      else     a=i+1;
578      i=a+(e-a)/2;
579    } while ( a<= e);
580    if (p>j) return j;
581    else     return cf_getSmallPrime(i-1);
582  }
583#endif
584#ifdef HAVE_FACTORY
[f30fdc]585  unsigned end_i=cf_getNumSmallPrimes()-1;
[26ac996]586#else
[f30fdc]587  unsigned end_i=p/2;
[7035b2]588#endif
[f30fdc]589  unsigned end_p=(unsigned)sqrt((double)p);
[cd22d1a]590restart:
591  for (i=0; i<end_i; i++)
[0e1846]592  {
[cd22d1a]593#ifdef HAVE_FACTORY
594    j=cf_getSmallPrime(i);
595#else
596    if (i==0) j=2;
597    else j=2*i-1;
[7035b2]598#endif
[cd22d1a]599    if ((p%j) == 0)
600    {
601    #ifdef HAVE_FACTORY
[f30fdc]602      if (p<=32751) return iiIsPrime0(p-2);
[7035b2]603    #endif
[cd22d1a]604      p-=2;
605      goto restart;
606    }
607    if (j > end_p) return p;
[0e1846]608  }
[96f9be8]609#ifdef HAVE_FACTORY
610  if (i>=end_i)
611  {
612    while(j<=end_p)
613    {
614      j+=2;
615      if ((p%j) == 0)
616      {
617        if (p<=32751) return iiIsPrime0(p-2);
618        p-=2;
619        goto restart;
620      }
621    }
622  }
623#endif
[0e1846]624  return p;
625}
[f30fdc]626int IsPrime(int p)  /* brute force !!!! */
627{
628  if      (p == 0)    return 0;
629  else if (p == 1)    return 1/*1*/;
630  else if ((p == 2)||(p==3))    return p;
[6bcda60]631  else if (p < 0)     return 2; //(iiIsPrime0((unsigned)(-p)));
[f30fdc]632  else if ((p & 1)==0) return iiIsPrime0((unsigned)(p-1));
633  return iiIsPrime0((unsigned)(p));
634}
[0e1846]635
[69672d]636BOOLEAN iiWRITE(leftv,leftv v)
[0e1846]637{
638  sleftv vf;
639  if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
640  {
[da97958]641    WerrorS("link expected");
[0e1846]642    return TRUE;
643  }
644  si_link l=(si_link)vf.Data();
[d754b7]645  if (vf.next == NULL)
646  {
[da97958]647    WerrorS("write: need at least two arguments");
[d754b7]648    return TRUE;
649  }
650
[0e1846]651  BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
652  if (b)
653  {
654    const char *s;
655    if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
656    else                            s=sNoName;
657    Werror("cannot write to %s",s);
658  }
659  vf.CleanUp();
660  return b;
661}
662
[85e68dd]663leftv iiMap(map theMap, const char * what)
[0e1846]664{
665  idhdl w,r;
666  leftv v;
667  int i;
[4508ce5]668  nMapFunc nMap;
[0e1846]669
[bd4cb92]670  r=IDROOT->get(theMap->preimage,myynest);
[a3bc95e]671  if ((currPack!=basePack)
672  &&((r==NULL) || ((r->typ != RING_CMD) && (r->typ != QRING_CMD))))
673    r=basePack->idroot->get(theMap->preimage,myynest);
[fba8c99]674  if ((r==NULL) && (currRingHdl!=NULL)
675  && (strcmp(theMap->preimage,IDID(currRingHdl))==0))
676  {
677    r=currRingHdl;
678  }
[0e1846]679  if ((r!=NULL) && ((r->typ == RING_CMD) || (r->typ== QRING_CMD)))
680  {
[4508ce5]681    //if ((nMap=nSetMap(rInternalChar(IDRING(r)),
[d4373f]682    //             IDRING(r)->parameter,
683    //             rPar(IDRING(r)),
[4508ce5]684    //             IDRING(r)->minpoly)))
[77bb59]685    if ((nMap=n_SetMap(IDRING(r)->cf, currRing->cf))==NULL)
[0e1846]686    {
[77bb59]687////////// WTF?
688//      if (rEqual(IDRING(r),currRing))
689//      {
690//        nMap = n_SetMap(currRing->cf, currRing->cf);
691//      }
692//      else
693//      {
[f13dc47]694        Werror("can not map from ground field of %s to current ground field",
695          theMap->preimage);
696        return NULL;
[77bb59]697//      }
[0e1846]698    }
699    if (IDELEMS(theMap)<IDRING(r)->N)
700    {
[c232af]701      theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
[c5f17b]702                                 IDELEMS(theMap)*sizeof(poly),
703                                 (IDRING(r)->N)*sizeof(poly));
[0e1846]704      for(i=IDELEMS(theMap);i<IDRING(r)->N;i++)
705        theMap->m[i]=NULL;
706      IDELEMS(theMap)=IDRING(r)->N;
707    }
708    if (what==NULL)
709    {
[da97958]710      WerrorS("argument of a map must have a name");
[0e1846]711    }
712    else if ((w=IDRING(r)->idroot->get(what,myynest))!=NULL)
713    {
[5d466e]714      char *save_r=NULL;
[c232af]715      v=(leftv)omAlloc0Bin(sleftv_bin);
[0e1846]716      sleftv tmpW;
717      memset(&tmpW,0,sizeof(sleftv));
718      tmpW.rtyp=IDTYP(w);
[392682]719      if (tmpW.rtyp==MAP_CMD)
720      {
[5d466e]721        tmpW.rtyp=IDEAL_CMD;
722        save_r=IDMAP(w)->preimage;
723        IDMAP(w)->preimage=0;
724      }
[0e1846]725      tmpW.data=IDDATA(w);
[f5bef2]726#if 0
[0ea97e]727      if (((tmpW.rtyp==IDEAL_CMD)||(tmpW.rtyp==MODUL_CMD)) && idIs0(IDIDEAL(w)))
[33293b6]728      {
[0ea97e]729        v->rtyp=tmpW.rtyp;
730        v->data=idInit(IDELEMS(IDIDEAL(w)),IDIDEAL(w)->rank);
[33293b6]731      }
732      else
[f5bef2]733#endif
[0e1846]734      {
[f5bef2]735#ifdef FAST_MAP
736        if ((tmpW.rtyp==IDEAL_CMD) && (nMap == ndCopyMap)
737#ifdef HAVE_PLURAL
[0ea97e]738        && (!rIsPluralRing(currRing))
[f5bef2]739#endif
[0ea97e]740        )
741        {
742          v->rtyp=IDEAL_CMD;
743          v->data=fast_map(IDIDEAL(w), IDRING(r), (ideal)theMap, currRing);
744        }
745        else
[f5bef2]746#endif
[0ea97e]747        if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,IDRING(r),NULL,NULL,0,nMap))
748        {
749          Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
750          omFreeBin((ADDRESS)v, sleftv_bin);
751          if (save_r!=NULL) IDMAP(w)->preimage=save_r;
752          return NULL;
753        }
[0e1846]754      }
[5d466e]755      if (save_r!=NULL)
[392682]756      {
[5d466e]757        IDMAP(w)->preimage=save_r;
758        IDMAP((idhdl)v)->preimage=omStrDup(save_r);
759        v->rtyp=MAP_CMD;
760      }
[0e1846]761      return v;
762    }
763    else
[c5f17b]764    {
[0e1846]765      Werror("%s undefined in %s",what,theMap->preimage);
[c5f17b]766    }
[0e1846]767  }
768  else
[c5f17b]769  {
[0e1846]770    Werror("cannot find preimage %s",theMap->preimage);
[c5f17b]771  }
[0e1846]772  return NULL;
773}
774
775#ifdef OLD_RES
776void  iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
777                   intvec ** weights)
778{
779  lists L=liMakeResolv(r,length,rlen,typ0,weights);
780  int i=0;
781  idhdl h;
[c232af]782  char * s=(char *)omAlloc(strlen(name)+5);
[0e1846]783
784  while (i<=L->nr)
785  {
786    sprintf(s,"%s(%d)",name,i+1);
787    if (i==0)
[3b1a83c]788      h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
[0e1846]789    else
[3b1a83c]790      h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
[0e1846]791    if (h!=NULL)
792    {
793      h->data.uideal=(ideal)L->m[i].data;
794      h->attribute=L->m[i].attribute;
795      if (BVERBOSE(V_DEF_RES))
796        Print("//defining: %s as %d-th syzygy module\n",s,i+1);
797    }
798    else
799    {
800      idDelete((ideal *)&(L->m[i].data));
801      Warn("cannot define %s",s);
802    }
803    //L->m[i].data=NULL;
804    //L->m[i].rtyp=0;
805    //L->m[i].attribute=NULL;
806    i++;
807  }
[c232af]808  omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
809  omFreeBin((ADDRESS)L, slists_bin);
810  omFreeSize((ADDRESS)s,strlen(name)+5);
[0e1846]811}
812#endif
813
814//resolvente iiFindRes(char * name, int * len, int *typ0)
815//{
[c232af]816//  char *s=(char *)omAlloc(strlen(name)+5);
[0e1846]817//  int i=-1;
818//  resolvente r;
819//  idhdl h;
820//
821//  do
822//  {
823//    i++;
824//    sprintf(s,"%s(%d)",name,i+1);
825//    h=currRing->idroot->get(s,myynest);
826//  } while (h!=NULL);
827//  *len=i-1;
828//  if (*len<=0)
829//  {
830//    Werror("no objects %s(1),.. found",name);
[c232af]831//    omFreeSize((ADDRESS)s,strlen(name)+5);
[0e1846]832//    return NULL;
833//  }
[c232af]834//  r=(ideal *)omAlloc(/*(len+1)*/ i*sizeof(ideal));
[0e1846]835//  memset(r,0,(*len)*sizeof(ideal));
836//  i=-1;
837//  *typ0=MODUL_CMD;
838//  while (i<(*len))
839//  {
840//    i++;
841//    sprintf(s,"%s(%d)",name,i+1);
842//    h=currRing->idroot->get(s,myynest);
843//    if (h->typ != MODUL_CMD)
844//    {
845//      if ((i!=0) || (h->typ!=IDEAL_CMD))
846//      {
847//        Werror("%s is not of type module",s);
[c232af]848//        omFreeSize((ADDRESS)r,(*len)*sizeof(ideal));
849//        omFreeSize((ADDRESS)s,strlen(name)+5);
[0e1846]850//        return NULL;
851//      }
852//      *typ0=IDEAL_CMD;
853//    }
854//    if ((i>0) && (idIs0(r[i-1])))
855//    {
856//      *len=i-1;
857//      break;
858//    }
859//    r[i]=IDIDEAL(h);
860//  }
[c232af]861//  omFreeSize((ADDRESS)s,strlen(name)+5);
[0e1846]862//  return r;
863//}
864
[4145db]865static resolvente iiCopyRes(resolvente r, int l)
[0e1846]866{
867  int i;
[c232af]868  resolvente res=(ideal *)omAlloc0((l+1)*sizeof(ideal));
[0e1846]869
870  for (i=0; i<l; i++)
871    res[i]=idCopy(r[i]);
872  return res;
873}
874
875BOOLEAN jjMINRES(leftv res, leftv v)
876{
877  int len=0;
878  int typ0;
[f43a74]879  lists L=(lists)v->Data();
880  intvec *weights=(intvec*)atGet(v,"isHomog",INTVEC_CMD);
881  int add_row_shift = 0;
882  if (weights==NULL)
[7035b2]883    weights=(intvec*)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
[f43a74]884  if (weights!=NULL)  add_row_shift=weights->min_in();
885  resolvente rr=liFindRes(L,&len,&typ0);
[0e1846]886  if (rr==NULL) return TRUE;
887  resolvente r=iiCopyRes(rr,len);
888
889  syMinimizeResolvente(r,len,0);
[c232af]890  omFreeSize((ADDRESS)rr,len*sizeof(ideal));
[0e1846]891  len++;
[f43a74]892  res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL,add_row_shift);
[0e1846]893  return FALSE;
894}
895
[7f14f2]896BOOLEAN jjBETTI(leftv res, leftv u)
897{
898  sleftv tmp;
899  memset(&tmp,0,sizeof(tmp));
900  tmp.rtyp=INT_CMD;
[7035b2]901  tmp.data=(void *)1;
[709ab0]902  if ((u->Typ()==IDEAL_CMD)
903  || (u->Typ()==MODUL_CMD))
904    return jjBETTI2_ID(res,u,&tmp);
905  else
906    return jjBETTI2(res,u,&tmp);
907}
908
909BOOLEAN jjBETTI2_ID(leftv res, leftv u, leftv v)
910{
911  lists l=(lists) omAllocBin(slists_bin);
912  l->Init(1);
913  l->m[0].rtyp=u->Typ();
914  l->m[0].data=u->Data();
[c227a2f]915  attr *a=u->Attribute();
916  if (a!=NULL)
917  l->m[0].attribute=*a;
[709ab0]918  sleftv tmp2;
919  memset(&tmp2,0,sizeof(tmp2));
920  tmp2.rtyp=LIST_CMD;
921  tmp2.data=(void *)l;
922  BOOLEAN r=jjBETTI2(res,&tmp2,v);
923  l->m[0].data=NULL;
924  l->m[0].attribute=NULL;
925  l->m[0].rtyp=DEF_CMD;
926  l->Clean();
927  return r;
[7f14f2]928}
929
930BOOLEAN jjBETTI2(leftv res, leftv u, leftv v)
[0e1846]931{
932  resolvente r;
933  int len;
934  int reg,typ0;
[7f14f2]935  lists l=(lists)u->Data();
936
[709ab0]937  intvec *weights=NULL;
938  int add_row_shift=0;
[7035b2]939  intvec *ww=(intvec *)atGet(&(l->m[0]),"isHomog",INTVEC_CMD);
[709ab0]940  if (ww!=NULL)
941  {
942     weights=ivCopy(ww);
943     add_row_shift = ww->min_in();
944     (*weights) -= add_row_shift;
945  }
[7f14f2]946  //Print("attr:%x\n",weights);
[0e1846]947
[7f14f2]948  r=liFindRes(l,&len,&typ0);
[0e1846]949  if (r==NULL) return TRUE;
[7447d8]950  res->data=(char *)syBetti(r,len,&reg,weights,(int)(long)v->Data());
[c232af]951  omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
[327eae8]952  atSet(res,omStrDup("rowShift"),(void*)add_row_shift,INT_CMD);
[709ab0]953  if (weights!=NULL) delete weights;
[0e1846]954  return FALSE;
955}
956
957int iiRegularity(lists L)
958{
959  int len,reg,typ0;
960
[26ac996]961  resolvente r=liFindRes(L,&len,&typ0);
962
963  if (r==NULL)
964    return -2;
[178d03]965  intvec *weights=NULL;
966  int add_row_shift=0;
967  intvec *ww=(intvec *)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
968  if (ww!=NULL)
969  {
970     weights=ivCopy(ww);
971     add_row_shift = ww->min_in();
972     (*weights) -= add_row_shift;
973  }
974  //Print("attr:%x\n",weights);
975
976  intvec *dummy=syBetti(r,len,&reg,weights);
977  if (weights!=NULL) delete weights;
[0e1846]978  delete dummy;
[178d03]979  omFreeSize((ADDRESS)r,len*sizeof(ideal));
980  return reg+1+add_row_shift;
[0e1846]981}
982
983BOOLEAN iiDebugMarker=TRUE;
[b1dd2f]984#define BREAK_LINE_LENGTH 80
[0e1846]985void iiDebug()
986{
987  Print("\n-- break point in %s --\n",VoiceName());
[057e93c]988  if (iiDebugMarker) VoiceBackTrack();
[0e1846]989  char * s;
990  iiDebugMarker=FALSE;
[c232af]991  s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
[b1dd2f]992  loop
993  {
994    memset(s,0,80);
995    fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
996    if (s[BREAK_LINE_LENGTH-1]!='\0')
997    {
998      Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
999    }
1000    else
1001      break;
1002  }
[0e1846]1003  if (*s=='\n')
1004  {
1005    iiDebugMarker=TRUE;
1006  }
[9ccebb]1007#if MDEBUG
1008  else if(strncmp(s,"cont;",5)==0)
1009  {
1010    iiDebugMarker=TRUE;
1011  }
1012#endif /* MDEBUG */
[0e1846]1013  else
1014  {
1015    strcat( s, "\n;~\n");
1016    newBuffer(s,BT_execute);
1017  }
1018}
1019
[938688]1020lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
1021{
1022  int i;
1023  indset save;
1024  lists res=(lists)omAlloc0Bin(slists_bin);
1025
1026  hexist = hInit(S, Q, &hNexist);
[883eacf]1027  if (hNexist == 0)
1028  {
[7fccc79]1029    intvec *iv=new intvec(rVar(currRing));
1030    for(i=0; i<rVar(currRing); i++) (*iv)[i]=1;
[883eacf]1031    res->Init(1);
1032    res->m[0].rtyp=INTVEC_CMD;
1033    res->m[0].data=(intvec*)iv;
1034    return res;
1035  }
1036  else if (hisModule!=0)
[938688]1037  {
1038    res->Init(0);
1039    return res;
1040  }
1041  save = ISet = (indset)omAlloc0Bin(indlist_bin);
1042  hMu = 0;
1043  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
[7fccc79]1044  hvar = (varset)omAlloc((rVar(currRing) + 1) * sizeof(int));
1045  hpure = (scmon)omAlloc((1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
[938688]1046  hrad = hexist;
1047  hNrad = hNexist;
[7fccc79]1048  radmem = hCreate(rVar(currRing) - 1);
1049  hCo = rVar(currRing) + 1;
1050  hNvar = rVar(currRing);
[938688]1051  hRadical(hrad, &hNrad, hNvar);
1052  hSupp(hrad, hNrad, hvar, &hNvar);
1053  if (hNvar)
1054  {
1055    hCo = hNvar;
[7fccc79]1056    memset(hpure, 0, (rVar(currRing) + 1) * sizeof(long));
[938688]1057    hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
1058    hLexR(hrad, hNrad, hvar, hNvar);
1059    hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1060  }
[7fccc79]1061  if (hCo && (hCo < rVar(currRing)))
[938688]1062  {
1063    hIndMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1064  }
1065  if (hMu!=0)
1066  {
1067    ISet = save;
1068    hMu2 = 0;
[7fccc79]1069    if (all && (hCo+1 < rVar(currRing)))
[938688]1070    {
1071      JSet = (indset)omAlloc0Bin(indlist_bin);
1072      hIndAllMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1073      i=hMu+hMu2;
1074      res->Init(i);
1075      if (hMu2 == 0)
1076      {
1077        omFreeBin((ADDRESS)JSet, indlist_bin);
1078      }
1079    }
1080    else
1081    {
1082      res->Init(hMu);
1083    }
1084    for (i=0;i<hMu;i++)
1085    {
1086      res->m[i].data = (void *)save->set;
1087      res->m[i].rtyp = INTVEC_CMD;
1088      ISet = save;
1089      save = save->nx;
1090      omFreeBin((ADDRESS)ISet, indlist_bin);
1091    }
1092    omFreeBin((ADDRESS)save, indlist_bin);
1093    if (hMu2 != 0)
1094    {
1095      save = JSet;
1096      for (i=hMu;i<hMu+hMu2;i++)
1097      {
1098        res->m[i].data = (void *)save->set;
1099        res->m[i].rtyp = INTVEC_CMD;
1100        JSet = save;
1101        save = save->nx;
1102        omFreeBin((ADDRESS)JSet, indlist_bin);
1103      }
1104      omFreeBin((ADDRESS)save, indlist_bin);
1105    }
1106  }
1107  else
1108  {
1109    res->Init(0);
1110    omFreeBin((ADDRESS)ISet,  indlist_bin);
1111  }
[7fccc79]1112  hKill(radmem, rVar(currRing) - 1);
1113  omFreeSize((ADDRESS)hpure, (1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1114  omFreeSize((ADDRESS)hvar, (rVar(currRing) + 1) * sizeof(int));
[938688]1115  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1116  hDelete(hexist, hNexist);
1117  return res;
1118}
1119
[0a3ddd]1120int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
[0e1846]1121{
1122  BOOLEAN res=FALSE;
[85e68dd]1123  const char *id = name->name;
[0c6135]1124
[0e1846]1125  memset(sy,0,sizeof(sleftv));
1126  if ((name->name==NULL)||(isdigit(name->name[0])))
1127  {
[da97958]1128    WerrorS("object to declare is not a name");
[0e1846]1129    res=TRUE;
1130  }
1131  else
1132  {
[4b5c87]1133    //if (name->rtyp!=0)
1134    //{
1135    //  Warn("`%s` is already in use",name->name);
1136    //}
[0a3ddd]1137    {
1138      sy->data = (char *)enterid(id,lev,t,root,init_b);
1139    }
[0e1846]1140    if (sy->data!=NULL)
1141    {
1142      sy->rtyp=IDHDL;
1143      currid=sy->name=IDID((idhdl)sy->data);
[3b1a83c]1144      // name->name=NULL; /* used in enterid */
[0e1846]1145      //sy->e = NULL;
1146      if (name->next!=NULL)
1147      {
[c232af]1148        sy->next=(leftv)omAllocBin(sleftv_bin);
[0a3ddd]1149        res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
[0e1846]1150      }
1151    }
1152    else res=TRUE;
1153  }
1154  name->CleanUp();
1155  return res;
1156}
1157
[f71681]1158BOOLEAN iiDefaultParameter(leftv p)
1159{
1160  attr at=NULL;
1161  if (iiCurrProc!=NULL)
1162     at=iiCurrProc->attribute->get("default_arg");
1163  if (at==NULL)
1164    return FALSE;
1165  sleftv tmp;
1166  memset(&tmp,0,sizeof(sleftv));
1167  tmp.rtyp=at->atyp;
1168  tmp.data=at->CopyA();
1169  return iiAssign(p,&tmp);
1170}
[0e1846]1171BOOLEAN iiParameter(leftv p)
1172{
1173  if (iiCurrArgs==NULL)
1174  {
[f71681]1175    if (strcmp(p->name,"#")==0)
1176      return iiDefaultParameter(p);
[0e1846]1177    Werror("not enough arguments for proc %s",VoiceName());
1178    p->CleanUp();
1179    return TRUE;
1180  }
1181  leftv h=iiCurrArgs;
1182  if (strcmp(p->name,"#")==0)
1183  {
1184    iiCurrArgs=NULL;
1185  }
1186  else
1187  {
1188    iiCurrArgs=h->next;
1189    h->next=NULL;
1190  }
1191  BOOLEAN res=iiAssign(p,h);
[1059a1]1192  h->CleanUp();
[c232af]1193  omFreeBin((ADDRESS)h, sleftv_bin);
[0e1846]1194  return res;
1195}
[ea947e]1196BOOLEAN iiAlias(leftv p)
1197{
1198  if (iiCurrArgs==NULL)
1199  {
1200    Werror("not enough arguments for proc %s",VoiceName());
1201    p->CleanUp();
1202    return TRUE;
1203  }
1204  leftv h=iiCurrArgs;
1205  iiCurrArgs=h->next;
1206  h->next=NULL;
1207  if (h->rtyp!=IDHDL)
1208  {
[c2d3bb]1209    BOOLEAN res=iiAssign(p,h);
1210    h->CleanUp();
1211    omFreeBin((ADDRESS)h, sleftv_bin);
1212    return res;
[ea947e]1213  }
1214  if (h->Typ()!=p->Typ())
1215  {
1216    WerrorS("type mismatch");
1217    return TRUE;
1218  }
1219  idhdl pp=(idhdl)p->data;
1220  switch(pp->typ)
1221  {
1222      case INT_CMD:
1223        break;
1224      case INTVEC_CMD:
1225      case INTMAT_CMD:
1226         delete IDINTVEC(pp);
1227         break;
1228      case NUMBER_CMD:
1229         nDelete(&IDNUMBER(pp));
1230         break;
1231      case BIGINT_CMD:
[6cc7f5]1232         n_Delete(&IDNUMBER(pp),currRing->cf);
[ea947e]1233         break;
1234      case MAP_CMD:
1235         {
1236           map im = IDMAP(pp);
1237           omFree((ADDRESS)im->preimage);
1238         }
1239         // continue as ideal:
1240      case IDEAL_CMD:
1241      case MODUL_CMD:
1242      case MATRIX_CMD:
1243          idDelete(&IDIDEAL(pp));
1244         break;
1245      case PROC_CMD:
1246      case RESOLUTION_CMD:
1247      case STRING_CMD:
1248         omFree((ADDRESS)IDSTRING(pp));
1249         break;
1250      case LIST_CMD:
1251         IDLIST(pp)->Clean();
1252         break;
1253      case LINK_CMD:
1254         omFreeBin(IDLINK(pp),sip_link_bin);
1255         break;
1256       // case ring: cannot happen
1257       default:
1258         Werror("unknown type %d",p->Typ());
1259         return TRUE;
1260  }
1261  pp->typ=ALIAS_CMD;
1262  IDDATA(pp)=(char*)h->data;
1263  h->CleanUp();
1264  omFreeBin((ADDRESS)h, sleftv_bin);
1265  return FALSE;
1266}
[0e1846]1267
[0a3ddd]1268static BOOLEAN iiInternalExport (leftv v, int toLev)
[0e1846]1269{
[0a3ddd]1270  idhdl h=(idhdl)v->data;
1271  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
[b565d4]1272  if (IDLEV(h)==0)
1273  {
1274    if (!BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(h));
1275  }
[0a3ddd]1276  else
[0e1846]1277  {
[0a3ddd]1278    h=IDROOT->get(v->name,toLev);
1279    idhdl *root=&IDROOT;
1280    if ((h==NULL)&&(currRing!=NULL))
[0e1846]1281    {
[0a3ddd]1282      h=currRing->idroot->get(v->name,toLev);
1283      root=&currRing->idroot;
[0e1846]1284    }
[1aa559b]1285    BOOLEAN keepring=FALSE;
[0a3ddd]1286    if ((h!=NULL)&&(IDLEV(h)==toLev))
[0e1846]1287    {
[0a3ddd]1288      if (IDTYP(h)==v->Typ())
[0e1846]1289      {
[1aa559b]1290        if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1291        && (v->Data()==IDDATA(h)))
1292        {
1293          IDRING(h)->ref++;
1294          keepring=TRUE;
1295          IDLEV(h)=toLev;
1296          //WarnS("keepring");
1297          return FALSE;
1298        }
[ef9012]1299        if (BVERBOSE(V_REDEFINE))
1300        {
[bb354a]1301          Warn("redefining %s",IDID(h));
[ef9012]1302        }
[77ff8e]1303#ifdef USE_IILOCALRING
[1aa559b]1304        if (iiLocalRing[0]==IDRING(h) && (!keepring)) iiLocalRing[0]=NULL;
[77ff8e]1305#else
[573da6]1306        proclevel *p=procstack;
1307        while (p->next!=NULL) p=p->next;
[1aa559b]1308        if ((p->cRing==IDRING(h)) && (!keepring))
[573da6]1309        {
1310          p->cRing=NULL;
1311          p->cRingHdl=NULL;
1312        }
[3b1a83c]1313#endif
[16acb0]1314        killhdl2(h,root,currRing);
[0a3ddd]1315      }
1316      else
1317      {
1318        return TRUE;
1319      }
1320    }
1321    h=(idhdl)v->data;
1322    IDLEV(h)=toLev;
[1aa559b]1323    if (keepring) IDRING(h)->ref--;
[0a3ddd]1324    iiNoKeepRing=FALSE;
[6f3743]1325    //Print("export %s\n",IDID(h));
[0a3ddd]1326  }
1327  return FALSE;
1328}
1329
[bd4cb92]1330BOOLEAN iiInternalExport (leftv v, int toLev, idhdl roothdl)
1331{
1332  idhdl h=(idhdl)v->data;
1333  if(h==NULL)
1334  {
1335    Warn("'%s': no such identifier\n", v->name);
1336    return FALSE;
1337  }
[7035b2]1338  package frompack=v->req_packhdl;
[75d7c7]1339  if (frompack==NULL) frompack=currPack;
[bd4cb92]1340  package rootpack = IDPACKAGE(roothdl);
[573da6]1341//  Print("iiInternalExport('%s',%d,%s->%s) typ:%d\n", v->name, toLev, IDID(currPackHdl),IDID(roothdl),v->Typ());
[f913a2]1342  if ((RingDependend(IDTYP(h)))
1343  || ((IDTYP(h)==LIST_CMD)
1344     && (lRingDependend(IDLIST(h)))
1345     )
1346  )
[bd4cb92]1347  {
1348    //Print("// ==> Ringdependent set nesting to 0\n");
[6f3743]1349    return (iiInternalExport(v, toLev));
[bd4cb92]1350  }
1351  else
1352  {
[573da6]1353    IDLEV(h)=toLev;
1354    v->req_packhdl=rootpack;
[75d7c7]1355    if (h==frompack->idroot)
[bd4cb92]1356    {
[75d7c7]1357      frompack->idroot=h->next;
[bd4cb92]1358    }
1359    else
1360    {
[75d7c7]1361      idhdl hh=frompack->idroot;
[6f3743]1362      while ((hh!=NULL) && (hh->next!=h))
[bd4cb92]1363        hh=hh->next;
[6f3743]1364      if ((hh!=NULL) && (hh->next==h))
[bd4cb92]1365        hh->next=h->next;
1366      else
1367      {
[75d7c7]1368        Werror("`%s` not found",v->Name());
[bd4cb92]1369        return TRUE;
[954cf2]1370      }
[bd4cb92]1371    }
1372    h->next=rootpack->idroot;
1373    rootpack->idroot=h;
1374  }
1375  return FALSE;
1376}
[0a3ddd]1377
1378BOOLEAN iiExport (leftv v, int toLev)
1379{
[5c5638]1380#ifndef NDEBUG
[a3bc95e]1381  checkall();
[3b1a83c]1382#endif
[0a3ddd]1383  BOOLEAN nok=FALSE;
1384  leftv r=v;
1385  while (v!=NULL)
1386  {
1387    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
1388    {
1389      WerrorS("cannot export");
1390      nok=TRUE;
1391    }
1392    else
1393    {
[f2dff02]1394      if(iiInternalExport(v, toLev))
1395      {
[0a3ddd]1396        r->CleanUp();
1397        return TRUE;
[0e1846]1398      }
1399    }
1400    v=v->next;
1401  }
1402  r->CleanUp();
[5c5638]1403#ifndef NDEBUG
[a3bc95e]1404  checkall();
[3b1a83c]1405#endif
[0e1846]1406  return nok;
1407}
1408
1409/*assume root!=idroot*/
[bd4cb92]1410BOOLEAN iiExport (leftv v, int toLev, idhdl root)
1411{
[5c5638]1412#ifndef NDEBUG
[a3bc95e]1413  checkall();
[5c5638]1414#endif
[f913a2]1415  //  Print("iiExport1: pack=%s\n",IDID(root));
[922a71f]1416  package pack=IDPACKAGE(root);
[bd4cb92]1417  BOOLEAN nok=FALSE;
1418  leftv rv=v;
1419  while (v!=NULL)
1420  {
1421    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1422    )
1423    {
1424      WerrorS("cannot export");
1425      nok=TRUE;
1426    }
1427    else
1428    {
[24a57d]1429      idhdl old=pack->idroot->get( v->name,toLev);
[bd4cb92]1430      if (old!=NULL)
1431      {
[922a71f]1432        if ((pack==currPack) && (old==(idhdl)v->data))
1433        {
[b565d4]1434          if (!BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(old));
[922a71f]1435          break;
1436        }
1437        else if (IDTYP(old)==v->Typ())
[bd4cb92]1438        {
1439          if (BVERBOSE(V_REDEFINE))
1440          {
1441            Warn("redefining %s",IDID(old));
1442          }
[283160]1443          v->name=omStrDup(v->name);
[24a57d]1444          killhdl2(old,&(pack->idroot),currRing);
[bd4cb92]1445        }
1446        else
1447        {
1448          rv->CleanUp();
1449          return TRUE;
1450        }
1451      }
[75d7c7]1452      //Print("iiExport: pack=%s\n",IDID(root));
[bd4cb92]1453      if(iiInternalExport(v, toLev, root))
1454      {
1455        rv->CleanUp();
1456        return TRUE;
1457      }
1458    }
1459    v=v->next;
1460  }
1461  rv->CleanUp();
[5c5638]1462#ifndef NDEBUG
[a3bc95e]1463  checkall();
[5c5638]1464#endif
[bd4cb92]1465  return nok;
1466}
[0e1846]1467
1468BOOLEAN iiCheckRing(int i)
1469{
[7d58b6]1470  if (currRing==NULL)
[0e1846]1471  {
1472    #ifdef SIQ
1473    if (siq<=0)
1474    {
1475    #endif
[df5fc1]1476      if (RingDependend(i))
[0e1846]1477      {
[da97958]1478        WerrorS("no ring active");
[0e1846]1479        return TRUE;
1480      }
1481    #ifdef SIQ
1482    }
1483    #endif
1484  }
1485  return FALSE;
1486}
[f99917f]1487
1488poly    iiHighCorner(ideal I, int ak)
1489{
[d609e1]1490  int i;
1491  if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1492  poly po=NULL;
[753f9d2]1493  if (rHasLocalOrMixedOrdering_currRing())
[f99917f]1494  {
[e08ae6]1495    scComputeHC(I,currQuotient,ak,po);
[f99917f]1496    if (po!=NULL)
1497    {
1498      pGetCoeff(po)=nInit(1);
[7fccc79]1499      for (i=rVar(currRing); i>0; i--)
[f99917f]1500      {
1501        if (pGetExp(po, i) > 0) pDecrExp(po,i);
1502      }
[4e3468]1503      pSetComp(po,ak);
1504      pSetm(po);
[f99917f]1505    }
1506  }
[4e3468]1507  else
1508    po=pOne();
[f99917f]1509  return po;
1510}
[d66a7d]1511
1512void iiCheckPack(package &p)
1513{
1514  if (p==basePack) return;
1515
1516  idhdl t=basePack->idroot;
1517
[bb483c]1518  while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
[d66a7d]1519
1520  if (t==NULL)
1521  {
1522    WarnS("package not found\n");
1523    p=basePack;
1524  }
1525  return;
1526}
[938688]1527
[85e68dd]1528idhdl rDefault(const char *s)
[938688]1529{
1530  idhdl tmp=NULL;
1531
1532  if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
1533  if (tmp==NULL) return NULL;
1534
[07f3b73]1535// if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
[938688]1536  if (sLastPrinted.RingDependend())
1537  {
1538    sLastPrinted.CleanUp();
1539    memset(&sLastPrinted,0,sizeof(sleftv));
1540  }
1541
1542  ring r = IDRING(tmp);
1543
[07f3b73]1544  r->cf = nInitChar(n_Zp, (void*)32003); //   r->cf->ch = 32003;
[6cc7f5]1545  r->N      = 3;
[938688]1546  /*r->P     = 0; Alloc0 in idhdl::set, ipid.cc*/
1547  /*names*/
1548  r->names = (char **) omAlloc0(3 * sizeof(char_ptr));
1549  r->names[0]  = omStrDup("x");
1550  r->names[1]  = omStrDup("y");
1551  r->names[2]  = omStrDup("z");
1552  /*weights: entries for 3 blocks: NULL*/
1553  r->wvhdl = (int **)omAlloc0(3 * sizeof(int_ptr));
1554  /*order: dp,C,0*/
1555  r->order = (int *) omAlloc(3 * sizeof(int *));
1556  r->block0 = (int *)omAlloc0(3 * sizeof(int *));
1557  r->block1 = (int *)omAlloc0(3 * sizeof(int *));
1558  /* ringorder dp for the first block: var 1..3 */
1559  r->order[0]  = ringorder_dp;
1560  r->block0[0] = 1;
1561  r->block1[0] = 3;
1562  /* ringorder C for the second block: no vars */
1563  r->order[1]  = ringorder_C;
1564  /* the last block: everything is 0 */
1565  r->order[2]  = 0;
1566  /*polynomial ring*/
1567  r->OrdSgn    = 1;
1568
1569  /* complete ring intializations */
1570  rComplete(r);
1571  rSetHdl(tmp);
1572  return currRingHdl;
1573}
1574
[69672d]1575idhdl rFindHdl(ring r, idhdl n, idhdl)
[938688]1576{
1577  idhdl h=rSimpleFindHdl(r,IDROOT,n);
1578  if (h!=NULL)  return h;
1579  if (IDROOT!=basePack->idroot) h=rSimpleFindHdl(r,basePack->idroot,n);
1580  if (h!=NULL)  return h;
1581  proclevel *p=procstack;
1582  while(p!=NULL)
1583  {
1584    if ((p->cPack!=basePack)
1585    && (p->cPack!=currPack))
1586      h=rSimpleFindHdl(r,p->cPack->idroot,n);
1587    if (h!=NULL)  return h;
1588    p=p->next;
1589  }
1590  idhdl tmp=basePack->idroot;
1591  while (tmp!=NULL)
1592  {
1593    if (IDTYP(tmp)==PACKAGE_CMD)
1594      h=rSimpleFindHdl(r,IDPACKAGE(tmp)->idroot,n);
1595    if (h!=NULL)  return h;
1596    tmp=IDNEXT(tmp);
1597  }
1598  return NULL;
1599}
1600
[c82e549]1601void rDecomposeCF(leftv h,const ring r,const ring R)
[938688]1602{
[c82e549]1603  lists L=(lists)omAlloc0Bin(slists_bin);
1604  L->Init(4);
1605  h->rtyp=LIST_CMD;
1606  h->data=(void *)L;
[938688]1607  // 0: char/ cf - ring
1608  // 1: list (var)
1609  // 2: list (ord)
1610  // 3: qideal
[c82e549]1611  // ----------------------------------------
1612  // 0: char/ cf - ring
1613  L->m[0].rtyp=INT_CMD;
[6cc7f5]1614  L->m[0].data=(void *)r->cf->ch;
[c82e549]1615  // ----------------------------------------
1616  // 1: list (var)
1617  lists LL=(lists)omAlloc0Bin(slists_bin);
1618  LL->Init(r->N);
1619  int i;
1620  for(i=0; i<r->N; i++)
1621  {
1622    LL->m[i].rtyp=STRING_CMD;
1623    LL->m[i].data=(void *)omStrDup(r->names[i]);
1624  }
1625  L->m[1].rtyp=LIST_CMD;
1626  L->m[1].data=(void *)LL;
1627  // ----------------------------------------
1628  // 2: list (ord)
1629  LL=(lists)omAlloc0Bin(slists_bin);
1630  i=rBlocks(r)-1;
1631  LL->Init(i);
1632  i--;
1633  lists LLL;
1634  for(; i>=0; i--)
1635  {
1636    intvec *iv;
1637    int j;
1638    LL->m[i].rtyp=LIST_CMD;
1639    LLL=(lists)omAlloc0Bin(slists_bin);
1640    LLL->Init(2);
1641    LLL->m[0].rtyp=STRING_CMD;
1642    LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1643    if (r->block1[i]-r->block0[i] >=0 )
1644    {
1645      j=r->block1[i]-r->block0[i];
[7035b2]1646      if(r->order[i]==ringorder_M) j=(j+1)*(j+1)-1;
[c82e549]1647      iv=new intvec(j+1);
1648      if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1649      {
1650        for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1651      }
1652      else switch (r->order[i])
1653      {
1654        case ringorder_dp:
1655        case ringorder_Dp:
1656        case ringorder_ds:
1657        case ringorder_Ds:
1658        case ringorder_lp:
1659          for(;j>=0; j--) (*iv)[j]=1;
1660          break;
1661        default: /* do nothing */;
1662      }
1663    }
1664    else
1665    {
1666      iv=new intvec(1);
1667    }
1668    LLL->m[1].rtyp=INTVEC_CMD;
1669    LLL->m[1].data=(void *)iv;
1670    LL->m[i].data=(void *)LLL;
1671  }
1672  L->m[2].rtyp=LIST_CMD;
1673  L->m[2].data=(void *)LL;
1674  // ----------------------------------------
1675  // 3: qideal
1676  L->m[3].rtyp=IDEAL_CMD;
[3c0498]1677  if (nCoeff_is_transExt(R->cf))
[c82e549]1678    L->m[3].data=(void *)idInit(1,1);
1679  else
1680  {
[dd668f]1681    ideal q=idInit(IDELEMS(r->qideal));
[3c0498]1682    q->m[0]=p_Init(R);
[dd668f]1683    pSetCoeff0(q->m[0],(number)(r->qideal->m[0]));
[3c0498]1684    L->m[3].data=(void *)q;
[f5bef2]1685//    I->m[0] = pNSet(R->minpoly);
[c82e549]1686  }
1687  // ----------------------------------------
1688}
1689void rDecomposeC(leftv h,const ring R)
[4b6ab7]1690/* field is R or C */
[c82e549]1691{
[938688]1692  lists L=(lists)omAlloc0Bin(slists_bin);
[4b6ab7]1693  if (rField_is_long_C(R)) L->Init(3);
1694  else                     L->Init(2);
[c82e549]1695  h->rtyp=LIST_CMD;
1696  h->data=(void *)L;
1697  // 0: char/ cf - ring
1698  // 1: list (var)
1699  // 2: list (ord)
[938688]1700  // ----------------------------------------
1701  // 0: char/ cf - ring
[c82e549]1702  L->m[0].rtyp=INT_CMD;
[4b6ab7]1703  L->m[0].data=(void *)0;
[c82e549]1704  // ----------------------------------------
[7035b2]1705  // 1:
[c82e549]1706  lists LL=(lists)omAlloc0Bin(slists_bin);
[4b6ab7]1707  LL->Init(2);
1708    LL->m[0].rtyp=INT_CMD;
[a06b98]1709    LL->m[0].data=(void *)si_max(R->cf->float_len,SHORT_REAL_LENGTH/2);
[4b6ab7]1710    LL->m[1].rtyp=INT_CMD;
[a06b98]1711    LL->m[1].data=(void *)si_max(R->cf->float_len2,SHORT_REAL_LENGTH);
[c82e549]1712  L->m[1].rtyp=LIST_CMD;
1713  L->m[1].data=(void *)LL;
1714  // ----------------------------------------
[4b6ab7]1715  // 2: list (par)
1716  if (rField_is_long_C(R))
[c82e549]1717  {
[4b6ab7]1718    L->m[2].rtyp=STRING_CMD;
[47ab5b]1719    L->m[2].data=(void *)omStrDup(*rParameter(R));
[c82e549]1720  }
1721  // ----------------------------------------
1722}
1723
[c81a40]1724#ifdef HAVE_RINGS
1725void rDecomposeRing(leftv h,const ring R)
1726/* field is R or C */
1727{
1728  lists L=(lists)omAlloc0Bin(slists_bin);
1729  if (rField_is_Ring_Z(R)) L->Init(1);
[20704f]1730  else                     L->Init(2);
[c81a40]1731  h->rtyp=LIST_CMD;
1732  h->data=(void *)L;
1733  // 0: char/ cf - ring
1734  // 1: list (module)
1735  // ----------------------------------------
1736  // 0: char/ cf - ring
1737  L->m[0].rtyp=STRING_CMD;
1738  L->m[0].data=(void *)omStrDup("integer");
1739  // ----------------------------------------
1740  // 1: module
1741  if (rField_is_Ring_Z(R)) return;
1742  lists LL=(lists)omAlloc0Bin(slists_bin);
1743  LL->Init(2);
1744  LL->m[0].rtyp=BIGINT_CMD;
[6cc7f5]1745  LL->m[0].data=nlMapGMP((number) R->cf->modBase, R->cf, R->cf);
[c81a40]1746  LL->m[1].rtyp=INT_CMD;
[6cc7f5]1747  LL->m[1].data=(void *) R->cf->modExponent;
[c81a40]1748  L->m[1].rtyp=LIST_CMD;
1749  L->m[1].data=(void *)LL;
1750}
1751#endif
1752
1753
[cb5cac]1754lists rDecompose(const ring r)
[c82e549]1755{
[faf350]1756  assume( r != NULL );
1757  const coeffs C = r->cf;
1758  assume( C != NULL );
[06c0b3]1759
[6815af]1760  // sanity check: require currRing==r for rings with polynomial data
[06c0b3]1761  if ( (r!=currRing) && (
1762           (nCoeff_is_algExt(C) && (C != currRing->cf))
1763        || (r->qideal != NULL)
[6815af]1764#ifdef HAVE_PLURAL
[faf350]1765        || (rIsPluralRing(r))
[6815af]1766#endif
[faf350]1767                        )
1768     )
[cb5cac]1769  {
[6815af]1770    WerrorS("ring with polynomial data must be the base ring or compatible");
[cb5cac]1771    return NULL;
1772  }
[c82e549]1773  // 0: char/ cf - ring
1774  // 1: list (var)
1775  // 2: list (ord)
1776  // 3: qideal
1777  // possibly:
1778  // 4: C
1779  // 5: D
1780  lists L=(lists)omAlloc0Bin(slists_bin);
1781  if (rIsPluralRing(r))
1782    L->Init(6);
1783  else
1784    L->Init(4);
1785  // ----------------------------------------
1786  // 0: char/ cf - ring
[4b6ab7]1787  if (rField_is_numeric(r))
[c82e549]1788  {
[4b6ab7]1789    rDecomposeC(&(L->m[0]),r);
1790  }
[c81a40]1791#ifdef HAVE_RINGS
1792  else if (rField_is_Ring(r))
1793  {
1794    rDecomposeRing(&(L->m[0]),r);
1795  }
1796#endif
[4b6ab7]1797  else if (rIsExtension(r))
1798  {
[5d18675]1799    if ( rField_is_Extension(r) )// nCoeff_is_algExt(r->cf))
1800    {
[fe9ee1]1801      assume( r->cf != NULL );
[5d18675]1802      assume( r->cf->extRing != NULL );
[fe9ee1]1803
[5d18675]1804      rDecomposeCF(&(L->m[0]), r->cf->extRing, r);
[47ab5b]1805    }
1806    else
[5eef8d]1807    {
[5d18675]1808      assume( nCoeff_is_GF(r->cf) );
[fe9ee1]1809
[9502424]1810      lists Lc=(lists)omAlloc0Bin(slists_bin);
[5eef8d]1811      Lc->Init(4);
1812      // char:
1813      Lc->m[0].rtyp=INT_CMD;
[5d5d79]1814      Lc->m[0].data=(void*)r->cf->m_nfCharQ;
[fe9ee1]1815      // var:
[5eef8d]1816      lists Lv=(lists)omAlloc0Bin(slists_bin);
1817      Lv->Init(1);
1818      Lv->m[0].rtyp=STRING_CMD;
[fe9ee1]1819      Lv->m[0].data=(void *)omStrDup(*rParameter(r));
[5eef8d]1820      Lc->m[1].rtyp=LIST_CMD;
1821      Lc->m[1].data=(void*)Lv;
1822      // ord:
1823      lists Lo=(lists)omAlloc0Bin(slists_bin);
1824      Lo->Init(1);
1825      lists Loo=(lists)omAlloc0Bin(slists_bin);
1826      Loo->Init(2);
1827      Loo->m[0].rtyp=STRING_CMD;
1828      Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
[fe9ee1]1829
[5eef8d]1830      intvec *iv=new intvec(1); (*iv)[0]=1;
1831      Loo->m[1].rtyp=INTVEC_CMD;
1832      Loo->m[1].data=(void *)iv;
[fe9ee1]1833
[5eef8d]1834      Lo->m[0].rtyp=LIST_CMD;
1835      Lo->m[0].data=(void*)Loo;
1836
1837      Lc->m[2].rtyp=LIST_CMD;
1838      Lc->m[2].data=(void*)Lo;
1839      // q-ideal:
1840      Lc->m[3].rtyp=IDEAL_CMD;
1841      Lc->m[3].data=(void *)idInit(1,1);
1842      // ----------------------
1843      L->m[0].rtyp=LIST_CMD;
1844      L->m[0].data=(void*)Lc;
1845    }
[cb5cac]1846    if (L->m[0].rtyp==0)
1847    {
[6e3cab]1848      //omFreeBin(slists_bin,(void *)L);
[cb5cac]1849      return NULL;
1850    }
[c82e549]1851  }
[938688]1852  else
1853  {
1854    L->m[0].rtyp=INT_CMD;
[6cc7f5]1855    L->m[0].data=(void *)r->cf->ch;
[938688]1856  }
1857  // ----------------------------------------
1858  // 1: list (var)
1859  lists LL=(lists)omAlloc0Bin(slists_bin);
1860  LL->Init(r->N);
1861  int i;
1862  for(i=0; i<r->N; i++)
1863  {
1864    LL->m[i].rtyp=STRING_CMD;
1865    LL->m[i].data=(void *)omStrDup(r->names[i]);
1866  }
1867  L->m[1].rtyp=LIST_CMD;
1868  L->m[1].data=(void *)LL;
1869  // ----------------------------------------
1870  // 2: list (ord)
1871  LL=(lists)omAlloc0Bin(slists_bin);
1872  i=rBlocks(r)-1;
1873  LL->Init(i);
1874  i--;
1875  lists LLL;
1876  for(; i>=0; i--)
1877  {
1878    intvec *iv;
1879    int j;
1880    LL->m[i].rtyp=LIST_CMD;
1881    LLL=(lists)omAlloc0Bin(slists_bin);
1882    LLL->Init(2);
1883    LLL->m[0].rtyp=STRING_CMD;
1884    LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
[273fed]1885
1886    if(r->order[i] == ringorder_IS) //  || r->order[i] == ringorder_s || r->order[i] == ringorder_S)
1887    {
1888      assume( r->block0[i] == r->block1[i] );
1889      const int s = r->block0[i];
1890      assume( -2 < s && s < 2);
1891
1892      iv=new intvec(1);
1893      (*iv)[0] = s;
[f93c5e9]1894    }
1895    else if (r->block1[i]-r->block0[i] >=0 )
[938688]1896    {
[f93c5e9]1897      int bl=j=r->block1[i]-r->block0[i];
1898      if (r->order[i]==ringorder_M)
1899      {
1900        j=(j+1)*(j+1)-1;
1901        bl=j+1;
1902      }
1903      else if (r->order[i]==ringorder_am)
1904      {
1905        j+=r->wvhdl[i][bl+1];
1906      }
[938688]1907      iv=new intvec(j+1);
1908      if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1909      {
[f93c5e9]1910        for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
[938688]1911      }
1912      else switch (r->order[i])
1913      {
1914        case ringorder_dp:
1915        case ringorder_Dp:
1916        case ringorder_ds:
1917        case ringorder_Ds:
1918        case ringorder_lp:
1919          for(;j>=0; j--) (*iv)[j]=1;
1920          break;
1921        default: /* do nothing */;
1922      }
1923    }
1924    else
1925    {
1926      iv=new intvec(1);
1927    }
1928    LLL->m[1].rtyp=INTVEC_CMD;
1929    LLL->m[1].data=(void *)iv;
1930    LL->m[i].data=(void *)LLL;
1931  }
1932  L->m[2].rtyp=LIST_CMD;
1933  L->m[2].data=(void *)LL;
1934  // ----------------------------------------
1935  // 3: qideal
1936  L->m[3].rtyp=IDEAL_CMD;
1937  if (r->qideal==NULL)
1938    L->m[3].data=(void *)idInit(1,1);
1939  else
1940    L->m[3].data=(void *)idCopy(r->qideal);
1941  // ----------------------------------------
[47ab5b]1942#ifdef HAVE_PLURAL // NC! in rDecompose
[7cbe8e]1943  if (rIsPluralRing(r))
[c82e549]1944  {
1945    L->m[4].rtyp=MATRIX_CMD;
[6cc7f5]1946    L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
[c82e549]1947    L->m[5].rtyp=MATRIX_CMD;
[6cc7f5]1948    L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
[c82e549]1949  }
[47ab5b]1950#endif
[938688]1951  return L;
1952}
1953
[4b6ab7]1954void rComposeC(lists L, ring R)
1955/* field is R or C */
1956{
1957  // ----------------------------------------
1958  // 0: char/ cf - ring
1959  if ((L->m[0].rtyp!=INT_CMD) || (L->m[0].data!=(char *)0))
[a0e57c]1960  {
[4b6ab7]1961    Werror("invald coeff. field description, expecting 0");
1962    return;
[a0e57c]1963  }
[47ab5b]1964//  R->cf->ch=0;
[4b6ab7]1965  // ----------------------------------------
[7035b2]1966  // 1:
1967  if (L->m[1].rtyp!=LIST_CMD)
[4b6ab7]1968    Werror("invald coeff. field description, expecting precision list");
1969  lists LL=(lists)L->m[1].data;
[7447d8]1970  int r1=(int)(long)LL->m[0].data;
1971  int r2=(int)(long)LL->m[1].data;
[cffd3e]1972  if (L->nr==2) // complex
1973    R->cf = nInitChar(n_long_C, NULL);
1974  else if ((r1<=SHORT_REAL_LENGTH)
1975  && (r2=SHORT_REAL_LENGTH))
1976    R->cf = nInitChar(n_R, NULL);
1977  else
1978    R->cf = nInitChar(n_long_R, NULL);
1979
1980  if ((r1<=SHORT_REAL_LENGTH)   // should go into nInitChar
[4b6ab7]1981  && (r2=SHORT_REAL_LENGTH))
1982  {
[a06b98]1983    R->cf->float_len=SHORT_REAL_LENGTH/2;
1984    R->cf->float_len2=SHORT_REAL_LENGTH;
[4b6ab7]1985  }
1986  else
1987  {
[a06b98]1988    R->cf->float_len=si_min(r1,32767);
1989    R->cf->float_len2=si_min(r2,32767);
[4b6ab7]1990  }
1991  // ----------------------------------------
1992  // 2: list (par)
1993  if (L->nr==2)
1994  {
[6cc7f5]1995    R->cf->extRing->N=1;
[4b6ab7]1996    if (L->m[2].rtyp!=STRING_CMD)
1997    {
1998      Werror("invald coeff. field description, expecting parameter name");
1999      return;
2000    }
[6cc7f5]2001    R->cf->extRing->names=(char**)omAlloc0(rPar(R)*sizeof(char_ptr));
2002    R->cf->extRing->names[0]=omStrDup((char *)L->m[2].data);
[4b6ab7]2003  }
2004  // ----------------------------------------
2005}
[20704f]2006
2007#ifdef HAVE_RINGS
2008void rComposeRing(lists L, ring R)
2009/* field is R or C */
2010{
2011  // ----------------------------------------
2012  // 0: string: integer
2013  // no further entries --> Z
[6bb9d9]2014  int_number modBase = NULL;
2015  unsigned int modExponent = 1;
2016
2017  modBase = (int_number) omAlloc(sizeof(mpz_t));
[20704f]2018  if (L->nr == 0)
2019  {
[6bb9d9]2020    mpz_init_set_ui(modBase,0);
2021    modExponent = 1;
[20704f]2022  }
2023  // ----------------------------------------
2024  // 1:
[e74fb8]2025  else
[20704f]2026  {
[e74fb8]2027    if (L->m[1].rtyp!=LIST_CMD) Werror("invald data, expecting list of numbers");
[20704f]2028    lists LL=(lists)L->m[1].data;
[350a6d]2029    if ((LL->nr >= 0) && LL->m[0].rtyp == BIGINT_CMD)
[e74fb8]2030    {
[6bb9d9]2031      number tmp= (number) LL->m[0].data;
2032      n_MPZ (modBase, tmp, coeffs_BIGINT);
[e74fb8]2033    }
[6bb9d9]2034    else if (LL->nr >= 0 && LL->m[0].rtyp == INT_CMD)
[e74fb8]2035    {
[6bb9d9]2036      mpz_init_set_ui(modBase,(unsigned long) LL->m[0].data);
[e74fb8]2037    }
2038    else
2039    {
[6bb9d9]2040      mpz_init_set_ui(modBase,0);
[e74fb8]2041    }
2042    if (LL->nr >= 1)
2043    {
[6bb9d9]2044      modExponent = (unsigned long) LL->m[1].data;
[e74fb8]2045    }
2046    else
2047    {
[6bb9d9]2048      modExponent = 1;
[e74fb8]2049    }
[20704f]2050  }
2051  // ----------------------------------------
[6bb9d9]2052  if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_cmp_ui(modBase, 0) < 0))
[20704f]2053  {
2054    Werror("Wrong ground ring specification (module is 1)");
2055    return;
2056  }
[6bb9d9]2057  if (modExponent < 1)
[20704f]2058  {
2059    Werror("Wrong ground ring specification (exponent smaller than 1");
2060    return;
2061  }
2062  // module is 0 ---> integers
[6bb9d9]2063  if (mpz_cmp_ui(modBase, 0) == 0)
[20704f]2064  {
[6bb9d9]2065    R->cf=nInitChar(n_Z,NULL);
[20704f]2066  }
2067  // we have an exponent
[6bb9d9]2068  else if (modExponent > 1)
[20704f]2069  {
[6bb9d9]2070    //R->cf->ch = R->cf->modExponent;
2071    if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(NATNUMBER)))
[7cbe8e]2072    {
[6cc7f5]2073      /* this branch should be active for modExponent = 2..32 resp. 2..64,
[cf21dd4]2074           depending on the size of a long on the respective platform */
[6bb9d9]2075      R->cf=nInitChar(n_Z2m,(void*)(long)modExponent);       // Use Z/2^ch
[dc07cbe]2076      omFreeSize (modBase, sizeof(mpz_t));
[20704f]2077    }
2078    else
2079    {
[6bb9d9]2080      //ringtype 3
2081      ZnmInfo info;
2082      info.base= modBase;
2083      info.exp= modExponent;
2084      R->cf=nInitChar(n_Znm,(void*) &info);
[20704f]2085    }
2086  }
2087  // just a module m > 1
2088  else
2089  {
[6bb9d9]2090    //ringtype = 2;
2091    //const int ch = mpz_get_ui(modBase);
2092    ZnmInfo info;
2093    info.base= modBase;
2094    info.exp= modExponent;
2095    R->cf=nInitChar(n_Zn,(void*) &info);
[20704f]2096  }
2097}
2098#endif
2099
[7c5dd1]2100static void rRenameVars(ring R)
2101{
2102  int i,j;
2103  for(i=0;i<R->N-1;i++)
2104  {
2105    for(j=i+1;j<R->N;j++)
2106    {
2107      if (strcmp(R->names[i],R->names[j])==0)
2108      {
2109        Warn("name conflict var(%d) and var(%d): `%s`, rename to `@(%d)`",i+1,j+1,R->names[i],j+1);
2110        omFree(R->names[j]);
2111        R->names[j]=(char *)omAlloc(10);
2112        sprintf(R->names[j],"@(%d)",j+1);
2113      }
2114    }
2115  }
[6cc7f5]2116  for(i=0;i<rPar(R); i++)
[7c5dd1]2117  {
2118    for(j=0;j<R->N;j++)
2119    {
[6cc7f5]2120      if (strcmp(rParameter(R)[i],R->names[j])==0)
[7c5dd1]2121      {
[7fee876]2122        Warn("name conflict par(%d) and var(%d): `%s`, renaming the VARIABLE to `@@(%d)`",i+1,j+1,R->names[j],i+1);
2123//        omFree(rParameter(R)[i]);
2124//        rParameter(R)[i]=(char *)omAlloc(10);
2125//        sprintf(rParameter(R)[i],"@@(%d)",i+1);
2126        omFree(R->names[j]);
2127        R->names[j]=(char *)omAlloc(10);
2128        sprintf(R->names[j],"@@(%d)",i+1);
[7c5dd1]2129      }
2130    }
2131  }
2132}
2133
[4b7db8]2134ring rCompose(const lists  L, const BOOLEAN check_comp)
[938688]2135{
[c82e549]2136  if ((L->nr!=3)
2137#ifdef HAVE_PLURAL
2138  &&(L->nr!=5)
2139#endif
2140  )
2141    return NULL;
[f16c61c]2142  int is_gf_char=0;
[938688]2143  // 0: char/ cf - ring
2144  // 1: list (var)
2145  // 2: list (ord)
2146  // 3: qideal
[c82e549]2147  // possibly:
2148  // 4: C
2149  // 5: D
[f16c61c]2150
[f92a39]2151  ring R = (ring) omAlloc0Bin(sip_sring_bin);
[f16c61c]2152
2153
[d143376]2154  // ------------------------------------------------------------------
2155  // 0: char:
2156  if (L->m[0].Typ()==INT_CMD)
2157  {
[e7e815]2158    int ch = (int)(long)L->m[0].Data();
[d143376]2159    assume( ch >= 0 );
[e7e815]2160
2161    if (ch == 0) // Q?
2162      R->cf = nInitChar(n_Q, NULL);
2163    else
2164    {
2165      int l = IsPrime(ch); // Zp?
2166      if( l != ch )
[d143376]2167      {
[e7e815]2168        Warn("%d is invalid characteristic of ground field. %d is used.", ch, l);
[d143376]2169        ch = l;
[f16c61c]2170      }
2171      R->cf = nInitChar(n_Zp, (void*)ch);
[d143376]2172    }
2173  }
[e7e815]2174  else if (L->m[0].Typ()==LIST_CMD) // something complicated...
[d143376]2175  {
2176    lists LL=(lists)L->m[0].Data();
[f16c61c]2177
[d143376]2178#ifdef HAVE_RINGS
[e7e815]2179    if (LL->m[0].Typ() == STRING_CMD) // 1st comes a string?
[d143376]2180    {
[e7e815]2181      rComposeRing(LL, R); // Ring!?
[d143376]2182    }
2183    else
2184#endif
[e7e815]2185    if (LL->nr < 3)
2186      rComposeC(LL,R); // R, long_R, long_C
[d143376]2187    else
[f16c61c]2188    {
[d143376]2189      if (LL->m[0].Typ()==INT_CMD)
[f16c61c]2190      {
[f5bef2]2191        int ch = (int)(long)LL->m[0].Data();
[f16c61c]2192        while ((ch!=fftable[is_gf_char]) && (fftable[is_gf_char])) is_gf_char++;
2193        if (fftable[is_gf_char]==0) is_gf_char=-1;
[e7e815]2194
[f16c61c]2195        if(is_gf_char!= -1)
[e7e815]2196        {
2197          GFInfo param;
[f16c61c]2198
2199          param.GFChar = ch;
[e7e815]2200          param.GFDegree = 1;
2201          param.GFPar_name = (const char*)(((lists)(LL->m[1].Data()))->m[0].Data());
2202
2203          // nfInitChar should be able to handle the case when ch is in fftables!
2204          R->cf = nInitChar(n_GF, (void*)&param);
2205        }
[d143376]2206      }
[e7e815]2207
2208      if( R->cf == NULL )
[d143376]2209      {
[4b7db8]2210        ring extRing = rCompose((lists)L->m[0].Data(),FALSE);
[f16c61c]2211
[d143376]2212        if (extRing==NULL)
2213        {
[e7e815]2214          WerrorS("could not create the specified coefficient field");
[d143376]2215          goto rCompose_err;
2216        }
[e7e815]2217
2218        if( extRing->qideal != NULL ) // Algebraic extension
[d143376]2219        {
[e7e815]2220          AlgExtInfo extParam;
[f16c61c]2221
[e7e815]2222          extParam.r = extRing;
2223
[f16c61c]2224          R->cf = nInitChar(n_algExt, (void*)&extParam);
2225        }
2226        else // Transcendental extension
[e7e815]2227        {
2228          TransExtInfo extParam;
[f5bef2]2229          extParam.r = extRing;
[06c0b3]2230          assume( extRing->qideal == NULL );
[e7e815]2231
2232          R->cf = nInitChar(n_transExt, &extParam);
[d143376]2233        }
[f16c61c]2234      }
[d143376]2235    }
2236  }
2237  else
2238  {
2239    WerrorS("coefficient field must be described by `int` or `list`");
2240    goto rCompose_err;
2241  }
[e7e815]2242
2243  if( R->cf == NULL )
[d143376]2244  {
[e7e815]2245    WerrorS("could not create coefficient field described by the input!");
[d143376]2246    goto rCompose_err;
2247  }
[e7e815]2248
[938688]2249  // ------------------------- VARS ---------------------------
2250  if (L->m[1].Typ()==LIST_CMD)
2251  {
2252    lists v=(lists)L->m[1].Data();
2253    R->N = v->nr+1;
2254    R->names   = (char **)omAlloc0(R->N * sizeof(char_ptr));
2255    int i;
2256    for(i=0;i<R->N;i++)
2257    {
2258      if (v->m[i].Typ()==STRING_CMD)
2259        R->names[i]=omStrDup((char *)v->m[i].Data());
2260      else if (v->m[i].Typ()==POLY_CMD)
2261      {
2262        poly p=(poly)v->m[i].Data();
2263        int nr=pIsPurePower(p);
2264        if (nr>0)
2265          R->names[i]=omStrDup(currRing->names[nr-1]);
2266        else
2267        {
2268          Werror("var name %d must be a string or a ring variable",i+1);
2269          goto rCompose_err;
2270        }
2271      }
2272      else
2273      {
2274        Werror("var name %d must be `string`",i+1);
2275        goto rCompose_err;
2276      }
2277    }
2278  }
2279  else
2280  {
2281    WerrorS("variable must be given as `list`");
2282    goto rCompose_err;
2283  }
2284  // ------------------------ ORDER ------------------------------
2285  if (L->m[2].Typ()==LIST_CMD)
2286  {
2287    lists v=(lists)L->m[2].Data();
2288    int n= v->nr+2;
2289    int j;
2290    // initialize fields of R
2291    R->order=(int *)omAlloc0(n*sizeof(int));
2292    R->block0=(int *)omAlloc0(n*sizeof(int));
2293    R->block1=(int *)omAlloc0(n*sizeof(int));
2294    R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
2295    // init order, so that rBlocks works correctly
[cf022c7]2296    for (j=0; j < n-1; j++)
[938688]2297      R->order[j] = (int) ringorder_unspec;
2298    // orderings
2299    R->OrdSgn=1;
2300    for(j=0;j<n-1;j++)
2301    {
2302    // todo: a(..), M
2303      if (v->m[j].Typ()!=LIST_CMD)
2304      {
2305        WerrorS("ordering must be list of lists");
2306        goto rCompose_err;
2307      }
2308      lists vv=(lists)v->m[j].Data();
2309      if ((vv->nr!=1)
2310      || (vv->m[0].Typ()!=STRING_CMD)
2311      || ((vv->m[1].Typ()!=INTVEC_CMD) && (vv->m[1].Typ()!=INT_CMD)))
2312      {
2313        WerrorS("ordering name must be a (string,intvec)");
2314        goto rCompose_err;
2315      }
2316      R->order[j]=rOrderName(omStrDup((char*)vv->m[0].Data())); // assume STRING
[22579cf]2317
[938688]2318      if (j==0) R->block0[0]=1;
[392682]2319      else
[99e6fde]2320      {
2321         int jj=j-1;
[cf022c7]2322         while((jj>=0)
[392682]2323         && ((R->order[jj]== ringorder_a)
[ad408c]2324            || (R->order[jj]== ringorder_aa)
[3a8a0d9]2325            || (R->order[jj]== ringorder_am)
[ad408c]2326            || (R->order[jj]== ringorder_c)
2327            || (R->order[jj]== ringorder_C)
[273fed]2328            || (R->order[jj]== ringorder_s)
2329            || (R->order[jj]== ringorder_S)
[ad408c]2330         ))
[cf022c7]2331         {
2332           //Print("jj=%, skip %s\n",rSimpleOrdStr(R->order[jj]));
[99e6fde]2333           jj--;
[cf022c7]2334         }
2335         if (jj<0) R->block0[j]=1;
[ad408c]2336         else       R->block0[j]=R->block1[jj]+1;
[99e6fde]2337      }
[938688]2338      intvec *iv;
2339      if (vv->m[1].Typ()==INT_CMD)
[7447d8]2340        iv=new intvec((int)(long)vv->m[1].Data(),(int)(long)vv->m[1].Data());
[938688]2341      else
2342        iv=ivCopy((intvec*)vv->m[1].Data()); //assume INTVEC
[091b0e8]2343      int iv_len=iv->length();
2344      R->block1[j]=si_max(R->block0[j],R->block0[j]+iv_len-1);
2345      if (R->block1[j]>R->N)
2346      {
[3373e32]2347        R->block1[j]=R->N;
2348        iv_len=R->block1[j]-R->block0[j]+1;
[091b0e8]2349      }
[99e6fde]2350      //Print("block %d from %d to %d\n",j,R->block0[j], R->block1[j]);
[938688]2351      int i;
2352      switch (R->order[j])
2353      {
2354         case ringorder_ws:
2355         case ringorder_Ws:
2356            R->OrdSgn=-1;
[99e6fde]2357         case ringorder_aa:
2358         case ringorder_a:
[938688]2359         case ringorder_wp:
2360         case ringorder_Wp:
[091b0e8]2361           R->wvhdl[j] =( int *)omAlloc(iv_len*sizeof(int));
2362           for (i=0; i<iv_len;i++)
[c2d114]2363           {
2364             R->wvhdl[j][i]=(*iv)[i];
2365           }
[938688]2366           break;
[ece1ce]2367         case ringorder_am:
2368           R->wvhdl[j] =( int *)omAlloc((iv->length()+1)*sizeof(int));
2369           for (i=0; i<iv_len;i++)
2370           {
2371             R->wvhdl[j][i]=(*iv)[i];
2372           }
2373           R->wvhdl[j][i]=iv->length() - iv_len;
2374           //printf("ivlen:%d,iv->len:%d,mod:%d\n",iv_len,iv->length(),R->wvhdl[j][i]);
2375           for (; i<iv->length(); i++)
2376           {
2377              R->wvhdl[j][i+1]=(*iv)[i];
2378           }
2379           break;
[62fb0b4]2380         case ringorder_M:
2381           R->wvhdl[j] =( int *)omAlloc((iv->length())*sizeof(int));
2382           for (i=0; i<iv->length();i++) R->wvhdl[j][i]=(*iv)[i];
[8c7e81]2383           R->block1[j]=si_max(R->block0[j],R->block0[j]+(int)sqrt((double)(iv->length()-1)));
[091b0e8]2384           if (R->block1[j]>R->N)
[3373e32]2385           {
2386             WerrorS("ordering matrix too big");
2387             goto rCompose_err;
2388           }
[62fb0b4]2389           break;
[938688]2390         case ringorder_ls:
2391         case ringorder_ds:
2392         case ringorder_Ds:
[529aad]2393         case ringorder_rs:
[938688]2394           R->OrdSgn=-1;
2395         case ringorder_lp:
2396         case ringorder_dp:
2397         case ringorder_Dp:
2398         case ringorder_rp:
2399           break;
2400         case ringorder_S:
2401           break;
2402         case ringorder_c:
2403         case ringorder_C:
[c05b46]2404           R->block1[j]=R->block0[j]=0;
[938688]2405           break;
[273fed]2406
2407         case ringorder_s:
2408           break;
2409
2410         case ringorder_IS:
2411         {
2412           R->block1[j] = R->block0[j] = 0;
2413           if( iv->length() > 0 )
2414           {
2415             const int s = (*iv)[0];
2416             assume( -2 < s && s < 2 );
2417             R->block1[j] = R->block0[j] = s;
2418           }
2419           break;
2420         }
[99e6fde]2421         case 0:
[cf022c7]2422         case ringorder_unspec:
[99e6fde]2423           break;
[938688]2424      }
[4be9b80]2425      delete iv;
[938688]2426    }
2427    // sanity check
2428    j=n-2;
2429    if ((R->order[j]==ringorder_c)
[cf022c7]2430    || (R->order[j]==ringorder_C)
2431    || (R->order[j]==ringorder_unspec)) j--;
[938688]2432    if (R->block1[j] != R->N)
2433    {
2434      if (((R->order[j]==ringorder_dp) ||
2435           (R->order[j]==ringorder_ds) ||
2436           (R->order[j]==ringorder_Dp) ||
2437           (R->order[j]==ringorder_Ds) ||
2438           (R->order[j]==ringorder_rp) ||
[529aad]2439           (R->order[j]==ringorder_rs) ||
[938688]2440           (R->order[j]==ringorder_lp) ||
2441           (R->order[j]==ringorder_ls))
2442          &&
2443            R->block0[j] <= R->N)
2444      {
2445        R->block1[j] = R->N;
2446      }
2447      else
2448      {
2449        Werror("ordering incomplete: size (%d) should be %d",R->block1[j],R->N);
2450        goto rCompose_err;
2451      }
2452    }
[4b7db8]2453    if (check_comp)
2454    {
2455      BOOLEAN comp_order=FALSE;
2456      int jj;
2457      for(jj=0;jj<n;jj++)
2458      {
2459        if ((R->order[jj]==ringorder_c) ||
2460            (R->order[jj]==ringorder_C)) { comp_order=TRUE; break; }
2461      }
2462      if (!comp_order)
2463      {
2464        R->order=(int*)omRealloc0Size(R->order,n*sizeof(int),(n+1)*sizeof(int));
2465        R->block0=(int*)omRealloc0Size(R->block0,n*sizeof(int),(n+1)*sizeof(int));
2466        R->block1=(int*)omRealloc0Size(R->block1,n*sizeof(int),(n+1)*sizeof(int));
2467        R->wvhdl=(int**)omRealloc0Size(R->wvhdl,n*sizeof(int_ptr),(n+1)*sizeof(int_ptr));
2468        R->order[n-1]=ringorder_C;
2469        R->block0[n-1]=0;
2470        R->block1[n-1]=0;
2471        R->wvhdl[n-1]=NULL;
2472        n++;
2473      }
2474    }
[938688]2475  }
2476  else
2477  {
2478    WerrorS("ordering must be given as `list`");
2479    goto rCompose_err;
2480  }
[e7e815]2481
2482  // ------------------------ ??????? --------------------
2483
2484  rRenameVars(R);
2485  rComplete(R);
2486
[f16c61c]2487#ifdef HAVE_RINGS
[e7e815]2488// currently, coefficients which are ring elements require a global ordering:
[f5bef2]2489  if (rField_is_Ring(R) && (R->OrdSgn==-1))
[e7e815]2490  {
2491    WerrorS("global ordering required for these coefficients");
2492    goto rCompose_err;
2493  }
2494#endif
2495
2496
[1bf1c0]2497  // ------------------------ Q-IDEAL ------------------------
[e6f922f]2498
[938688]2499  if (L->m[3].Typ()==IDEAL_CMD)
2500  {
2501    ideal q=(ideal)L->m[3].Data();
2502    if (q->m[0]!=NULL)
[392682]2503    {
[42d26c]2504      if (R->cf != currRing->cf) //->cf->ch!=currRing->cf->ch)
[392682]2505      {
[7e1643]2506      #if 0
[0d0763]2507            WerrorS("coefficient fields must be equal if q-ideal !=0");
2508            goto rCompose_err;
2509      #else
2510        ring orig_ring=currRing;
2511        rChangeCurrRing(R);
2512        int *perm=NULL;
2513        int *par_perm=NULL;
2514        int par_perm_size=0;
2515        nMapFunc nMap;
2516
[6cc7f5]2517        if ((nMap=nSetMap(orig_ring->cf))==NULL)
[0d0763]2518        {
2519          if (rEqual(orig_ring,currRing))
2520          {
[6cc7f5]2521            nMap=n_SetMap(currRing->cf, currRing->cf);
[0d0763]2522          }
2523          else
2524          // Allow imap/fetch to be make an exception only for:
2525          if ( (rField_is_Q_a(orig_ring) &&  // Q(a..) -> Q(a..) || Q || Zp || Zp(a)
[6cc7f5]2526            (rField_is_Q(currRing) || rField_is_Q_a(currRing) ||
2527             (rField_is_Zp(currRing) || rField_is_Zp_a(currRing))))
[0d0763]2528           ||
2529           (rField_is_Zp_a(orig_ring) &&  // Zp(a..) -> Zp(a..) || Zp
2530            (rField_is_Zp(currRing, rInternalChar(orig_ring)) ||
2531             rField_is_Zp_a(currRing, rInternalChar(orig_ring)))) )
2532          {
2533            par_perm_size=rPar(orig_ring);
[f16c61c]2534
[dd668f]2535//            if ((orig_ring->minpoly != NULL) || (orig_ring->qideal != NULL))
[f5bef2]2536//              naSetChar(rInternalChar(orig_ring),orig_ring);
2537//            else ntSetChar(rInternalChar(orig_ring),orig_ring);
[f16c61c]2538
[6cc7f5]2539            nSetChar(currRing->cf);
[0d0763]2540          }
2541          else
2542          {
2543            WerrorS("coefficient fields must be equal if q-ideal !=0");
2544            goto rCompose_err;
2545          }
2546        }
[7e1643]2547        perm=(int *)omAlloc0((orig_ring->N+1)*sizeof(int));
2548        if (par_perm_size!=0)
2549          par_perm=(int *)omAlloc0(par_perm_size*sizeof(int));
[27afa1]2550        int i;
[0ea97e]2551        #if 0
2552        // use imap:
[7e1643]2553        maFindPerm(orig_ring->names,orig_ring->N,orig_ring->parameter,orig_ring->P,
2554          currRing->names,currRing->N,currRing->parameter, currRing->P,
2555          perm,par_perm, currRing->ch);
[0ea97e]2556        #else
2557        // use fetch
2558        if ((rPar(orig_ring)>0) && (rPar(currRing)==0))
2559        {
2560          for(i=si_min(rPar(orig_ring),rVar(currRing))-1;i>=0;i--) par_perm[i]=i+1;
2561        }
2562        else if (par_perm_size!=0)
2563          for(i=si_min(rPar(orig_ring),rPar(currRing))-1;i>=0;i--) par_perm[i]=-(i+1);
[7fccc79]2564        for(i=si_min(orig_ring->N,rVar(currRing));i>0;i--) perm[i]=i;
[0ea97e]2565        #endif
[7e1643]2566        ideal dest_id=idInit(IDELEMS(q),1);
2567        for(i=IDELEMS(q)-1; i>=0; i--)
[0d0763]2568        {
[6cc7f5]2569          dest_id->m[i]=p_PermPoly(q->m[i],perm,orig_ring, currRing,nMap,
[7e1643]2570                                  par_perm,par_perm_size);
[0ea97e]2571          //  PrintS("map:");pWrite(dest_id->m[i]);PrintLn();
[fe62d0]2572          pTest(dest_id->m[i]);
[0d0763]2573        }
[7e1643]2574        R->qideal=dest_id;
[0d0763]2575        if (perm!=NULL)
2576          omFreeSize((ADDRESS)perm,(orig_ring->N+1)*sizeof(int));
2577        if (par_perm!=NULL)
2578          omFreeSize((ADDRESS)par_perm,par_perm_size*sizeof(int));
2579        rChangeCurrRing(orig_ring);
2580      #endif
[392682]2581      }
[0d0763]2582      else
2583        R->qideal=idrCopyR(q,currRing,R);
[392682]2584    }
[938688]2585  }
2586  else
2587  {
2588    WerrorS("q-ideal must be given as `ideal`");
2589    goto rCompose_err;
2590  }
2591
[c82e549]2592
2593  // ---------------------------------------------------------------
2594  #ifdef HAVE_PLURAL
2595  if (L->nr==5)
2596  {
[e5a4ba]2597    if (nc_CallPlural((matrix)L->m[4].Data(),
2598                      (matrix)L->m[5].Data(),
2599                      NULL,NULL,
2600                      R,
2601                      true, // !!!
2602                      true, false,
2603                      currRing, FALSE)) goto rCompose_err;
[3f78cb]2604    // takes care about non-comm. quotient! i.e. calls "nc_SetupQuotient" due to last true
[c82e549]2605  }
2606  #endif
[938688]2607  return R;
2608
2609rCompose_err:
2610  if (R->N>0)
2611  {
2612    int i;
2613    if (R->names!=NULL)
2614    {
[a4240cf]2615      i=R->N-1;
[938688]2616      while (i>=0) { if (R->names[i]!=NULL) omFree(R->names[i]); i--; }
2617      omFree(R->names);
2618    }
2619  }
2620  if (R->order!=NULL) omFree(R->order);
2621  if (R->block0!=NULL) omFree(R->block0);
2622  if (R->block1!=NULL) omFree(R->block1);
2623  if (R->wvhdl!=NULL) omFree(R->wvhdl);
2624  omFree(R);
2625  return NULL;
2626}
2627
2628// from matpol.cc
2629
2630/*2
2631* compute the jacobi matrix of an ideal
2632*/
2633BOOLEAN mpJacobi(leftv res,leftv a)
2634{
2635  int     i,j;
2636  matrix result;
2637  ideal id=(ideal)a->Data();
2638
[7fccc79]2639  result =mpNew(IDELEMS(id),rVar(currRing));
[938688]2640  for (i=1; i<=IDELEMS(id); i++)
2641  {
[7fccc79]2642    for (j=1; j<=rVar(currRing); j++)
[938688]2643    {
2644      MATELEM(result,i,j) = pDiff(id->m[i-1],j);
2645    }
2646  }
2647  res->data=(char *)result;
2648  return FALSE;
2649}
2650
2651/*2
2652* returns the Koszul-matrix of degree d of a vectorspace with dimension n
2653* uses the first n entrees of id, if id <> NULL
2654*/
2655BOOLEAN mpKoszul(leftv res,leftv c/*ip*/, leftv b/*in*/, leftv id)
2656{
[7447d8]2657  int n=(int)(long)b->Data();
2658  int d=(int)(long)c->Data();
[938688]2659  int     k,l,sign,row,col;
2660  matrix  result;
2661  ideal temp;
2662  BOOLEAN bo;
2663  poly    p;
2664
2665  if ((d>n) || (d<1) || (n<1))
2666  {
2667    res->data=(char *)mpNew(1,1);
2668    return FALSE;
2669  }
2670  int *choise = (int*)omAlloc(d*sizeof(int));
2671  if (id==NULL)
2672    temp=idMaxIdeal(1);
2673  else
2674    temp=(ideal)id->Data();
2675
2676  k = binom(n,d);
2677  l = k*d;
2678  l /= n-d+1;
2679  result =mpNew(l,k);
2680  col = 1;
2681  idInitChoise(d,1,n,&bo,choise);
2682  while (!bo)
2683  {
2684    sign = 1;
2685    for (l=1;l<=d;l++)
2686    {
2687      if (choise[l-1]<=IDELEMS(temp))
2688      {
2689        p = pCopy(temp->m[choise[l-1]-1]);
2690        if (sign == -1) p = pNeg(p);
2691        sign *= -1;
2692        row = idGetNumberOfChoise(l-1,d,1,n,choise);
2693        MATELEM(result,row,col) = p;
2694      }
2695    }
2696    col++;
2697    idGetNextChoise(d,n,&bo,choise);
2698  }
2699  if (id==NULL) idDelete(&temp);
2700
2701  res->data=(char *)result;
2702  return FALSE;
2703}
2704
2705// from syz1.cc
2706/*2
2707* read out the Betti numbers from resolution
2708* (interpreter interface)
2709*/
2710BOOLEAN syBetti2(leftv res, leftv u, leftv w)
2711{
2712  syStrategy syzstr=(syStrategy)u->Data();
[22579cf]2713
[7447d8]2714  BOOLEAN minim=(int)(long)w->Data();
[938688]2715  int row_shift=0;
[7f14f2]2716  int add_row_shift=0;
2717  intvec *weights=NULL;
2718  intvec *ww=(intvec *)atGet(u,"isHomog",INTVEC_CMD);
2719  if (ww!=NULL)
2720  {
2721     weights=ivCopy(ww);
2722     add_row_shift = ww->min_in();
2723     (*weights) -= add_row_shift;
2724  }
[750e70]2725
[7f14f2]2726  res->data=(void *)syBettiOfComputation(syzstr,minim,&row_shift,weights);
2727  //row_shift += add_row_shift;
2728  //Print("row_shift=%d, add_row_shift=%d\n",row_shift,add_row_shift);
2729  atSet(res,omStrDup("rowShift"),(void*)add_row_shift,INT_CMD);
[22579cf]2730
[938688]2731  return FALSE;
2732}
2733BOOLEAN syBetti1(leftv res, leftv u)
2734{
[7f14f2]2735  sleftv tmp;
2736  memset(&tmp,0,sizeof(tmp));
2737  tmp.rtyp=INT_CMD;
[7035b2]2738  tmp.data=(void *)1;
[7f14f2]2739  return syBetti2(res,u,&tmp);
[938688]2740}
2741
2742/*3
2743* converts a resolution into a list of modules
2744*/
[f43a74]2745lists syConvRes(syStrategy syzstr,BOOLEAN toDel,int add_row_shift)
[938688]2746{
[22579cf]2747  resolvente fullres = syzstr->fullres;
2748  resolvente minres = syzstr->minres;
2749
2750  const int length = syzstr->length;
2751
2752  if ((fullres==NULL) && (minres==NULL))
[938688]2753  {
2754    if (syzstr->hilb_coeffs==NULL)
[750e70]2755    { // La Scala
[22579cf]2756      fullres = syReorder(syzstr->res, length, syzstr);
[938688]2757    }
2758    else
[750e70]2759    { // HRES
[22579cf]2760      minres = syReorder(syzstr->orderedRes, length, syzstr);
2761      syKillEmptyEntres(minres, length);
[938688]2762    }
2763  }
[22579cf]2764
[938688]2765  resolvente tr;
2766  int typ0=IDEAL_CMD;
[22579cf]2767
2768  if (minres!=NULL)
2769    tr = minres;
[938688]2770  else
[22579cf]2771    tr = fullres;
[750e70]2772
[22579cf]2773  resolvente trueres=NULL; intvec ** w=NULL;
2774
2775  if (length>0)
[938688]2776  {
[22579cf]2777    trueres = (resolvente)omAlloc0((length)*sizeof(ideal));
2778    for (int i=(length)-1;i>=0;i--)
[938688]2779    {
2780      if (tr[i]!=NULL)
2781      {
2782        trueres[i] = idCopy(tr[i]);
2783      }
2784    }
[8156a7]2785    if ( id_RankFreeModule(trueres[0], currRing) > 0)
[938688]2786      typ0 = MODUL_CMD;
2787    if (syzstr->weights!=NULL)
2788    {
[22579cf]2789      w = (intvec**)omAlloc0(length*sizeof(intvec*));
2790      for (int i=length-1;i>=0;i--)
[938688]2791      {
2792        if (syzstr->weights[i]!=NULL) w[i] = ivCopy(syzstr->weights[i]);
2793      }
2794    }
2795  }
[750e70]2796
[22579cf]2797  lists li = liMakeResolv(trueres, length, syzstr->list_length,typ0,
2798                          w, add_row_shift);
2799
2800  if (w != NULL) omFreeSize(w, length*sizeof(intvec*));
[750e70]2801
[22579cf]2802  if (toDel)
2803    syKillComputation(syzstr);
2804  else
2805  {
2806    if( fullres != NULL && syzstr->fullres == NULL )
2807      syzstr->fullres = fullres;
2808
2809    if( minres != NULL && syzstr->minres == NULL )
2810      syzstr->minres = minres;
2811  }
[750e70]2812
[938688]2813  return li;
[22579cf]2814
[750e70]2815
[938688]2816}
2817
2818/*3
2819* converts a list of modules into a resolution
2820*/
2821syStrategy syConvList(lists li,BOOLEAN toDel)
2822{
2823  int typ0;
2824  syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
2825
2826  resolvente fr = liFindRes(li,&(result->length),&typ0,&(result->weights));
2827  if (fr != NULL)
2828  {
2829
2830    result->fullres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
2831    for (int i=result->length-1;i>=0;i--)
2832    {
2833      if (fr[i]!=NULL)
2834        result->fullres[i] = idCopy(fr[i]);
2835    }
2836    result->list_length=result->length;
2837    omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
2838  }
2839  else
2840  {
2841    omFreeSize(result, sizeof(ssyStrategy));
2842    result = NULL;
2843  }
2844  if (toDel) li->Clean();
2845  return result;
2846}
2847
2848/*3
2849* converts a list of modules into a minimal resolution
2850*/
2851syStrategy syForceMin(lists li)
2852{
2853  int typ0;
2854  syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
2855
2856  resolvente fr = liFindRes(li,&(result->length),&typ0);
2857  result->minres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
2858  for (int i=result->length-1;i>=0;i--)
2859  {
2860    if (fr[i]!=NULL)
2861      result->minres[i] = idCopy(fr[i]);
2862  }
2863  omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
2864  return result;
2865}
2866// from weight.cc
2867BOOLEAN kWeight(leftv res,leftv id)
2868{
2869  ideal F=(ideal)id->Data();
[7fccc79]2870  intvec * iv = new intvec(rVar(currRing));
[938688]2871  polyset s;
2872  int  sl, n, i;
2873  int  *x;
2874
2875  res->data=(char *)iv;
2876  s = F->m;
2877  sl = IDELEMS(F) - 1;
[7fccc79]2878  n = rVar(currRing);
[6aacb6]2879  double wNsqr = (double)2.0 / (double)n;
[938688]2880  wFunctional = wFunctionalBuch;
2881  x = (int * )omAlloc(2 * (n + 1) * sizeof(int));
[6cc7f5]2882  wCall(s, sl, x, wNsqr, currRing);
[938688]2883  for (i = n; i!=0; i--)
2884    (*iv)[i-1] = x[i + n + 1];
2885  omFreeSize((ADDRESS)x, 2 * (n + 1) * sizeof(int));
2886  return FALSE;
2887}
2888
2889BOOLEAN kQHWeight(leftv res,leftv v)