source: git/Singular/ipshell.cc @ cb5cac

spielwiese
Last change on this file since cb5cac was cb5cac, checked in by Hans Schönemann <hannes@…>, 19 years ago
*hannes: ringlist git-svn-id: file:///usr/local/Singular/svn/trunk@7936 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 105.9 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipshell.cc,v 1.105 2005-04-29 07:49:55 Singular Exp $ */
5/*
6* ABSTRACT:
7*/
8
9//#include <stdlib.h>
10#include <stdio.h>
11#include <string.h>
12#include <ctype.h>
13#include <math.h>
14
15#include "mod2.h"
16#include "tok.h"
17#include "ipid.h"
18#include "intvec.h"
19#include "omalloc.h"
20#include "febase.h"
21#include "polys.h"
22#include "ideals.h"
23#include "matpol.h"
24#include "kstd1.h"
25#include "ring.h"
26#include "subexpr.h"
27#include "maps.h"
28#include "syz.h"
29#include "numbers.h"
30#include "lists.h"
31#include "attrib.h"
32#include "ipconv.h"
33#include "silink.h"
34#include "stairc.h"
35#include "weight.h"
36#include "semic.h"
37#include "splist.h"
38#include "spectrum.h"
39#include "gnumpfl.h"
40#include "mpr_base.h"
41#include "ffields.h"
42#include "clapsing.h"
43#include "hutil.h"
44#include "ipshell.h"
45#ifdef HAVE_FACTORY
46#define SI_DONT_HAVE_GLOBAL_VARS
47#include <factory.h>
48#endif
49
50// define this if you want to use the fast_map routine for mapping ideals
51#define FAST_MAP
52
53#ifdef FAST_MAP
54#include "fast_maps.h"
55#endif
56
57leftv iiCurrArgs=NULL;
58int  traceit = 0;
59char *lastreserved=NULL;
60
61int  myynest = -1;
62
63static BOOLEAN iiNoKeepRing=TRUE;
64
65/*0 implementation*/
66
67char * Tok2Cmdname(int tok)
68{
69  int i = 0;
70  if (tok < 0)
71  {
72    return cmds[0].name;
73  }
74  if (tok==ANY_TYPE) return "any_type";
75  if (tok==NONE) return "nothing";
76  //if (tok==IFBREAK) return "if_break";
77  //if (tok==VECTOR_FROM_POLYS) return "vector_from_polys";
78  //if (tok==ORDER_VECTOR) return "ordering";
79  //if (tok==REF_VAR) return "ref";
80  //if (tok==OBJECT) return "object";
81  //if (tok==PRINT_EXPR) return "print_expr";
82  if (tok==IDHDL) return "identifier";
83  while (cmds[i].tokval!=0)
84  {
85    if ((cmds[i].tokval == tok)&&(cmds[i].alias==0))
86    {
87      return cmds[i].name;
88    }
89    i++;
90  }
91  return cmds[0].name;
92}
93
94char * iiTwoOps(int t)
95{
96  if (t<127)
97  {
98    static char ch[2];
99    switch (t)
100    {
101      case '&':
102        return "and";
103      case '|':
104        return "or";
105      default:
106        ch[0]=t;
107        ch[1]='\0';
108        return ch;
109    }
110  }
111  switch (t)
112  {
113    case COLONCOLON:  return "::";
114    case DOTDOT:      return "..";
115    //case PLUSEQUAL:   return "+=";
116    //case MINUSEQUAL:  return "-=";
117    case MINUSMINUS:  return "--";
118    case PLUSPLUS:    return "++";
119    case EQUAL_EQUAL: return "==";
120    case LE:          return "<=";
121    case GE:          return ">=";
122    case NOTEQUAL:    return "<>";
123    default:          return Tok2Cmdname(t);
124  }
125}
126
127static void list1(char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
128{
129  char buffer[22];
130  int l;
131  char buf2[128];
132
133  if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
134  else sprintf(buf2, "%s", IDID(h));
135
136  Print("%s%-20.20s [%d]  ",s,buf2,IDLEV(h));
137  if (h == currRingHdl) PrintS("*");
138  PrintS(Tok2Cmdname((int)IDTYP(h)));
139
140  ipListFlag(h);
141  switch(IDTYP(h))
142  {
143    case INT_CMD:   Print(" %d",IDINT(h)); break;
144    case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
145    case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
146                    break;
147    case POLY_CMD:
148    case VECTOR_CMD:if (c)
149                    {
150                      PrintS(" ");wrp(IDPOLY(h));
151                      if(IDPOLY(h) != NULL)
152                      {
153                        Print(", %d monomial(s)",pLength(IDPOLY(h)));
154                      }
155                    }
156                    break;
157    case MODUL_CMD: Print(", rk %d", IDIDEAL(h)->rank);
158    case IDEAL_CMD: Print(", %u generator(s)",
159                    IDELEMS(IDIDEAL(h)),IDIDEAL(h)->rank); break;
160    case MAP_CMD:
161                    Print(" from %s",IDMAP(h)->preimage); break;
162    case MATRIX_CMD:Print(" %u x %u"
163                      ,MATROWS(IDMATRIX(h))
164                      ,MATCOLS(IDMATRIX(h))
165                    );
166                    break;
167    case PACKAGE_CMD:
168                    PrintS(" (");
169                    switch (IDPACKAGE(h)->language)
170                    {
171                        case LANG_SINGULAR: PrintS("S"); break;
172                        case LANG_C:        PrintS("C"); break;
173                        case LANG_TOP:      PrintS("T"); break;
174                        case LANG_NONE:     PrintS("N"); break;
175                        default:            PrintS("U");
176                    }
177                    if(IDPACKAGE(h)->libname!=NULL)
178                      Print(",%s", IDPACKAGE(h)->libname);
179                    PrintS(")");
180                    break;
181    case PROC_CMD: if(strlen(IDPROC(h)->libname)>0)
182                     Print(" from %s",IDPROC(h)->libname);
183                   if(IDPROC(h)->is_static)
184                     PrintS(" (static)");
185                   break;
186    case STRING_CMD:
187                   {
188                     char *s;
189                     l=strlen(IDSTRING(h));
190                     memset(buffer,0,22);
191                     strncpy(buffer,IDSTRING(h),min(l,20));
192                     if ((s=strchr(buffer,'\n'))!=NULL)
193                     {
194                       *s='\0';
195                     }
196                     PrintS(" ");
197                     PrintS(buffer);
198                     if((s!=NULL) ||(l>20))
199                     {
200                       Print("..., %d char(s)",l);
201                     }
202                     break;
203                   }
204    case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
205                   break;
206    case QRING_CMD:
207    case RING_CMD:
208                   if ((IDRING(h)==currRing) && (currRingHdl!=h))
209                     PrintS("(*)"); /* this is an alias to currRing */
210#ifdef RDEBUG
211                   if (traceit &TRACE_SHOW_RINGS)
212                     Print(" <%x>",IDRING(h));
213#endif
214                   break;
215    /*default:     break;*/
216  }
217  PrintLn();
218}
219
220void type_cmd(idhdl h)
221{
222  BOOLEAN oldShortOut = FALSE;
223
224  if (currRing != NULL)
225  {
226    oldShortOut = currRing->ShortOut;
227    currRing->ShortOut = 1;
228  }
229  list1("// ",h,FALSE,FALSE);
230  if (IDTYP(h)!=INT_CMD)
231  {
232    sleftv expr;
233    memset(&expr,0,sizeof(expr));
234    expr.rtyp=IDHDL;
235    expr.name=IDID(h);
236    expr.data=(void *)h;
237    expr.Print();
238  }
239  if (currRing != NULL)
240    currRing->ShortOut = oldShortOut;
241}
242
243static void killlocals0(int v, idhdl * localhdl, const ring r)
244{
245  idhdl h = *localhdl;
246  while (h!=NULL)
247  {
248    int vv;
249    //Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
250    if ((vv=IDLEV(h))>0)
251    {
252      if (vv < v)
253      {
254        if (iiNoKeepRing)
255        {
256          //PrintS(" break\n");
257          return;
258        }
259        h = IDNEXT(h);
260        //PrintLn();
261      }
262      else if (vv >= v)
263      {
264        idhdl nexth = IDNEXT(h);
265        killhdl2(h,localhdl,r);
266        h = nexth;
267        //PrintS("kill\n");
268      }
269    }
270    else
271    {
272      h = IDNEXT(h);
273      //PrintLn();
274    }
275  }
276}
277#ifndef HAVE_NS
278void killlocals(int v)
279{
280  killlocals0(v,&IDROOT,currRing);
281
282  if ((iiRETURNEXPR_len > myynest)
283  && ((iiRETURNEXPR[myynest].Typ()==RING_CMD)
284    || (iiRETURNEXPR[myynest].Typ()==QRING_CMD)))
285  {
286    leftv h=&iiRETURNEXPR[myynest];
287    killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
288  }
289
290  idhdl sh=currRingHdl;
291  ring sr=currRing;
292  BOOLEAN changed=FALSE;
293  idhdl h = IDROOT;
294
295//  Print("killlocals in %s\n",IDID(currPackHdl));
296  while (h!=NULL)
297  {
298    if (((IDTYP(h)==QRING_CMD) || (IDTYP(h) == RING_CMD))
299    && (IDRING(h)->idroot!=NULL))
300    {
301      if (IDRING(h)!=currRing) {changed=TRUE;rSetHdl(h);}
302      killlocals0(v,&(IDRING(h)->idroot),IDRING(h));
303    }
304    else if (IDTYP(h) == PACKAGE_CMD)
305    {
306      killlocals0(v,&(IDPACKAGE(h)->idroot),IDRING(h));
307    }
308    h = IDNEXT(h);
309  }
310  if (changed)
311  {
312    currRing=NULL;
313    currRingHdl=NULL;
314    if (sh!=NULL) rSetHdl(sh);
315    else if (sr!=NULL)
316    {
317      sh=rFindHdl(sr,NULL,NULL);
318      rSetHdl(sh);
319    }
320  }
321
322  if (myynest<=1) iiNoKeepRing=TRUE;
323  //Print("end killlocals  >= %d\n",v);
324  //listall();
325}
326#endif
327#ifdef HAVE_NS
328void killlocals_rec(idhdl *root,int v, ring r)
329{
330  idhdl h=*root;
331  while (h!=NULL)
332  {
333    if (IDLEV(h)>=v)
334    {
335//      Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
336      idhdl n=IDNEXT(h);
337      killhdl2(h,root,r);
338      h=n;
339    }
340    else if (IDTYP(h)==PACKAGE_CMD)
341    {
342 //     Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
343      if (IDPACKAGE(h)!=basePack)
344        killlocals_rec(&(IDRING(h)->idroot),v,r);
345      h=IDNEXT(h);
346    }
347    else if ((IDTYP(h)==RING_CMD)
348    ||(IDTYP(h)==QRING_CMD))
349    {
350      if (IDRING(h)->idroot!=NULL)
351      {
352  //    Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
353        killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
354      }
355      h=IDNEXT(h);
356    }
357    else
358    {
359//      Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
360      h=IDNEXT(h);
361    }
362  }
363}
364BOOLEAN killlocals_list(int v, lists L)
365{
366  if (L==NULL) return FALSE;
367  BOOLEAN changed=FALSE;
368  int n=L->nr;
369  for(;n>=0;n--)
370  {
371    leftv h=&(L->m[n]);
372    void *d=h->data;
373    if (((h->rtyp==RING_CMD) || (h->rtyp==QRING_CMD))
374    && (((ring)d)->idroot!=NULL))
375    {
376      if (d!=currRing) {changed=TRUE;rChangeCurrRing((ring)d);}
377      killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
378    }
379    else if (h->rtyp==LIST_CMD)
380      changed|=killlocals_list(v,(lists)d);
381  }
382  return changed;
383}
384void killlocals(int v)
385{
386  BOOLEAN changed=FALSE;
387  idhdl sh=currRingHdl;
388  ring cr=currRing;
389  if (sh!=NULL) changed=((IDLEV(sh)<v) || (IDRING(sh)->ref>0));
390  //if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
391
392  killlocals_rec(&(basePack->idroot),v,currRing);
393
394  if (iiRETURNEXPR_len > myynest)
395  {
396    int t=iiRETURNEXPR[myynest].Typ();
397    if ((/*iiRETURNEXPR[myynest].Typ()*/ t==RING_CMD)
398    || (/*iiRETURNEXPR[myynest].Typ()*/ t==QRING_CMD))
399    {
400      leftv h=&iiRETURNEXPR[myynest];
401      if (((ring)h->data)->idroot!=NULL)
402        killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
403    }
404    else if (/*iiRETURNEXPR[myynest].Typ()*/ t==LIST_CMD)
405    {
406      leftv h=&iiRETURNEXPR[myynest];
407      changed |=killlocals_list(v,(lists)h->data);
408    }
409  }
410  if (changed)
411  {
412    currRingHdl=rFindHdl(cr,NULL,NULL);
413    if (currRingHdl==NULL) 
414      currRing=NULL;
415    else
416      rChangeCurrRing(cr);
417  }
418
419  if (myynest<=1) iiNoKeepRing=TRUE;
420  //Print("end killlocals  >= %d\n",v);
421  //listall();
422}
423#endif
424
425void list_cmd(int typ, const char* what, char *prefix,BOOLEAN iterate, BOOLEAN fullname)
426{
427  idhdl h,start;
428  BOOLEAN all = typ<0;
429  BOOLEAN really_all=FALSE;
430  BOOLEAN do_packages=FALSE;
431
432  if ( typ == -1 ) do_packages=TRUE;
433  if ( typ==0 )
434  {
435    if (strcmp(what,"all")==0)
436    {
437      really_all=TRUE;
438#ifdef HAVE_NS
439      h=basePack->idroot;
440#else
441      h=IDROOT;
442#endif
443    }
444    else
445    {
446      h = ggetid(what);
447      if (h!=NULL)
448      {
449        if (iterate) list1(prefix,h,TRUE,fullname);
450        if ((IDTYP(h)==RING_CMD)
451            || (IDTYP(h)==QRING_CMD)
452#ifdef HAVE_NS
453            //|| (IDTYP(h)==PACKE_CMD)
454#endif
455        )
456        {
457          h=IDRING(h)->idroot;
458        }
459        else if((IDTYP(h)==PACKAGE_CMD) || (IDTYP(h)==POINTER_CMD))
460        {
461          Print("list_cmd:package or pointer\n");
462          all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
463          h=IDPACKAGE(h)->idroot;
464        }
465        else
466          return;
467      }
468      else
469      {
470        Werror("%s is undefined",what);
471        return;
472      }
473    }
474    all=TRUE;
475  }
476  else if (RingDependend(typ))
477  {
478    h = currRing->idroot;
479  }
480  else
481    h = IDROOT;
482  start=h;
483  while (h!=NULL)
484  {
485    if ((all && (IDTYP(h)!=PROC_CMD) &&(IDTYP(h)!=PACKAGE_CMD))
486    || (typ == IDTYP(h))
487    || ((IDTYP(h)==QRING_CMD) && (typ==RING_CMD)))
488    {
489      list1(prefix,h,start==currRingHdl, fullname);
490      if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
491        && (really_all || (all && (h==currRingHdl)))
492        && ((IDLEV(h)==0)||(IDLEV(h)==myynest)))
493      {
494        list_cmd(0,IDID(h),"//      ",FALSE);
495      }
496#ifdef HAVE_NS
497      if (IDTYP(h)==PACKAGE_CMD && really_all)
498      {
499        list_cmd(0,IDID(h),"//      ",FALSE);
500      }
501#endif /* HAVE_NS */
502    }
503    h = IDNEXT(h);
504  }
505}
506
507void test_cmd(int i)
508{
509  int ii=(char)i;
510
511  if (i == (-32))
512  {
513    test = 0;
514  }
515  else
516  {
517    if (i<0)
518    {
519      ii= -i;
520      if (Sy_bit(ii) & kOptions)
521      {
522        Warn("Gerhard, use the option command");
523        test &= ~Sy_bit(ii);
524      }
525      else if (Sy_bit(ii) & validOpts)
526        test &= ~Sy_bit(ii);
527    }
528    else if (i<32)
529    {
530      if (Sy_bit(ii) & kOptions)
531      {
532        Warn("Gerhard, use the option command");
533        test |= Sy_bit(ii);
534      }
535      else if (Sy_bit(ii) & validOpts)
536        test |= Sy_bit(ii);
537    }
538  }
539}
540
541int exprlist_length(leftv v)
542{
543  int rc = 0;
544  while (v!=NULL)
545  {
546    switch (v->Typ())
547    {
548      case INT_CMD:
549      case POLY_CMD:
550      case VECTOR_CMD:
551      case NUMBER_CMD:
552        rc++;
553        break;
554      case INTVEC_CMD:
555      case INTMAT_CMD:
556        rc += ((intvec *)(v->Data()))->length();
557        break;
558      case MATRIX_CMD:
559      case IDEAL_CMD:
560      case MODUL_CMD:
561        {
562          matrix mm = (matrix)(v->Data());
563          rc += mm->rows() * mm->cols();
564        }
565        break;
566      case LIST_CMD:
567        rc+=((lists)v->Data())->nr+1;
568        break;
569      default:
570        rc++;
571    }
572    v = v->next;
573  }
574  return rc;
575}
576
577int IsPrime(int p)  /* brute force !!!! */
578{
579  int i,j;
580  if      (p == 0)    return 0;
581  else if (p == 1)    return 1/*1*/;
582  else if (p == 2)    return p;
583  else if (p < 0)     return (-IsPrime(-p));
584  else if (!(p & 1)) return IsPrime(p-1);
585#ifdef HAVE_FACTORY
586  else if (p<=32749) // max. small prime in factory
587  {
588    int a=0;
589    int e=cf_getNumSmallPrimes()-1;
590    i=e/2;
591    do
592    {
593      if (p==(j=cf_getSmallPrime(i))) return p;
594      if (p<j) e=i-1;
595      else     a=i+1;
596      i=a+(e-a)/2;
597    } while ( a<= e);
598    if (p>j) return j;
599    else     return cf_getSmallPrime(i-1);
600  }
601#endif
602#ifdef HAVE_FACTORY
603  int end_i=cf_getNumSmallPrimes()-1;
604#else
605  int end_i=p/2;
606#endif 
607  int end_p=(int)sqrt((double)p);
608restart:
609  for (i=0; i<end_i; i++)
610  {
611#ifdef HAVE_FACTORY
612    j=cf_getSmallPrime(i);
613#else
614    if (i==0) j=2;
615    else j=2*i-1;
616#endif   
617    if ((p%j) == 0)
618    {
619    #ifdef HAVE_FACTORY
620      if (p<=32751) return IsPrime(p-2);
621    #endif 
622      p-=2;
623      goto restart;
624    }
625    if (j > end_p) return p;
626  }
627  return p;
628}
629
630BOOLEAN iiWRITE(leftv res,leftv v)
631{
632  sleftv vf;
633  if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
634  {
635    WerrorS("link expected");
636    return TRUE;
637  }
638  si_link l=(si_link)vf.Data();
639  if (vf.next == NULL)
640  {
641    WerrorS("write: need at least two arguments");
642    return TRUE;
643  }
644
645  BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
646  if (b)
647  {
648    const char *s;
649    if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
650    else                            s=sNoName;
651    Werror("cannot write to %s",s);
652  }
653  vf.CleanUp();
654  return b;
655}
656
657leftv iiMap(map theMap, char * what)
658{
659  idhdl w,r;
660  leftv v;
661  int i;
662  nMapFunc nMap;
663
664  r=IDROOT->get(theMap->preimage,myynest);
665#ifdef HAVE_NS
666  if ((currPack!=basePack)
667  &&((r==NULL) || ((r->typ != RING_CMD) && (r->typ != QRING_CMD))))
668    r=basePack->idroot->get(theMap->preimage,myynest);
669  if ((r==NULL) && (currRingHdl!=NULL)
670  && (strcmp(theMap->preimage,IDID(currRingHdl))==0))
671  {
672    r=currRingHdl;
673  }
674#endif /* HAVE_NS */
675  if ((r!=NULL) && ((r->typ == RING_CMD) || (r->typ== QRING_CMD)))
676  {
677    //if ((nMap=nSetMap(rInternalChar(IDRING(r)),
678    //             IDRING(r)->parameter,
679    //             rPar(IDRING(r)),
680    //             IDRING(r)->minpoly)))
681    if ((nMap=nSetMap(IDRING(r)))==NULL)
682    {
683      if (rEqual(IDRING(r),currRing))
684      {
685        nMap=nCopy;
686      }
687      else
688      {
689        Werror("can not map from ground field of %s to current ground field",
690          theMap->preimage);
691        return NULL;
692      }
693    }
694    if (IDELEMS(theMap)<IDRING(r)->N)
695    {
696      theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
697                                 IDELEMS(theMap)*sizeof(poly),
698                                 (IDRING(r)->N)*sizeof(poly));
699      for(i=IDELEMS(theMap);i<IDRING(r)->N;i++)
700        theMap->m[i]=NULL;
701      IDELEMS(theMap)=IDRING(r)->N;
702    }
703    if (what==NULL)
704    {
705      WerrorS("argument of a map must have a name");
706    }
707    else if ((w=IDRING(r)->idroot->get(what,myynest))!=NULL)
708    {
709      v=(leftv)omAlloc0Bin(sleftv_bin);
710      sleftv tmpW;
711      memset(&tmpW,0,sizeof(sleftv));
712      tmpW.rtyp=IDTYP(w);
713      tmpW.data=IDDATA(w);
714      #ifdef FAST_MAP
715      if ((tmpW.rtyp==IDEAL_CMD) && (nMap==nCopy)
716      #ifdef HAVE_PLURAL
717      && (!rIsPluralRing(currRing))
718      #endif
719      )
720      {
721        v->rtyp=IDEAL_CMD;
722        v->data=fast_map(IDIDEAL(w), IDRING(r), (ideal)theMap, currRing);
723      }
724      else
725      #endif
726      if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,IDRING(r),NULL,NULL,0,nMap))
727      {
728        Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
729        omFreeBin((ADDRESS)v, sleftv_bin);
730        return NULL;
731      }
732      return v;
733    }
734    else
735    {
736      Werror("%s undefined in %s",what,theMap->preimage);
737    }
738  }
739  else
740  {
741    Werror("cannot find preimage %s",theMap->preimage);
742  }
743  return NULL;
744}
745
746#ifdef OLD_RES
747void  iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
748                   intvec ** weights)
749{
750  lists L=liMakeResolv(r,length,rlen,typ0,weights);
751  int i=0;
752  idhdl h;
753  char * s=(char *)omAlloc(strlen(name)+5);
754
755  while (i<=L->nr)
756  {
757    sprintf(s,"%s(%d)",name,i+1);
758    if (i==0)
759      h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
760    else
761      h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
762    if (h!=NULL)
763    {
764      h->data.uideal=(ideal)L->m[i].data;
765      h->attribute=L->m[i].attribute;
766      if (BVERBOSE(V_DEF_RES))
767        Print("//defining: %s as %d-th syzygy module\n",s,i+1);
768    }
769    else
770    {
771      idDelete((ideal *)&(L->m[i].data));
772      Warn("cannot define %s",s);
773    }
774    //L->m[i].data=NULL;
775    //L->m[i].rtyp=0;
776    //L->m[i].attribute=NULL;
777    i++;
778  }
779  omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
780  omFreeBin((ADDRESS)L, slists_bin);
781  omFreeSize((ADDRESS)s,strlen(name)+5);
782}
783#endif
784
785//resolvente iiFindRes(char * name, int * len, int *typ0)
786//{
787//  char *s=(char *)omAlloc(strlen(name)+5);
788//  int i=-1;
789//  resolvente r;
790//  idhdl h;
791//
792//  do
793//  {
794//    i++;
795//    sprintf(s,"%s(%d)",name,i+1);
796//    h=currRing->idroot->get(s,myynest);
797//  } while (h!=NULL);
798//  *len=i-1;
799//  if (*len<=0)
800//  {
801//    Werror("no objects %s(1),.. found",name);
802//    omFreeSize((ADDRESS)s,strlen(name)+5);
803//    return NULL;
804//  }
805//  r=(ideal *)omAlloc(/*(len+1)*/ i*sizeof(ideal));
806//  memset(r,0,(*len)*sizeof(ideal));
807//  i=-1;
808//  *typ0=MODUL_CMD;
809//  while (i<(*len))
810//  {
811//    i++;
812//    sprintf(s,"%s(%d)",name,i+1);
813//    h=currRing->idroot->get(s,myynest);
814//    if (h->typ != MODUL_CMD)
815//    {
816//      if ((i!=0) || (h->typ!=IDEAL_CMD))
817//      {
818//        Werror("%s is not of type module",s);
819//        omFreeSize((ADDRESS)r,(*len)*sizeof(ideal));
820//        omFreeSize((ADDRESS)s,strlen(name)+5);
821//        return NULL;
822//      }
823//      *typ0=IDEAL_CMD;
824//    }
825//    if ((i>0) && (idIs0(r[i-1])))
826//    {
827//      *len=i-1;
828//      break;
829//    }
830//    r[i]=IDIDEAL(h);
831//  }
832//  omFreeSize((ADDRESS)s,strlen(name)+5);
833//  return r;
834//}
835
836static resolvente iiCopyRes(resolvente r, int l)
837{
838  int i;
839  resolvente res=(ideal *)omAlloc0((l+1)*sizeof(ideal));
840
841  for (i=0; i<l; i++)
842    res[i]=idCopy(r[i]);
843  return res;
844}
845
846BOOLEAN jjMINRES(leftv res, leftv v)
847{
848  int len=0;
849  int typ0;
850  resolvente rr=liFindRes((lists)v->Data(),&len,&typ0);
851  if (rr==NULL) return TRUE;
852  resolvente r=iiCopyRes(rr,len);
853
854  syMinimizeResolvente(r,len,0);
855  omFreeSize((ADDRESS)rr,len*sizeof(ideal));
856  len++;
857  res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL);
858  return FALSE;
859}
860
861BOOLEAN jjBETTI(leftv res, leftv u)
862{
863  sleftv tmp;
864  memset(&tmp,0,sizeof(tmp));
865  tmp.rtyp=INT_CMD;
866  tmp.data=(void *)1; 
867  if ((u->Typ()==IDEAL_CMD)
868  || (u->Typ()==MODUL_CMD))
869    return jjBETTI2_ID(res,u,&tmp);
870  else
871    return jjBETTI2(res,u,&tmp);
872}
873
874BOOLEAN jjBETTI2_ID(leftv res, leftv u, leftv v)
875{
876  lists l=(lists) omAllocBin(slists_bin);
877  l->Init(1);
878  l->m[0].rtyp=u->Typ();
879  l->m[0].data=u->Data();
880  l->m[0].attribute=u->attribute;
881  sleftv tmp2;
882  memset(&tmp2,0,sizeof(tmp2));
883  tmp2.rtyp=LIST_CMD;
884  tmp2.data=(void *)l;
885  BOOLEAN r=jjBETTI2(res,&tmp2,v);
886  l->m[0].data=NULL;
887  l->m[0].attribute=NULL;
888  l->m[0].rtyp=DEF_CMD;
889  l->Clean();
890  return r;
891}
892
893BOOLEAN jjBETTI2(leftv res, leftv u, leftv v)
894{
895  resolvente r;
896  int len;
897  int reg,typ0;
898  lists l=(lists)u->Data();
899
900  intvec *weights=NULL;
901  int add_row_shift=0;
902  intvec *ww=(intvec *)atGet(&(l->m[0]),"isHomog",INTVEC_CMD); 
903  if (ww!=NULL)
904  {
905     weights=ivCopy(ww);
906     add_row_shift = ww->min_in();
907     (*weights) -= add_row_shift;
908  }
909  //Print("attr:%x\n",weights);
910
911  r=liFindRes(l,&len,&typ0);
912  if (r==NULL) return TRUE;
913  res->data=(char *)syBetti(r,len,&reg,weights,(int)v->Data());
914  omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
915  atSet(res,omStrDup("rowShift"),(void*)add_row_shift,INT_CMD);
916  if (weights!=NULL) delete weights;
917  return FALSE;
918}
919
920int iiRegularity(lists L)
921{
922  int len,reg,typ0;
923
924  resolvente r=liFindRes(L,&len,&typ0);
925
926  if (r==NULL)
927    return -2;
928  intvec * dummy=syBetti(r,len,&reg);
929  omFreeSize((ADDRESS)r,len*sizeof(ideal));
930  delete dummy;
931  return reg+1;
932}
933
934BOOLEAN iiDebugMarker=TRUE;
935#define BREAK_LINE_LENGTH 80
936void iiDebug()
937{
938  Print("\n-- break point in %s --\n",VoiceName());
939  if (iiDebugMarker) VoiceBackTrack();
940  char * s;
941  iiDebugMarker=FALSE;
942  s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
943  loop
944  {
945    memset(s,0,80);
946    fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
947    if (s[BREAK_LINE_LENGTH-1]!='\0')
948    {
949      Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
950    }
951    else
952      break;
953  }
954  if (*s=='\n')
955  {
956    iiDebugMarker=TRUE;
957  }
958#if MDEBUG
959  else if(strncmp(s,"cont;",5)==0)
960  {
961    iiDebugMarker=TRUE;
962  }
963#endif /* MDEBUG */
964  else
965  {
966    strcat( s, "\n;~\n");
967    newBuffer(s,BT_execute);
968  }
969}
970
971lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
972{
973  int i;
974  indset save;
975  lists res=(lists)omAlloc0Bin(slists_bin);
976
977  hexist = hInit(S, Q, &hNexist);
978  if ((hNexist == 0) || (hisModule!=0))
979  {
980    res->Init(0);
981    return res;
982  }
983  save = ISet = (indset)omAlloc0Bin(indlist_bin);
984  hMu = 0;
985  hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
986  hvar = (varset)omAlloc((pVariables + 1) * sizeof(int));
987  hpure = (scmon)omAlloc((1 + (pVariables * pVariables)) * sizeof(Exponent_t));
988  hrad = hexist;
989  hNrad = hNexist;
990  radmem = hCreate(pVariables - 1);
991  hCo = pVariables + 1;
992  hNvar = pVariables;
993  hRadical(hrad, &hNrad, hNvar);
994  hSupp(hrad, hNrad, hvar, &hNvar);
995  if (hNvar)
996  {
997    hCo = hNvar;
998    memset(hpure, 0, (pVariables + 1) * sizeof(Exponent_t));
999    hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
1000    hLexR(hrad, hNrad, hvar, hNvar);
1001    hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1002  }
1003  if (hCo && (hCo < pVariables))
1004  {
1005    hIndMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1006  }
1007  if (hMu!=0)
1008  {
1009    ISet = save;
1010    hMu2 = 0;
1011    if (all && (hCo+1 < pVariables))
1012    {
1013      JSet = (indset)omAlloc0Bin(indlist_bin);
1014      hIndAllMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1015      i=hMu+hMu2;
1016      res->Init(i);
1017      if (hMu2 == 0)
1018      {
1019        omFreeBin((ADDRESS)JSet, indlist_bin);
1020      }
1021    }
1022    else
1023    {
1024      res->Init(hMu);
1025    }
1026    for (i=0;i<hMu;i++)
1027    {
1028      res->m[i].data = (void *)save->set;
1029      res->m[i].rtyp = INTVEC_CMD;
1030      ISet = save;
1031      save = save->nx;
1032      omFreeBin((ADDRESS)ISet, indlist_bin);
1033    }
1034    omFreeBin((ADDRESS)save, indlist_bin);
1035    if (hMu2 != 0)
1036    {
1037      save = JSet;
1038      for (i=hMu;i<hMu+hMu2;i++)
1039      {
1040        res->m[i].data = (void *)save->set;
1041        res->m[i].rtyp = INTVEC_CMD;
1042        JSet = save;
1043        save = save->nx;
1044        omFreeBin((ADDRESS)JSet, indlist_bin);
1045      }
1046      omFreeBin((ADDRESS)save, indlist_bin);
1047    }
1048  }
1049  else
1050  {
1051    res->Init(0);
1052    omFreeBin((ADDRESS)ISet,  indlist_bin);
1053  }
1054  hKill(radmem, pVariables - 1);
1055  omFreeSize((ADDRESS)hpure, (1 + (pVariables * pVariables)) * sizeof(Exponent_t));
1056  omFreeSize((ADDRESS)hvar, (pVariables + 1) * sizeof(int));
1057  omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1058  hDelete(hexist, hNexist);
1059  return res;
1060}
1061
1062int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
1063{
1064  BOOLEAN res=FALSE;
1065  char *id = name->name;
1066
1067  memset(sy,0,sizeof(sleftv));
1068  if ((name->name==NULL)||(isdigit(name->name[0])))
1069  {
1070    WerrorS("object to declare is not a name");
1071    res=TRUE;
1072  }
1073  else
1074  {
1075    //if (name->rtyp!=0)
1076    //{
1077    //  Warn("`%s` is already in use",name->name);
1078    //}
1079    {
1080      sy->data = (char *)enterid(id,lev,t,root,init_b);
1081    }
1082    if (sy->data!=NULL)
1083    {
1084      sy->rtyp=IDHDL;
1085      currid=sy->name=IDID((idhdl)sy->data);
1086      // name->name=NULL; /* used in enterid */
1087      //sy->e = NULL;
1088      if (name->next!=NULL)
1089      {
1090        sy->next=(leftv)omAllocBin(sleftv_bin);
1091        res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
1092      }
1093    }
1094    else res=TRUE;
1095  }
1096  name->CleanUp();
1097  return res;
1098}
1099
1100BOOLEAN iiParameter(leftv p)
1101{
1102  if (iiCurrArgs==NULL)
1103  {
1104    if (strcmp(p->name,"#")==0) return FALSE;
1105    Werror("not enough arguments for proc %s",VoiceName());
1106    p->CleanUp();
1107    return TRUE;
1108  }
1109  leftv h=iiCurrArgs;
1110  if (strcmp(p->name,"#")==0)
1111  {
1112    iiCurrArgs=NULL;
1113  }
1114  else
1115  {
1116    iiCurrArgs=h->next;
1117    h->next=NULL;
1118  }
1119  BOOLEAN res=iiAssign(p,h);
1120  omFreeBin((ADDRESS)h, sleftv_bin);
1121  return res;
1122}
1123
1124static BOOLEAN iiInternalExport (leftv v, int toLev)
1125{
1126  idhdl h=(idhdl)v->data;
1127  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
1128  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
1129  else
1130  {
1131    h=IDROOT->get(v->name,toLev);
1132    idhdl *root=&IDROOT;
1133    if ((h==NULL)&&(currRing!=NULL))
1134    {
1135      h=currRing->idroot->get(v->name,toLev);
1136      root=&currRing->idroot;
1137    }
1138    BOOLEAN keepring=FALSE;
1139    if ((h!=NULL)&&(IDLEV(h)==toLev))
1140    {
1141      if (IDTYP(h)==v->Typ())
1142      {
1143        if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
1144        && (v->Data()==IDDATA(h)))
1145        {
1146          IDRING(h)->ref++;
1147          keepring=TRUE;
1148          IDLEV(h)=toLev;
1149          //WarnS("keepring");
1150          return FALSE;
1151        }
1152        if (BVERBOSE(V_REDEFINE))
1153        {
1154          Warn("redefining %s",IDID(h));
1155        }
1156#ifdef USE_IILOCALRING
1157        if (iiLocalRing[0]==IDRING(h) && (!keepring)) iiLocalRing[0]=NULL;
1158#else
1159        proclevel *p=procstack;
1160        while (p->next!=NULL) p=p->next;
1161        if ((p->cRing==IDRING(h)) && (!keepring))
1162        {
1163          p->cRing=NULL;
1164          p->cRingHdl=NULL;
1165        }
1166#endif
1167        killhdl2(h,root,currRing);
1168      }
1169      else
1170      {
1171        return TRUE;
1172      }
1173    }
1174    h=(idhdl)v->data;
1175    IDLEV(h)=toLev;
1176    if (keepring) IDRING(h)->ref--;
1177    iiNoKeepRing=FALSE;
1178    //Print("export %s\n",IDID(h));
1179  }
1180  return FALSE;
1181}
1182
1183#ifdef HAVE_NS
1184BOOLEAN iiInternalExport (leftv v, int toLev, idhdl roothdl)
1185{
1186  idhdl h=(idhdl)v->data;
1187  if(h==NULL)
1188  {
1189    Warn("'%s': no such identifier\n", v->name);
1190    return FALSE;
1191  }
1192  package frompack=v->req_packhdl; 
1193  if (frompack==NULL) frompack=currPack;
1194  package rootpack = IDPACKAGE(roothdl);
1195//  Print("iiInternalExport('%s',%d,%s->%s) typ:%d\n", v->name, toLev, IDID(currPackHdl),IDID(roothdl),v->Typ());
1196  if ((RingDependend(IDTYP(h)))
1197  || ((IDTYP(h)==LIST_CMD)
1198     && (lRingDependend(IDLIST(h)))
1199     )
1200  )
1201  {
1202    //Print("// ==> Ringdependent set nesting to 0\n");
1203    return (iiInternalExport(v, toLev));
1204  }
1205  else
1206  {
1207    IDLEV(h)=toLev;
1208    v->req_packhdl=rootpack;
1209    if (h==frompack->idroot)
1210    {
1211      frompack->idroot=h->next;
1212    }
1213    else
1214    {
1215      idhdl hh=frompack->idroot;
1216      while ((hh!=NULL) && (hh->next!=h))
1217        hh=hh->next;
1218      if ((hh!=NULL) && (hh->next==h))
1219        hh->next=h->next;
1220      else
1221      {
1222        Werror("`%s` not found",v->Name());
1223        return TRUE;
1224      }
1225    }
1226    h->next=rootpack->idroot;
1227    rootpack->idroot=h;
1228  }
1229  return FALSE;
1230}
1231#endif /* HAVE_NS */
1232
1233BOOLEAN iiExport (leftv v, int toLev)
1234{
1235#ifdef HAVE_NS
1236  checkall();
1237#endif
1238  BOOLEAN nok=FALSE;
1239  leftv r=v;
1240  while (v!=NULL)
1241  {
1242    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
1243    {
1244      WerrorS("cannot export");
1245      nok=TRUE;
1246    }
1247    else
1248    {
1249      if(iiInternalExport(v, toLev))
1250      {
1251        r->CleanUp();
1252        return TRUE;
1253      }
1254    }
1255    v=v->next;
1256  }
1257  r->CleanUp();
1258#ifdef HAVE_NS
1259  checkall();
1260#endif
1261  return nok;
1262}
1263
1264/*assume root!=idroot*/
1265#ifdef HAVE_NS
1266BOOLEAN iiExport (leftv v, int toLev, idhdl root)
1267{
1268  checkall();
1269  //  Print("iiExport1: pack=%s\n",IDID(root));
1270  BOOLEAN nok=FALSE;
1271  leftv rv=v;
1272  while (v!=NULL)
1273  {
1274    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1275    )
1276    {
1277      WerrorS("cannot export");
1278      nok=TRUE;
1279    }
1280    else
1281    {
1282      idhdl old=root->get(v->name,toLev);
1283      if (old!=NULL)
1284      {
1285        if (IDTYP(old)==v->Typ())
1286        {
1287          if (BVERBOSE(V_REDEFINE))
1288          {
1289            Warn("redefining %s",IDID(old));
1290          }
1291          killhdl2(old,&root,currRing);
1292        }
1293        else
1294        {
1295          rv->CleanUp();
1296          return TRUE;
1297        }
1298      }
1299      //Print("iiExport: pack=%s\n",IDID(root));
1300      if(iiInternalExport(v, toLev, root))
1301      {
1302        rv->CleanUp();
1303        return TRUE;
1304      }
1305    }
1306    v=v->next;
1307  }
1308  rv->CleanUp();
1309  checkall();
1310  return nok;
1311}
1312#endif
1313
1314BOOLEAN iiCheckRing(int i)
1315{
1316  if (currRingHdl==NULL)
1317  {
1318    #ifdef SIQ
1319    if (siq<=0)
1320    {
1321    #endif
1322      if (RingDependend(i))
1323      {
1324        WerrorS("no ring active");
1325        return TRUE;
1326      }
1327    #ifdef SIQ
1328    }
1329    #endif
1330  }
1331  return FALSE;
1332}
1333
1334poly    iiHighCorner(ideal I, int ak)
1335{
1336  int i;
1337  if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1338  poly po=NULL;
1339  if (currRing->OrdSgn== -1)
1340  {
1341    scComputeHC(I,currQuotient,ak,po);
1342    if (po!=NULL)
1343    {
1344      pGetCoeff(po)=nInit(1);
1345      for (i=pVariables; i>0; i--)
1346      {
1347        if (pGetExp(po, i) > 0) pDecrExp(po,i);
1348      }
1349      pSetComp(po,ak);
1350      pSetm(po);
1351    }
1352  }
1353  else
1354    po=pOne();
1355  return po;
1356}
1357
1358#ifdef HAVE_NS
1359void iiCheckPack(package &p)
1360{
1361  if (p==basePack) return;
1362
1363  idhdl t=basePack->idroot;
1364
1365  while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
1366
1367  if (t==NULL)
1368  {
1369    WarnS("package not found\n");
1370    p=basePack;
1371  }
1372  return;
1373}
1374#endif
1375
1376idhdl rDefault(char *s)
1377{
1378  idhdl tmp=NULL;
1379
1380  if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
1381  if (tmp==NULL) return NULL;
1382
1383  if (ppNoether!=NULL) pDelete(&ppNoether);
1384  if (sLastPrinted.RingDependend())
1385  {
1386    sLastPrinted.CleanUp();
1387    memset(&sLastPrinted,0,sizeof(sleftv));
1388  }
1389
1390  ring r = IDRING(tmp);
1391
1392  r->ch    = 32003;
1393  r->N     = 3;
1394  /*r->P     = 0; Alloc0 in idhdl::set, ipid.cc*/
1395  /*names*/
1396  r->names = (char **) omAlloc0(3 * sizeof(char_ptr));
1397  r->names[0]  = omStrDup("x");
1398  r->names[1]  = omStrDup("y");
1399  r->names[2]  = omStrDup("z");
1400  /*weights: entries for 3 blocks: NULL*/
1401  r->wvhdl = (int **)omAlloc0(3 * sizeof(int_ptr));
1402  /*order: dp,C,0*/
1403  r->order = (int *) omAlloc(3 * sizeof(int *));
1404  r->block0 = (int *)omAlloc0(3 * sizeof(int *));
1405  r->block1 = (int *)omAlloc0(3 * sizeof(int *));
1406  /* ringorder dp for the first block: var 1..3 */
1407  r->order[0]  = ringorder_dp;
1408  r->block0[0] = 1;
1409  r->block1[0] = 3;
1410  /* ringorder C for the second block: no vars */
1411  r->order[1]  = ringorder_C;
1412  /* the last block: everything is 0 */
1413  r->order[2]  = 0;
1414  /*polynomial ring*/
1415  r->OrdSgn    = 1;
1416
1417  /* complete ring intializations */
1418  rComplete(r);
1419  rSetHdl(tmp);
1420  return currRingHdl;
1421}
1422
1423idhdl rFindHdl(ring r, idhdl n, idhdl w)
1424{
1425  idhdl h=rSimpleFindHdl(r,IDROOT,n);
1426  if (h!=NULL)  return h;
1427#ifdef HAVE_NS
1428  if (IDROOT!=basePack->idroot) h=rSimpleFindHdl(r,basePack->idroot,n);
1429  if (h!=NULL)  return h;
1430  proclevel *p=procstack;
1431  while(p!=NULL)
1432  {
1433    if ((p->cPack!=basePack)
1434    && (p->cPack!=currPack))
1435      h=rSimpleFindHdl(r,p->cPack->idroot,n);
1436    if (h!=NULL)  return h;
1437    p=p->next;
1438  }
1439  idhdl tmp=basePack->idroot;
1440  while (tmp!=NULL)
1441  {
1442    if (IDTYP(tmp)==PACKAGE_CMD)
1443      h=rSimpleFindHdl(r,IDPACKAGE(tmp)->idroot,n);
1444    if (h!=NULL)  return h;
1445    tmp=IDNEXT(tmp);
1446  }
1447#endif
1448  return NULL;
1449}
1450
1451void rDecomposeCF(leftv h,const ring r,const ring R)
1452{
1453  lists L=(lists)omAlloc0Bin(slists_bin);
1454  L->Init(4);
1455  h->rtyp=LIST_CMD;
1456  h->data=(void *)L;
1457  // 0: char/ cf - ring
1458  // 1: list (var)
1459  // 2: list (ord)
1460  // 3: qideal
1461  // ----------------------------------------
1462  // 0: char/ cf - ring
1463  L->m[0].rtyp=INT_CMD;
1464  L->m[0].data=(void *)r->ch;
1465  // ----------------------------------------
1466  // 1: list (var)
1467  lists LL=(lists)omAlloc0Bin(slists_bin);
1468  LL->Init(r->N);
1469  int i;
1470  for(i=0; i<r->N; i++)
1471  {
1472    LL->m[i].rtyp=STRING_CMD;
1473    LL->m[i].data=(void *)omStrDup(r->names[i]);
1474  }
1475  L->m[1].rtyp=LIST_CMD;
1476  L->m[1].data=(void *)LL;
1477  // ----------------------------------------
1478  // 2: list (ord)
1479  LL=(lists)omAlloc0Bin(slists_bin);
1480  i=rBlocks(r)-1;
1481  LL->Init(i);
1482  i--;
1483  lists LLL;
1484  for(; i>=0; i--)
1485  {
1486    intvec *iv;
1487    int j;
1488    LL->m[i].rtyp=LIST_CMD;
1489    LLL=(lists)omAlloc0Bin(slists_bin);
1490    LLL->Init(2);
1491    LLL->m[0].rtyp=STRING_CMD;
1492    LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1493    if (r->block1[i]-r->block0[i] >=0 )
1494    {
1495      j=r->block1[i]-r->block0[i];
1496      iv=new intvec(j+1);
1497      if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1498      {
1499        for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1500      }
1501      else switch (r->order[i])
1502      {
1503        case ringorder_dp:
1504        case ringorder_Dp:
1505        case ringorder_ds:
1506        case ringorder_Ds:
1507        case ringorder_lp:
1508          for(;j>=0; j--) (*iv)[j]=1;
1509          break;
1510        default: /* do nothing */;
1511      }
1512    }
1513    else
1514    {
1515      iv=new intvec(1);
1516    }
1517    LLL->m[1].rtyp=INTVEC_CMD;
1518    LLL->m[1].data=(void *)iv;
1519    LL->m[i].data=(void *)LLL;
1520  }
1521  L->m[2].rtyp=LIST_CMD;
1522  L->m[2].data=(void *)LL;
1523  // ----------------------------------------
1524  // 3: qideal
1525  L->m[3].rtyp=IDEAL_CMD;
1526  if (R->minpoly==NULL)
1527    L->m[3].data=(void *)idInit(1,1);
1528  else
1529  {
1530    ideal I=idInit(1,1);
1531    L->m[3].data=(void *)I;
1532    I->m[0]=pOne();
1533    pSetCoeff(I->m[0],R->minpoly);
1534  }
1535  // ----------------------------------------
1536}
1537void rDecomposeC(leftv h,const ring R)
1538{
1539  lists L=(lists)omAlloc0Bin(slists_bin);
1540  L->Init(4);
1541  h->rtyp=LIST_CMD;
1542  h->data=(void *)L;
1543  // 0: char/ cf - ring
1544  // 1: list (var)
1545  // 2: list (ord)
1546  // 3: qideal
1547  // ----------------------------------------
1548  // 0: char/ cf - ring
1549  L->m[0].rtyp=INT_CMD;
1550  L->m[0].data=(void *)R->ch;
1551  // ----------------------------------------
1552  // 1: list (var)
1553  lists LL=(lists)omAlloc0Bin(slists_bin);
1554  LL->Init(1);
1555    LL->m[0].rtyp=STRING_CMD;
1556    LL->m[0].data=(void *)omStrDup(R->parameter[0]);
1557  L->m[1].rtyp=LIST_CMD;
1558  L->m[1].data=(void *)LL;
1559  // ----------------------------------------
1560  // 2: list (ord)
1561  LL=(lists)omAlloc0Bin(slists_bin);
1562  LL->Init(1);
1563  lists LLL;
1564  {
1565    intvec *iv;
1566    int j;
1567    LL->m[0].rtyp=LIST_CMD;
1568    LLL=(lists)omAlloc0Bin(slists_bin);
1569    LLL->Init(2);
1570    LLL->m[0].rtyp=STRING_CMD;
1571    LLL->m[0].data=(void *)omStrDup("lp");
1572    {
1573      iv=new intvec(1);
1574      for(;j>=0; j--) (*iv)[0]=1;
1575    }
1576    LLL->m[1].rtyp=INTVEC_CMD;
1577    LLL->m[1].data=(void *)iv;
1578    LL->m[0].data=(void *)LLL;
1579  }
1580  L->m[2].rtyp=LIST_CMD;
1581  L->m[2].data=(void *)LL;
1582  // ----------------------------------------
1583  // 3: qideal
1584  L->m[3].rtyp=IDEAL_CMD;
1585  {
1586    ideal I=idInit(1,1);
1587    L->m[3].data=(void *)I;
1588    //I->m[0]=pOne();
1589    //pSetCoeff(I->m[0],R->minpoly);
1590  }
1591  // ----------------------------------------
1592}
1593
1594lists rDecompose(const ring r)
1595{
1596  // sanity check:
1597  if ((r!=currRing) 
1598  && ((r->minpoly!=NULL) || (r->qideal!=NULL) || (r->minideal!=NULL))
1599  )
1600  {
1601    WerrorS("ring must be the base ring or compatible");
1602    return NULL;
1603  }
1604  // 0: char/ cf - ring
1605  // 1: list (var)
1606  // 2: list (ord)
1607  // 3: qideal
1608  // possibly:
1609  // 4: C
1610  // 5: D
1611  lists L=(lists)omAlloc0Bin(slists_bin);
1612  if (rIsPluralRing(r))
1613    L->Init(6);
1614  else
1615    L->Init(4);
1616  // ----------------------------------------
1617  // 0: char/ cf - ring
1618  #if 1 /* TODO */
1619  if (rIsExtension(r))
1620  {
1621    if (rField_is_long_C(r))
1622      rDecomposeC(&(L->m[0]),r);
1623    else
1624      rDecomposeCF(&(L->m[0]),r->algring,r);
1625    if (L->m[0].rtyp==0)
1626    {
1627      omFreeBin(slists_bin,(void *)L);
1628      return NULL;
1629    }
1630  }
1631  else
1632  #endif
1633  {
1634    L->m[0].rtyp=INT_CMD;
1635    L->m[0].data=(void *)r->ch;
1636  }
1637  // ----------------------------------------
1638  // 1: list (var)
1639  lists LL=(lists)omAlloc0Bin(slists_bin);
1640  LL->Init(r->N);
1641  int i;
1642  for(i=0; i<r->N; i++)
1643  {
1644    LL->m[i].rtyp=STRING_CMD;
1645    LL->m[i].data=(void *)omStrDup(r->names[i]);
1646  }
1647  L->m[1].rtyp=LIST_CMD;
1648  L->m[1].data=(void *)LL;
1649  // ----------------------------------------
1650  // 2: list (ord)
1651  LL=(lists)omAlloc0Bin(slists_bin);
1652  i=rBlocks(r)-1;
1653  LL->Init(i);
1654  i--;
1655  lists LLL;
1656  for(; i>=0; i--)
1657  {
1658    intvec *iv;
1659    int j;
1660    LL->m[i].rtyp=LIST_CMD;
1661    LLL=(lists)omAlloc0Bin(slists_bin);
1662    LLL->Init(2);
1663    LLL->m[0].rtyp=STRING_CMD;
1664    LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1665    if (r->block1[i]-r->block0[i] >=0 )
1666    {
1667      j=r->block1[i]-r->block0[i];
1668      iv=new intvec(j+1);
1669      if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1670      {
1671        for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1672      }
1673      else switch (r->order[i])
1674      {
1675        case ringorder_dp:
1676        case ringorder_Dp:
1677        case ringorder_ds:
1678        case ringorder_Ds:
1679        case ringorder_lp:
1680          for(;j>=0; j--) (*iv)[j]=1;
1681          break;
1682        default: /* do nothing */;
1683      }
1684    }
1685    else
1686    {
1687      iv=new intvec(1);
1688    }
1689    LLL->m[1].rtyp=INTVEC_CMD;
1690    LLL->m[1].data=(void *)iv;
1691    LL->m[i].data=(void *)LLL;
1692  }
1693  L->m[2].rtyp=LIST_CMD;
1694  L->m[2].data=(void *)LL;
1695  // ----------------------------------------
1696  // 3: qideal
1697  L->m[3].rtyp=IDEAL_CMD;
1698  if (r->qideal==NULL)
1699    L->m[3].data=(void *)idInit(1,1);
1700  else
1701    L->m[3].data=(void *)idCopy(r->qideal);
1702  // ----------------------------------------
1703  #ifdef HAVE_PLURAL
1704  if (rIsPluralRing(r))
1705  {
1706    L->m[4].rtyp=MATRIX_CMD;
1707    L->m[4].data=(void *)mpCopy(r->nc->C);
1708    L->m[5].rtyp=MATRIX_CMD;
1709    L->m[5].data=(void *)mpCopy(r->nc->D);
1710  }
1711  #endif
1712  return L;
1713}
1714
1715ring rCompose(const lists  L)
1716{
1717  if ((L->nr!=3)
1718#ifdef HAVE_PLURAL
1719  &&(L->nr!=5)
1720#endif
1721  )
1722    return NULL;
1723  // 0: char/ cf - ring
1724  // 1: list (var)
1725  // 2: list (ord)
1726  // 3: qideal
1727  // possibly:
1728  // 4: C
1729  // 5: D
1730  ring R=(ring) omAlloc0Bin(sip_sring_bin);
1731  if (L->m[0].Typ()==INT_CMD)
1732  {
1733    R->ch=(int)L->m[0].Data();
1734  }
1735  else if (L->m[0].Typ()==LIST_CMD)
1736  {
1737    R->algring=rCompose((lists)L->m[0].Data());
1738    if (R->algring==NULL)
1739    {
1740      WerrorS("could not create rational function coefficient field");
1741      goto rCompose_err;
1742    }
1743    if (R->algring->ch>0)
1744       R->ch= -R->algring->ch;
1745    else
1746       R->ch=1;
1747    R->P=R->algring->N;
1748    R->parameter=(char**)omAlloc0(R->P*sizeof(char_ptr));
1749    int i;
1750    for(i=R->P-1;i>=0;i--)
1751      R->parameter[i]=omStrDup(R->algring->names[i]);
1752    if (R->algring->qideal!=NULL)
1753    {
1754      R->minpoly=pGetCoeff(R->algring->qideal->m[0]);
1755    }
1756  }
1757  else
1758  {
1759    WerrorS("coefficient field must be described by `int` or `list`");
1760    goto rCompose_err;
1761  }
1762  // ------------------------- VARS ---------------------------
1763  if (L->m[1].Typ()==LIST_CMD)
1764  {
1765    lists v=(lists)L->m[1].Data();
1766    R->N = v->nr+1;
1767    R->names   = (char **)omAlloc0(R->N * sizeof(char_ptr));
1768    int i;
1769    for(i=0;i<R->N;i++)
1770    {
1771      if (v->m[i].Typ()==STRING_CMD)
1772        R->names[i]=omStrDup((char *)v->m[i].Data());
1773      else if (v->m[i].Typ()==POLY_CMD)
1774      {
1775        poly p=(poly)v->m[i].Data();
1776        int nr=pIsPurePower(p);
1777        if (nr>0)
1778          R->names[i]=omStrDup(currRing->names[nr-1]);
1779        else
1780        {
1781          Werror("var name %d must be a string or a ring variable",i+1);
1782          goto rCompose_err;
1783        }
1784      }
1785      else
1786      {
1787        Werror("var name %d must be `string`",i+1);
1788        goto rCompose_err;
1789      }
1790    }
1791  }
1792  else
1793  {
1794    WerrorS("variable must be given as `list`");
1795    goto rCompose_err;
1796  }
1797  // ------------------------ ORDER ------------------------------
1798  if (L->m[2].Typ()==LIST_CMD)
1799  {
1800    lists v=(lists)L->m[2].Data();
1801    int n= v->nr+2;
1802    int j;
1803    // initialize fields of R
1804    R->order=(int *)omAlloc0(n*sizeof(int));
1805    R->block0=(int *)omAlloc0(n*sizeof(int));
1806    R->block1=(int *)omAlloc0(n*sizeof(int));
1807    R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
1808    // init order, so that rBlocks works correctly
1809    for (j=0; j < n-2; j++)
1810      R->order[j] = (int) ringorder_unspec;
1811    // orderings
1812    R->OrdSgn=1;
1813    for(j=0;j<n-1;j++)
1814    {
1815    // todo: a(..), M
1816      if (v->m[j].Typ()!=LIST_CMD)
1817      {
1818        WerrorS("ordering must be list of lists");
1819        goto rCompose_err;
1820      }
1821      lists vv=(lists)v->m[j].Data();
1822      if ((vv->nr!=1)
1823      || (vv->m[0].Typ()!=STRING_CMD)
1824      || ((vv->m[1].Typ()!=INTVEC_CMD) && (vv->m[1].Typ()!=INT_CMD)))
1825      {
1826        WerrorS("ordering name must be a (string,intvec)");
1827        goto rCompose_err;
1828      }
1829      R->order[j]=rOrderName(omStrDup((char*)vv->m[0].Data())); // assume STRING
1830      if (j==0) R->block0[0]=1;
1831      else      R->block0[j]=R->block1[j-1]+1;
1832      intvec *iv;
1833      if (vv->m[1].Typ()==INT_CMD)
1834        iv=new intvec((int)vv->m[1].Data(),(int)vv->m[1].Data());
1835      else
1836        iv=ivCopy((intvec*)vv->m[1].Data()); //assume INTVEC
1837      R->block1[j]=max(R->block0[j],R->block0[j]+iv->length()-1);
1838      int i;
1839      switch (R->order[j])
1840      {
1841         case ringorder_ws:
1842         case ringorder_Ws:
1843            R->OrdSgn=-1;
1844         case ringorder_wp:
1845         case ringorder_Wp:
1846           R->wvhdl[j] =( int *)omAlloc((iv->length())*sizeof(int));
1847           for (i=0; i<iv->length();i++) R->wvhdl[j][i]=(*iv)[i];
1848           break;
1849         case ringorder_ls:
1850         case ringorder_ds:
1851         case ringorder_Ds:
1852           R->OrdSgn=-1;
1853         case ringorder_lp:
1854         case ringorder_dp:
1855         case ringorder_Dp:
1856         case ringorder_rp:
1857           break;
1858         case ringorder_S:
1859           break;
1860         case ringorder_c:
1861         case ringorder_C:
1862           R->block1[j]=R->block0[j]-1;
1863           break;
1864         case ringorder_aa:
1865         case ringorder_a:
1866           R->wvhdl[j] =( int *)omAlloc((iv->length())*sizeof(int));
1867           for (i=1; i<iv->length();i++) R->wvhdl[n][i-1]=(*iv)[i];
1868         // todo
1869           break;
1870         case ringorder_M:
1871         // todo
1872           break;
1873      }
1874    }
1875    // sanity check
1876    j=n-2;
1877    if ((R->order[j]==ringorder_c)
1878    || (R->order[j]==ringorder_C)) j--;
1879    if (R->block1[j] != R->N)
1880    {
1881      if (((R->order[j]==ringorder_dp) ||
1882           (R->order[j]==ringorder_ds) ||
1883           (R->order[j]==ringorder_Dp) ||
1884           (R->order[j]==ringorder_Ds) ||
1885           (R->order[j]==ringorder_rp) ||
1886           (R->order[j]==ringorder_lp) ||
1887           (R->order[j]==ringorder_ls))
1888          &&
1889            R->block0[j] <= R->N)
1890      {
1891        R->block1[j] = R->N;
1892      }
1893      else
1894      {
1895        Werror("ordering incomplete: size (%d) should be %d",R->block1[j],R->N);
1896        goto rCompose_err;
1897      }
1898    }
1899  }
1900  else
1901  {
1902    WerrorS("ordering must be given as `list`");
1903    goto rCompose_err;
1904  }
1905  // ------------------------ Q-IDEAL ------------------------
1906  if (L->m[3].Typ()==IDEAL_CMD)
1907  {
1908    ideal q=(ideal)L->m[3].Data();
1909    if (q->m[0]!=NULL)
1910      R->qideal=idCopy(q);
1911  }
1912  else
1913  {
1914    WerrorS("q-ideal must be given as `ideal`");
1915    goto rCompose_err;
1916  }
1917
1918  // todo
1919  rComplete(R);
1920
1921  // ---------------------------------------------------------------
1922  #ifdef HAVE_PLURAL
1923  if (L->nr==5)
1924  {
1925    if (nc_CallPlural((matrix)L->m[4].Data(),(matrix)L->m[5].Data(),
1926        NULL,NULL,R))
1927      goto rCompose_err;
1928  }
1929  #endif
1930  return R;
1931
1932rCompose_err:
1933  if (R->N>0)
1934  {
1935    int i;
1936    if (R->names!=NULL)
1937    {
1938      i=R->N-1;
1939      while (i>=0) { if (R->names[i]!=NULL) omFree(R->names[i]); i--; }
1940      omFree(R->names);
1941    }
1942  }
1943  if (R->order!=NULL) omFree(R->order);
1944  if (R->block0!=NULL) omFree(R->block0);
1945  if (R->block1!=NULL) omFree(R->block1);
1946  if (R->wvhdl!=NULL) omFree(R->wvhdl);
1947  omFree(R);
1948  return NULL;
1949}
1950
1951// from matpol.cc
1952
1953/*2
1954* compute the jacobi matrix of an ideal
1955*/
1956BOOLEAN mpJacobi(leftv res,leftv a)
1957{
1958  int     i,j;
1959  matrix result;
1960  ideal id=(ideal)a->Data();
1961
1962  result =mpNew(IDELEMS(id),pVariables);
1963  for (i=1; i<=IDELEMS(id); i++)
1964  {
1965    for (j=1; j<=pVariables; j++)
1966    {
1967      MATELEM(result,i,j) = pDiff(id->m[i-1],j);
1968    }
1969  }
1970  res->data=(char *)result;
1971  return FALSE;
1972}
1973
1974/*2
1975* returns the Koszul-matrix of degree d of a vectorspace with dimension n
1976* uses the first n entrees of id, if id <> NULL
1977*/
1978BOOLEAN mpKoszul(leftv res,leftv c/*ip*/, leftv b/*in*/, leftv id)
1979{
1980  int n=(int)b->Data();
1981  int d=(int)c->Data();
1982  int     k,l,sign,row,col;
1983  matrix  result;
1984  ideal temp;
1985  BOOLEAN bo;
1986  poly    p;
1987
1988  if ((d>n) || (d<1) || (n<1))
1989  {
1990    res->data=(char *)mpNew(1,1);
1991    return FALSE;
1992  }
1993  int *choise = (int*)omAlloc(d*sizeof(int));
1994  if (id==NULL)
1995    temp=idMaxIdeal(1);
1996  else
1997    temp=(ideal)id->Data();
1998
1999  k = binom(n,d);
2000  l = k*d;
2001  l /= n-d+1;
2002  result =mpNew(l,k);
2003  col = 1;
2004  idInitChoise(d,1,n,&bo,choise);
2005  while (!bo)
2006  {
2007    sign = 1;
2008    for (l=1;l<=d;l++)
2009    {
2010      if (choise[l-1]<=IDELEMS(temp))
2011      {
2012        p = pCopy(temp->m[choise[l-1]-1]);
2013        if (sign == -1) p = pNeg(p);
2014        sign *= -1;
2015        row = idGetNumberOfChoise(l-1,d,1,n,choise);
2016        MATELEM(result,row,col) = p;
2017      }
2018    }
2019    col++;
2020    idGetNextChoise(d,n,&bo,choise);
2021  }
2022  if (id==NULL) idDelete(&temp);
2023
2024  res->data=(char *)result;
2025  return FALSE;
2026}
2027
2028// from syz1.cc
2029/*2
2030* read out the Betti numbers from resolution
2031* (interpreter interface)
2032*/
2033BOOLEAN syBetti2(leftv res, leftv u, leftv w)
2034{
2035  syStrategy syzstr=(syStrategy)u->Data();
2036  BOOLEAN minim=(int)w->Data();
2037  int row_shift=0;
2038  int add_row_shift=0;
2039  intvec *weights=NULL;
2040  intvec *ww=(intvec *)atGet(u,"isHomog",INTVEC_CMD);
2041  if (ww!=NULL)
2042  {
2043     weights=ivCopy(ww);
2044     add_row_shift = ww->min_in();
2045     (*weights) -= add_row_shift;
2046  }
2047  res->data=(void *)syBettiOfComputation(syzstr,minim,&row_shift,weights);
2048  //row_shift += add_row_shift;
2049  //Print("row_shift=%d, add_row_shift=%d\n",row_shift,add_row_shift);
2050  atSet(res,omStrDup("rowShift"),(void*)add_row_shift,INT_CMD);
2051  return FALSE;
2052}
2053BOOLEAN syBetti1(leftv res, leftv u)
2054{
2055  sleftv tmp;
2056  memset(&tmp,0,sizeof(tmp));
2057  tmp.rtyp=INT_CMD;
2058  tmp.data=(void *)1; 
2059  return syBetti2(res,u,&tmp);
2060}
2061
2062/*3
2063* converts a resolution into a list of modules
2064*/
2065lists syConvRes(syStrategy syzstr,BOOLEAN toDel)
2066{
2067  if ((syzstr->fullres==NULL) && (syzstr->minres==NULL))
2068  {
2069    if (syzstr->hilb_coeffs==NULL)
2070    {
2071      syzstr->fullres = syReorder(syzstr->res,syzstr->length,syzstr);
2072    }
2073    else
2074    {
2075      syzstr->minres = syReorder(syzstr->orderedRes,syzstr->length,syzstr);
2076      syKillEmptyEntres(syzstr->minres,syzstr->length);
2077    }
2078  }
2079  resolvente tr;
2080  int typ0=IDEAL_CMD;
2081  if (syzstr->minres!=NULL)
2082    tr = syzstr->minres;
2083  else
2084    tr = syzstr->fullres;
2085  resolvente trueres=NULL;
2086  intvec ** w=NULL;
2087  if (syzstr->length>0)
2088  {
2089    trueres=(resolvente)omAlloc0((syzstr->length)*sizeof(ideal));
2090    for (int i=(syzstr->length)-1;i>=0;i--)
2091    {
2092      if (tr[i]!=NULL)
2093      {
2094        trueres[i] = idCopy(tr[i]);
2095      }
2096    }
2097    if (idRankFreeModule(trueres[0]) > 0)
2098      typ0 = MODUL_CMD;
2099    if (syzstr->weights!=NULL)
2100    {
2101      w = (intvec**)omAlloc0((syzstr->length)*sizeof(intvec*));
2102      for (int i=(syzstr->length)-1;i>=0;i--)
2103      {
2104        if (syzstr->weights[i]!=NULL) w[i] = ivCopy(syzstr->weights[i]);
2105      }
2106    }
2107  }
2108  lists li = liMakeResolv(trueres,syzstr->length,syzstr->list_length,typ0,w);
2109  if (w != NULL) omFreeSize(w, (syzstr->length)*sizeof(intvec*));
2110  if (toDel) syKillComputation(syzstr);
2111  return li;
2112}
2113
2114/*3
2115* converts a list of modules into a resolution
2116*/
2117syStrategy syConvList(lists li,BOOLEAN toDel)
2118{
2119  int typ0;
2120  syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
2121
2122  resolvente fr = liFindRes(li,&(result->length),&typ0,&(result->weights));
2123  if (fr != NULL)
2124  {
2125
2126    result->fullres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
2127    for (int i=result->length-1;i>=0;i--)
2128    {
2129      if (fr[i]!=NULL)
2130        result->fullres[i] = idCopy(fr[i]);
2131    }
2132    result->list_length=result->length;
2133    omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
2134  }
2135  else
2136  {
2137    omFreeSize(result, sizeof(ssyStrategy));
2138    result = NULL;
2139  }
2140  if (toDel) li->Clean();
2141  return result;
2142}
2143
2144/*3
2145* converts a list of modules into a minimal resolution
2146*/
2147syStrategy syForceMin(lists li)
2148{
2149  int typ0;
2150  syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
2151
2152  resolvente fr = liFindRes(li,&(result->length),&typ0);
2153  result->minres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
2154  for (int i=result->length-1;i>=0;i--)
2155  {
2156    if (fr[i]!=NULL)
2157      result->minres[i] = idCopy(fr[i]);
2158  }
2159  omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
2160  return result;
2161}
2162// from weight.cc
2163BOOLEAN kWeight(leftv res,leftv id)
2164{
2165  ideal F=(ideal)id->Data();
2166  intvec * iv = new intvec(pVariables);
2167  polyset s;
2168  int  sl, n, i;
2169  int  *x;
2170
2171  res->data=(char *)iv;
2172  s = F->m;
2173  sl = IDELEMS(F) - 1;
2174  n = pVariables;
2175  wNsqr = (double)2.0 / (double)n;
2176  wFunctional = wFunctionalBuch;
2177  x = (int * )omAlloc(2 * (n + 1) * sizeof(int));
2178  wCall(s, sl, x);
2179  for (i = n; i!=0; i--)
2180    (*iv)[i-1] = x[i + n + 1];
2181  omFreeSize((ADDRESS)x, 2 * (n + 1) * sizeof(int));
2182  return FALSE;
2183}
2184
2185BOOLEAN kQHWeight(leftv res,leftv v)
2186{
2187  res->data=(char *)idQHomWeight((ideal)v->Data());
2188  if (res->data==NULL)
2189    res->data=(char *)new intvec(pVariables);
2190  return FALSE;
2191}
2192/*==============================================================*/
2193// from clapsing.cc
2194#if 0
2195BOOLEAN jjIS_SQR_FREE(leftv res, leftv u)
2196{
2197  BOOLEAN b=singclap_factorize((poly)(u->Data()), &v, 0);
2198  res->data=(void *)b;
2199}
2200#endif
2201
2202BOOLEAN jjRESULTANT(leftv res, leftv u, leftv v, leftv w)
2203{
2204  res->data=singclap_resultant((poly)u->Data(),(poly)v->Data(), (poly)w->Data());
2205  return errorreported;
2206}
2207BOOLEAN jjCHARSERIES(leftv res, leftv u)
2208{
2209  res->data=singclap_irrCharSeries((ideal)u->Data());
2210  return (res->data==NULL);
2211}
2212
2213// from semic.cc
2214#ifdef HAVE_SPECTRUM
2215
2216// ----------------------------------------------------------------------------
2217//  Initialize a  spectrum  deep from another  spectrum
2218// ----------------------------------------------------------------------------
2219
2220void spectrum::copy_deep( const spectrum &spec )
2221{
2222    mu = spec.mu;
2223    pg = spec.pg;
2224    n  = spec.n;
2225
2226    copy_new( n );
2227
2228    for( int i=0; i<n; i++ )
2229    {
2230        s[i] = spec.s[i];
2231        w[i] = spec.w[i];
2232    }
2233}
2234
2235// ----------------------------------------------------------------------------
2236//  Initialize a  spectrum  deep from a  singular  lists
2237// ----------------------------------------------------------------------------
2238
2239void spectrum::copy_deep( lists l )
2240{
2241    mu = (int)(l->m[0].Data( ));
2242    pg = (int)(l->m[1].Data( ));
2243    n  = (int)(l->m[2].Data( ));
2244
2245    copy_new( n );
2246
2247    intvec  *num = (intvec*)l->m[3].Data( );
2248    intvec  *den = (intvec*)l->m[4].Data( );
2249    intvec  *mul = (intvec*)l->m[5].Data( );
2250
2251    for( int i=0; i<n; i++ )
2252    {
2253        s[i] = (Rational)((*num)[i])/(Rational)((*den)[i]);
2254        w[i] = (*mul)[i];
2255    }
2256}
2257
2258// ----------------------------------------------------------------------------
2259//  singular lists  constructor for  spectrum
2260// ----------------------------------------------------------------------------
2261
2262spectrum::spectrum( lists l )
2263{
2264    copy_deep( l );
2265}
2266
2267// ----------------------------------------------------------------------------
2268//  generate a Singular  lists  from a spectrum
2269// ----------------------------------------------------------------------------
2270
2271lists   spectrum::thelist( void )
2272{
2273    lists   L  = (lists)omAllocBin( slists_bin);
2274
2275    L->Init( 6 );
2276
2277    intvec            *num  = new intvec( n );
2278    intvec            *den  = new intvec( n );
2279    intvec            *mult = new intvec( n );
2280
2281    for( int i=0; i<n; i++ )
2282    {
2283        (*num) [i] = s[i].get_num_si( );
2284        (*den) [i] = s[i].get_den_si( );
2285        (*mult)[i] = w[i];
2286    }
2287
2288    L->m[0].rtyp = INT_CMD;    //  milnor number
2289    L->m[1].rtyp = INT_CMD;    //  geometrical genus
2290    L->m[2].rtyp = INT_CMD;    //  # of spectrum numbers
2291    L->m[3].rtyp = INTVEC_CMD; //  numerators
2292    L->m[4].rtyp = INTVEC_CMD; //  denomiantors
2293    L->m[5].rtyp = INTVEC_CMD; //  multiplicities
2294
2295    L->m[0].data = (void*)mu;
2296    L->m[1].data = (void*)pg;
2297    L->m[2].data = (void*)n;
2298    L->m[3].data = (void*)num;
2299    L->m[4].data = (void*)den;
2300    L->m[5].data = (void*)mult;
2301
2302    return  L;
2303}
2304// from spectrum.cc
2305// ----------------------------------------------------------------------------
2306//  print out an error message for a spectrum list
2307// ----------------------------------------------------------------------------
2308
2309void    list_error( semicState state )
2310{
2311    switch( state )
2312    {
2313        case semicListTooShort:
2314            WerrorS( "the list is too short" );
2315            break;
2316        case semicListTooLong:
2317            WerrorS( "the list is too long" );
2318            break;
2319
2320        case semicListFirstElementWrongType:
2321            WerrorS( "first element of the list should be int" );
2322            break;
2323        case semicListSecondElementWrongType:
2324            WerrorS( "second element of the list should be int" );
2325            break;
2326        case semicListThirdElementWrongType:
2327            WerrorS( "third element of the list should be int" );
2328            break;
2329        case semicListFourthElementWrongType:
2330            WerrorS( "fourth element of the list should be intvec" );
2331            break;
2332        case semicListFifthElementWrongType:
2333            WerrorS( "fifth element of the list should be intvec" );
2334            break;
2335        case semicListSixthElementWrongType:
2336            WerrorS( "sixth element of the list should be intvec" );
2337            break;
2338
2339        case semicListNNegative:
2340            WerrorS( "first element of the list should be positive" );
2341            break;
2342        case semicListWrongNumberOfNumerators:
2343            WerrorS( "wrong number of numerators" );
2344            break;
2345        case semicListWrongNumberOfDenominators:
2346            WerrorS( "wrong number of denominators" );
2347            break;
2348        case semicListWrongNumberOfMultiplicities:
2349            WerrorS( "wrong number of multiplicities" );
2350            break;
2351
2352        case semicListMuNegative:
2353            WerrorS( "the Milnor number should be positive" );
2354            break;
2355        case semicListPgNegative:
2356            WerrorS( "the geometrical genus should be nonnegative" );
2357            break;
2358        case semicListNumNegative:
2359            WerrorS( "all numerators should be positive" );
2360            break;
2361        case semicListDenNegative:
2362            WerrorS( "all denominators should be positive" );
2363            break;
2364        case semicListMulNegative:
2365            WerrorS( "all multiplicities should be positive" );
2366            break;
2367
2368        case semicListNotSymmetric:
2369            WerrorS( "it is not symmetric" );
2370            break;
2371        case semicListNotMonotonous:
2372            WerrorS( "it is not monotonous" );
2373            break;
2374
2375        case semicListMilnorWrong:
2376            WerrorS( "the Milnor number is wrong" );
2377            break;
2378        case semicListPGWrong:
2379            WerrorS( "the geometrical genus is wrong" );
2380            break;
2381
2382        default:
2383            WerrorS( "unspecific error" );
2384            break;
2385    }
2386}
2387// ----------------------------------------------------------------------------
2388//  this is the main spectrum computation function
2389// ----------------------------------------------------------------------------
2390
2391spectrumState   spectrumCompute( poly h,lists *L,int fast )
2392{
2393  int i,j;
2394
2395  #ifdef SPECTRUM_DEBUG
2396  #ifdef SPECTRUM_PRINT
2397  #ifdef SPECTRUM_IOSTREAM
2398    cout << "spectrumCompute\n";
2399    if( fast==0 ) cout << "    no optimization" << endl;
2400    if( fast==1 ) cout << "    weight optimization" << endl;
2401    if( fast==2 ) cout << "    symmetry optimization" << endl;
2402  #else
2403    fprintf( stdout,"spectrumCompute\n" );
2404    if( fast==0 ) fprintf( stdout,"    no optimization\n" );
2405    if( fast==1 ) fprintf( stdout,"    weight optimization\n" );
2406    if( fast==2 ) fprintf( stdout,"    symmetry optimization\n" );
2407  #endif
2408  #endif
2409  #endif
2410
2411  // ----------------------
2412  //  check if  h  is zero
2413  // ----------------------
2414
2415  if( h==(poly)NULL )
2416  {
2417    return  spectrumZero;
2418  }
2419
2420  // ----------------------------------
2421  //  check if  h  has a constant term
2422  // ----------------------------------
2423
2424  if( hasConstTerm( h ) )
2425  {
2426    return  spectrumBadPoly;
2427  }
2428
2429  // --------------------------------
2430  //  check if  h  has a linear term
2431  // --------------------------------
2432
2433  if( hasLinearTerm( h ) )
2434  {
2435    *L = (lists)omAllocBin( slists_bin);
2436    (*L)->Init( 1 );
2437    (*L)->m[0].rtyp = INT_CMD;    //  milnor number
2438    /* (*L)->m[0].data = (void*)0;a  -- done by Init */
2439
2440    return  spectrumNoSingularity;
2441  }
2442
2443  // ----------------------------------
2444  //  compute the jacobi ideal of  (h)
2445  // ----------------------------------
2446
2447  ideal J = NULL;
2448  J = idInit( pVariables,1 );
2449
2450  #ifdef SPECTRUM_DEBUG
2451  #ifdef SPECTRUM_PRINT
2452  #ifdef SPECTRUM_IOSTREAM
2453    cout << "\n   computing the Jacobi ideal...\n";
2454  #else
2455    fprintf( stdout,"\n   computing the Jacobi ideal...\n" );
2456  #endif
2457  #endif
2458  #endif
2459
2460  for( i=0; i<pVariables; i++ )
2461  {
2462    J->m[i] = pDiff( h,i+1); //j );
2463
2464    #ifdef SPECTRUM_DEBUG
2465    #ifdef SPECTRUM_PRINT
2466    #ifdef SPECTRUM_IOSTREAM
2467      cout << "        ";
2468    #else
2469      fprintf( stdout,"        " );
2470    #endif
2471      pWrite( J->m[i] );
2472    #endif
2473    #endif
2474  }
2475
2476  // --------------------------------------------
2477  //  compute a standard basis  stdJ  of  jac(h)
2478  // --------------------------------------------
2479
2480  #ifdef SPECTRUM_DEBUG
2481  #ifdef SPECTRUM_PRINT
2482  #ifdef SPECTRUM_IOSTREAM
2483    cout << endl;
2484    cout << "    computing a standard basis..." << endl;
2485  #else
2486    fprintf( stdout,"\n" );
2487    fprintf( stdout,"    computing a standard basis...\n" );
2488  #endif
2489  #endif
2490  #endif
2491
2492  ideal stdJ = kStd(J,currQuotient,isNotHomog,NULL);
2493  idSkipZeroes( stdJ );
2494
2495  #ifdef SPECTRUM_DEBUG
2496  #ifdef SPECTRUM_PRINT
2497    for( i=0; i<IDELEMS(stdJ); i++ )
2498    {
2499      #ifdef SPECTRUM_IOSTREAM
2500        cout << "        ";
2501      #else
2502        fprintf( stdout,"        " );
2503      #endif
2504
2505      pWrite( stdJ->m[i] );
2506    }
2507  #endif
2508  #endif
2509
2510  idDelete( &J );
2511
2512  // ------------------------------------------
2513  //  check if the  h  has a singularity
2514  // ------------------------------------------
2515
2516  if( hasOne( stdJ ) )
2517  {
2518    // -------------------------------
2519    //  h is smooth in the origin
2520    //  return only the Milnor number
2521    // -------------------------------
2522
2523    *L = (lists)omAllocBin( slists_bin);
2524    (*L)->Init( 1 );
2525    (*L)->m[0].rtyp = INT_CMD;    //  milnor number
2526    /* (*L)->m[0].data = (void*)0;a  -- done by Init */
2527
2528    return  spectrumNoSingularity;
2529  }
2530
2531  // ------------------------------------------
2532  //  check if the singularity  h  is isolated
2533  // ------------------------------------------
2534
2535  for( i=pVariables; i>0; i-- )
2536  {
2537    if( hasAxis( stdJ,i )==FALSE )
2538    {
2539      return  spectrumNotIsolated;
2540    }
2541  }
2542
2543  // ------------------------------------------
2544  //  compute the highest corner  hc  of  stdJ
2545  // ------------------------------------------
2546
2547  #ifdef SPECTRUM_DEBUG
2548  #ifdef SPECTRUM_PRINT
2549  #ifdef SPECTRUM_IOSTREAM
2550    cout << "\n    computing the highest corner...\n";
2551  #else
2552    fprintf( stdout,"\n    computing the highest corner...\n" );
2553  #endif
2554  #endif
2555  #endif
2556
2557  poly hc = (poly)NULL;
2558
2559  scComputeHC( stdJ,currQuotient, 0,hc );
2560
2561  if( hc!=(poly)NULL )
2562  {
2563    pGetCoeff(hc) = nInit(1);
2564
2565    for( i=pVariables; i>0; i-- )
2566    {
2567      if( pGetExp( hc,i )>0 ) pDecrExp( hc,i );
2568    }
2569    pSetm( hc );
2570  }
2571  else
2572  {
2573    return  spectrumNoHC;
2574  }
2575
2576  #ifdef SPECTRUM_DEBUG
2577  #ifdef SPECTRUM_PRINT
2578  #ifdef SPECTRUM_IOSTREAM
2579    cout << "       ";
2580  #else
2581    fprintf( stdout,"       " );
2582  #endif
2583    pWrite( hc );
2584  #endif
2585  #endif
2586
2587  // ----------------------------------------
2588  //  compute the Newton polygon  nph  of  h
2589  // ----------------------------------------
2590
2591  #ifdef SPECTRUM_DEBUG
2592  #ifdef SPECTRUM_PRINT
2593  #ifdef SPECTRUM_IOSTREAM
2594    cout << "\n    computing the newton polygon...\n";
2595  #else
2596    fprintf( stdout,"\n    computing the newton polygon...\n" );
2597  #endif
2598  #endif
2599  #endif
2600
2601  newtonPolygon nph( h );
2602
2603  #ifdef SPECTRUM_DEBUG
2604  #ifdef SPECTRUM_PRINT
2605    cout << nph;
2606  #endif
2607  #endif
2608
2609  // -----------------------------------------------
2610  //  compute the weight corner  wc  of  (stdj,nph)
2611  // -----------------------------------------------
2612
2613  #ifdef SPECTRUM_DEBUG
2614  #ifdef SPECTRUM_PRINT
2615  #ifdef SPECTRUM_IOSTREAM
2616    cout << "\n    computing the weight corner...\n";
2617  #else
2618    fprintf( stdout,"\n    computing the weight corner...\n" );
2619  #endif
2620  #endif
2621  #endif
2622
2623  poly    wc = ( fast==0 ? pCopy( hc ) :
2624               ( fast==1 ? computeWC( nph,(Rational)pVariables ) :
2625              /* fast==2 */computeWC( nph,((Rational)pVariables)/(Rational)2 ) ) );
2626
2627  #ifdef SPECTRUM_DEBUG
2628  #ifdef SPECTRUM_PRINT
2629  #ifdef SPECTRUM_IOSTREAM
2630    cout << "        ";
2631  #else
2632    fprintf( stdout,"        " );
2633  #endif
2634    pWrite( wc );
2635  #endif
2636  #endif
2637
2638  // -------------
2639  //  compute  NF
2640  // -------------
2641
2642  #ifdef SPECTRUM_DEBUG
2643  #ifdef SPECTRUM_PRINT
2644  #ifdef SPECTRUM_IOSTREAM
2645    cout << "\n    computing NF...\n" << endl;
2646  #else
2647    fprintf( stdout,"\n    computing NF...\n" );
2648  #endif
2649  #endif
2650  #endif
2651
2652  spectrumPolyList NF( &nph );
2653
2654  computeNF( stdJ,hc,wc,&NF );
2655
2656  #ifdef SPECTRUM_DEBUG
2657  #ifdef SPECTRUM_PRINT
2658    cout << NF;
2659  #ifdef SPECTRUM_IOSTREAM
2660    cout << endl;
2661  #else
2662    fprintf( stdout,"\n" );
2663  #endif
2664  #endif
2665  #endif
2666
2667  // ----------------------------
2668  //  compute the spectrum of  h
2669  // ----------------------------
2670
2671  return  NF.spectrum( L,fast );
2672}
2673
2674// ----------------------------------------------------------------------------
2675//  this procedure is called from the interpreter
2676// ----------------------------------------------------------------------------
2677//  first  = polynomial
2678//  result = list of spectrum numbers
2679// ----------------------------------------------------------------------------
2680
2681BOOLEAN spectrumProc( leftv result,leftv first )
2682{
2683  spectrumState state = spectrumOK;
2684
2685  // -------------------
2686  //  check consistency
2687  // -------------------
2688
2689  //  check for a local ring
2690
2691  if( !ringIsLocal( ) )
2692  {
2693    WerrorS( "only works for local orderings" );
2694    state = spectrumWrongRing;
2695  }
2696
2697  //  no quotient rings are allowed
2698
2699  else if( currRing->qideal != NULL )
2700  {
2701    WerrorS( "does not work in quotient rings" );
2702    state = spectrumWrongRing;
2703  }
2704  else
2705  {
2706    lists   L    = (lists)NULL;
2707    int     flag = 1; // weight corner optimization is safe
2708
2709    state = spectrumCompute( (poly)first->Data( ),&L,flag );
2710
2711    if( state==spectrumOK )
2712    {
2713      result->rtyp = LIST_CMD;
2714      result->data = (char*)L;
2715    }
2716    else
2717    {
2718      spectrumPrintError(state);
2719    }
2720  }
2721
2722  return  (state!=spectrumOK);
2723}
2724
2725// ----------------------------------------------------------------------------
2726//  this procedure is called from the interpreter
2727// ----------------------------------------------------------------------------
2728//  first  = polynomial
2729//  result = list of spectrum numbers
2730// ----------------------------------------------------------------------------
2731
2732BOOLEAN spectrumfProc( leftv result,leftv first )
2733{
2734  spectrumState state = spectrumOK;
2735
2736  // -------------------
2737  //  check consistency
2738  // -------------------
2739
2740  //  check for a local polynomial ring
2741
2742  if( currRing->OrdSgn != -1 )
2743  // ?? HS: the test above is also true for k[x][[y]], k[[x]][y]
2744  // or should we use:
2745  //if( !ringIsLocal( ) )
2746  {
2747    WerrorS( "only works for local orderings" );
2748    state = spectrumWrongRing;
2749  }
2750  else if( currRing->qideal != NULL )
2751  {
2752    WerrorS( "does not work in quotient rings" );
2753    state = spectrumWrongRing;
2754  }
2755  else
2756  {
2757    lists   L    = (lists)NULL;
2758    int     flag = 2; // symmetric optimization
2759
2760    state = spectrumCompute( (poly)first->Data( ),&L,flag );
2761
2762    if( state==spectrumOK )
2763    {
2764      result->rtyp = LIST_CMD;
2765      result->data = (char*)L;
2766    }
2767    else
2768    {
2769      spectrumPrintError(state);
2770    }
2771  }
2772
2773  return  (state!=spectrumOK);
2774}
2775
2776// ----------------------------------------------------------------------------
2777//  check if a list is a spectrum
2778//  check for:
2779//      list has 6 elements
2780//      1st element is int (mu=Milnor number)
2781//      2nd element is int (pg=geometrical genus)
2782//      3rd element is int (n =number of different spectrum numbers)
2783//      4th element is intvec (num=numerators)
2784//      5th element is intvec (den=denomiantors)
2785//      6th element is intvec (mul=multiplicities)
2786//      exactly n numerators
2787//      exactly n denominators
2788//      exactly n multiplicities
2789//      mu>0
2790//      pg>=0
2791//      n>0
2792//      num>0
2793//      den>0
2794//      mul>0
2795//      symmetriy with respect to numberofvariables/2
2796//      monotony
2797//      mu = sum of all multiplicities
2798//      pg = sum of all multiplicities where num/den<=1
2799// ----------------------------------------------------------------------------
2800
2801semicState  list_is_spectrum( lists l )
2802{
2803    // -------------------
2804    //  check list length
2805    // -------------------
2806
2807    if( l->nr < 5 )
2808    {
2809        return  semicListTooShort;
2810    }
2811    else if( l->nr > 5 )
2812    {
2813        return  semicListTooLong;
2814    }
2815
2816    // -------------
2817    //  check types
2818    // -------------
2819
2820    if( l->m[0].rtyp != INT_CMD )
2821    {
2822        return  semicListFirstElementWrongType;
2823    }
2824    else if( l->m[1].rtyp != INT_CMD )
2825    {
2826        return  semicListSecondElementWrongType;
2827    }
2828    else if( l->m[2].rtyp != INT_CMD )
2829    {
2830        return  semicListThirdElementWrongType;
2831    }
2832    else if( l->m[3].rtyp != INTVEC_CMD )
2833    {
2834        return  semicListFourthElementWrongType;
2835    }
2836    else if( l->m[4].rtyp != INTVEC_CMD )
2837    {
2838        return  semicListFifthElementWrongType;
2839    }
2840    else if( l->m[5].rtyp != INTVEC_CMD )
2841    {
2842        return  semicListSixthElementWrongType;
2843    }
2844
2845    // -------------------------
2846    //  check number of entries
2847    // -------------------------
2848
2849    int     mu = (int)(l->m[0].Data( ));
2850    int     pg = (int)(l->m[1].Data( ));
2851    int     n  = (int)(l->m[2].Data( ));
2852
2853    if( n <= 0 )
2854    {
2855        return  semicListNNegative;
2856    }
2857
2858    intvec  *num = (intvec*)l->m[3].Data( );
2859    intvec  *den = (intvec*)l->m[4].Data( );
2860    intvec  *mul = (intvec*)l->m[5].Data( );
2861
2862    if( n != num->length( ) )
2863    {
2864        return  semicListWrongNumberOfNumerators;
2865    }
2866    else if( n != den->length( ) )
2867    {
2868        return  semicListWrongNumberOfDenominators;
2869    }
2870    else if( n != mul->length( ) )
2871    {
2872        return  semicListWrongNumberOfMultiplicities;
2873    }
2874
2875    // --------
2876    //  values
2877    // --------
2878
2879    if( mu <= 0 )
2880    {
2881        return  semicListMuNegative;
2882    }
2883    if( pg < 0 )
2884    {
2885        return  semicListPgNegative;
2886    }
2887
2888    int i;
2889
2890    for( i=0; i<n; i++ )
2891    {
2892        if( (*num)[i] <= 0 )
2893        {
2894            return  semicListNumNegative;
2895        }
2896        if( (*den)[i] <= 0 )
2897        {
2898            return  semicListDenNegative;
2899        }
2900        if( (*mul)[i] <= 0 )
2901        {
2902            return  semicListMulNegative;
2903        }
2904    }
2905
2906    // ----------------
2907    //  check symmetry
2908    // ----------------
2909
2910    int     j;
2911
2912    for( i=0, j=n-1; i<=j; i++,j-- )
2913    {
2914        if( (*num)[i] != pVariables*((*den)[i]) - (*num)[j] ||
2915            (*den)[i] != (*den)[j] ||
2916            (*mul)[i] != (*mul)[j] )
2917        {
2918            return  semicListNotSymmetric;
2919        }
2920    }
2921
2922    // ----------------
2923    //  check monotony
2924    // ----------------
2925
2926    for( i=0, j=1; i<n/2; i++,j++ )
2927    {
2928        if( (*num)[i]*(*den)[j] >= (*num)[j]*(*den)[i] )
2929        {
2930            return  semicListNotMonotonous;
2931        }
2932    }
2933
2934    // ---------------------
2935    //  check Milnor number
2936    // ---------------------
2937
2938    for( mu=0, i=0; i<n; i++ )
2939    {
2940        mu += (*mul)[i];
2941    }
2942
2943    if( mu != (int)(l->m[0].Data( )) )
2944    {
2945        return  semicListMilnorWrong;
2946    }
2947
2948    // -------------------------
2949    //  check geometrical genus
2950    // -------------------------
2951
2952    for( pg=0, i=0; i<n; i++ )
2953    {
2954        if( (*num)[i]<=(*den)[i] )
2955        {
2956            pg += (*mul)[i];
2957        }
2958    }
2959
2960    if( pg != (int)(l->m[1].Data( )) )
2961    {
2962        return  semicListPGWrong;
2963    }
2964
2965    return  semicOK;
2966}
2967
2968// ----------------------------------------------------------------------------
2969//  this procedure is called from the interpreter
2970// ----------------------------------------------------------------------------
2971//  first  = list of spectrum numbers
2972//  second = list of spectrum numbers
2973//  result = sum of the two lists
2974// ----------------------------------------------------------------------------
2975
2976BOOLEAN spaddProc( leftv result,leftv first,leftv second )
2977{
2978    semicState  state;
2979
2980    // -----------------
2981    //  check arguments
2982    // -----------------
2983
2984    lists l1 = (lists)first->Data( );
2985    lists l2 = (lists)second->Data( );
2986
2987    if( (state=list_is_spectrum( l1 )) != semicOK )
2988    {
2989        WerrorS( "first argument is not a spectrum:" );
2990        list_error( state );
2991    }
2992    else if( (state=list_is_spectrum( l2 )) != semicOK )
2993    {
2994        WerrorS( "second argument is not a spectrum:" );
2995        list_error( state );
2996    }
2997    else
2998    {
2999        spectrum s1( l1 );
3000        spectrum s2( l2 );
3001        spectrum sum( s1+s2 );
3002
3003        result->rtyp = LIST_CMD;
3004        result->data = (char*)(sum.thelist( ));
3005    }
3006
3007    return  (state!=semicOK);
3008}
3009
3010// ----------------------------------------------------------------------------
3011//  this procedure is called from the interpreter
3012// ----------------------------------------------------------------------------
3013//  first  = list of spectrum numbers
3014//  second = integer
3015//  result = the multiple of the first list by the second factor
3016// ----------------------------------------------------------------------------
3017
3018BOOLEAN spmulProc( leftv result,leftv first,leftv second )
3019{
3020    semicState  state;
3021
3022    // -----------------
3023    //  check arguments
3024    // -----------------
3025
3026    lists   l = (lists)first->Data( );
3027    int     k = (int)second->Data( );
3028
3029    if( (state=list_is_spectrum( l ))!=semicOK )
3030    {
3031        WerrorS( "first argument is not a spectrum" );
3032        list_error( state );
3033    }
3034    else if( k < 0 )
3035    {
3036        WerrorS( "second argument should be positive" );
3037        state = semicMulNegative;
3038    }
3039    else
3040    {
3041        spectrum s( l );
3042        spectrum product( k*s );
3043
3044        result->rtyp = LIST_CMD;
3045        result->data = (char*)product.thelist( );
3046    }
3047
3048    return  (state!=semicOK);
3049}
3050
3051// ----------------------------------------------------------------------------
3052//  this procedure is called from the interpreter
3053// ----------------------------------------------------------------------------
3054//  first  = list of spectrum numbers
3055//  second = list of spectrum numbers
3056//  result = semicontinuity index
3057// ----------------------------------------------------------------------------
3058
3059BOOLEAN    semicProc3   ( leftv res,leftv u,leftv v,leftv w )
3060{
3061  semicState  state;
3062  BOOLEAN qh=(((int)w->Data())==1);
3063
3064  // -----------------
3065  //  check arguments
3066  // -----------------
3067
3068  lists l1 = (lists)u->Data( );
3069  lists l2 = (lists)v->Data( );
3070
3071  if( (state=list_is_spectrum( l1 ))!=semicOK )
3072  {
3073    WerrorS( "first argument is not a spectrum" );
3074    list_error( state );
3075  }
3076  else if( (state=list_is_spectrum( l2 ))!=semicOK )
3077  {
3078    WerrorS( "second argument is not a spectrum" );
3079    list_error( state );
3080  }
3081  else
3082  {
3083    spectrum s1( l1 );
3084    spectrum s2( l2 );
3085
3086    res->rtyp = INT_CMD;
3087    if (qh)
3088      res->data = (void*)(s1.mult_spectrumh( s2 ));
3089    else
3090      res->data = (void*)(s1.mult_spectrum( s2 ));
3091  }
3092
3093  // -----------------
3094  //  check status
3095  // -----------------
3096
3097  return  (state!=semicOK);
3098}
3099BOOLEAN    semicProc   ( leftv res,leftv u,leftv v )
3100{
3101  sleftv tmp;
3102  memset(&tmp,0,sizeof(tmp));
3103  tmp.rtyp=INT_CMD;
3104  /* tmp.data = (void *)0;  -- done by memset */
3105
3106  return  semicProc3(res,u,v,&tmp);
3107}
3108// from splist.cc
3109// ----------------------------------------------------------------------------
3110//  Compute the spectrum of a  spectrumPolyList
3111// ----------------------------------------------------------------------------
3112
3113spectrumState   spectrumPolyList::spectrum( lists *L,int fast )
3114{
3115    spectrumPolyNode  **node = &root;
3116    spectrumPolyNode  *search;
3117
3118    poly              f,tmp;
3119    int               found,cmp;
3120
3121    Rational smax( ( fast==0 ? 0 : pVariables ),
3122                   ( fast==2 ? 2 : 1 ) );
3123
3124    Rational weight_prev( 0,1 );
3125
3126    int     mu = 0;          // the milnor number
3127    int     pg = 0;          // the geometrical genus
3128    int     n  = 0;          // number of different spectral numbers
3129    int     z  = 0;          // number of spectral number equal to smax
3130
3131    int     k = 0;
3132
3133    while( (*node)!=(spectrumPolyNode*)NULL &&
3134           ( fast==0 || (*node)->weight<=smax ) )
3135    {
3136        // ---------------------------------------
3137        //  determine the first normal form which
3138        //  contains the monomial  node->mon
3139        // ---------------------------------------
3140
3141        found  = FALSE;
3142        search = *node;
3143
3144        while( search!=(spectrumPolyNode*)NULL && found==FALSE )
3145        {
3146            if( search->nf!=(poly)NULL )
3147            {
3148                f = search->nf;
3149
3150                do
3151                {
3152                    // --------------------------------
3153                    //  look for  (*node)->mon  in   f
3154                    // --------------------------------
3155
3156                    cmp = pCmp( (*node)->mon,f );
3157
3158                    if( cmp<0 )
3159                    {
3160                        f = pNext( f );
3161                    }
3162                    else if( cmp==0 )
3163                    {
3164                        // -----------------------------
3165                        //  we have found a normal form
3166                        // -----------------------------
3167
3168                        found = TRUE;
3169
3170                        //  normalize coefficient
3171
3172                        number inv = nInvers( pGetCoeff( f ) );
3173                        pMult_nn( search->nf,inv );
3174                        nDelete( &inv );
3175
3176                        //  exchange  normal forms
3177
3178                        tmp         = (*node)->nf;
3179                        (*node)->nf = search->nf;
3180                        search->nf  = tmp;
3181                    }
3182                }
3183                while( cmp<0 && f!=(poly)NULL );
3184            }
3185            search = search->next;
3186        }
3187
3188        if( found==FALSE )
3189        {
3190            // ------------------------------------------------
3191            //  the weight of  node->mon  is a spectrum number
3192            // ------------------------------------------------
3193
3194            mu++;
3195
3196            if( (*node)->weight<=(Rational)1 )              pg++;
3197            if( (*node)->weight==smax )           z++;
3198            if( (*node)->weight>weight_prev )     n++;
3199
3200            weight_prev = (*node)->weight;
3201            node = &((*node)->next);
3202        }
3203        else
3204        {
3205            // -----------------------------------------------
3206            //  determine all other normal form which contain
3207            //  the monomial  node->mon
3208            //  replace for  node->mon  its normal form
3209            // -----------------------------------------------
3210
3211            while( search!=(spectrumPolyNode*)NULL )
3212            {
3213                    if( search->nf!=(poly)NULL )
3214                {
3215                    f = search->nf;
3216
3217                    do
3218                    {
3219                        // --------------------------------
3220                        //  look for  (*node)->mon  in   f
3221                        // --------------------------------
3222
3223                        cmp = pCmp( (*node)->mon,f );
3224
3225                        if( cmp<0 )
3226                        {
3227                            f = pNext( f );
3228                        }
3229                        else if( cmp==0 )
3230                        {
3231                            search->nf = pSub( search->nf,
3232                                ppMult_nn( (*node)->nf,pGetCoeff( f ) ) );
3233                            pNorm( search->nf );
3234                        }
3235                    }
3236                    while( cmp<0 && f!=(poly)NULL );
3237                }
3238                search = search->next;
3239            }
3240            delete_node( node );
3241        }
3242
3243    }
3244
3245    // --------------------------------------------------------
3246    //  fast computation exploits the symmetry of the spectrum
3247    // --------------------------------------------------------
3248
3249    if( fast==2 )
3250    {
3251        mu = 2*mu - z;
3252        n  = ( z > 0 ? 2*n - 1 : 2*n );
3253    }
3254
3255    // --------------------------------------------------------
3256    //  compute the spectrum numbers with their multiplicities
3257    // --------------------------------------------------------
3258
3259    intvec            *nom  = new intvec( n );
3260    intvec            *den  = new intvec( n );
3261    intvec            *mult = new intvec( n );
3262
3263    int count         = 0;
3264    int multiplicity  = 1;
3265
3266    for( search=root; search!=(spectrumPolyNode*)NULL &&
3267                     ( fast==0 || search->weight<=smax );
3268                     search=search->next )
3269    {
3270        if( search->next==(spectrumPolyNode*)NULL ||
3271            search->weight<search->next->weight )
3272        {
3273            (*nom) [count] = search->weight.get_num_si( );
3274            (*den) [count] = search->weight.get_den_si( );
3275            (*mult)[count] = multiplicity;
3276
3277            multiplicity=1;
3278            count++;
3279        }
3280        else
3281        {
3282            multiplicity++;
3283        }
3284    }
3285
3286    // --------------------------------------------------------
3287    //  fast computation exploits the symmetry of the spectrum
3288    // --------------------------------------------------------
3289
3290    if( fast==2 )
3291    {
3292        int n1,n2;
3293        for( n1=0, n2=n-1; n1<n2; n1++, n2-- )
3294        {
3295            (*nom) [n2] = pVariables*(*den)[n1]-(*nom)[n1];
3296            (*den) [n2] = (*den)[n1];
3297            (*mult)[n2] = (*mult)[n1];
3298        }
3299    }
3300
3301    // -----------------------------------
3302    //  test if the spectrum is symmetric
3303    // -----------------------------------
3304
3305    if( fast==0 || fast==1 )
3306    {
3307        int symmetric=TRUE;
3308
3309        for( int n1=0, n2=n-1 ; n1<n2 && symmetric==TRUE; n1++, n2-- )
3310        {
3311            if( (*mult)[n1]!=(*mult)[n2] ||
3312                (*den) [n1]!= (*den)[n2] ||
3313                (*nom)[n1]+(*nom)[n2]!=pVariables*(*den) [n1] )
3314            {
3315                symmetric = FALSE;
3316            }
3317        }
3318
3319        if( symmetric==FALSE )
3320        {
3321            // ---------------------------------------------
3322            //  the spectrum is not symmetric => degenerate
3323            //  principal part
3324            // ---------------------------------------------
3325
3326            *L = (lists)omAllocBin( slists_bin);
3327            (*L)->Init( 1 );
3328            (*L)->m[0].rtyp = INT_CMD;    //  milnor number
3329            (*L)->m[0].data = (void*)mu;
3330
3331            return spectrumDegenerate;
3332        }
3333    }
3334
3335    *L = (lists)omAllocBin( slists_bin);
3336
3337    (*L)->Init( 6 );
3338
3339    (*L)->m[0].rtyp = INT_CMD;    //  milnor number
3340    (*L)->m[1].rtyp = INT_CMD;    //  geometrical genus
3341    (*L)->m[2].rtyp = INT_CMD;    //  number of spectrum values
3342    (*L)->m[3].rtyp = INTVEC_CMD; //  nominators
3343    (*L)->m[4].rtyp = INTVEC_CMD; //  denomiantors
3344    (*L)->m[5].rtyp = INTVEC_CMD; //  multiplicities
3345
3346    (*L)->m[0].data = (void*)mu;
3347    (*L)->m[1].data = (void*)pg;
3348    (*L)->m[2].data = (void*)n;
3349    (*L)->m[3].data = (void*)nom;
3350    (*L)->m[4].data = (void*)den;
3351    (*L)->m[5].data = (void*)mult;
3352
3353    return  spectrumOK;
3354}
3355
3356#endif
3357
3358//from mpr_inout.cc
3359extern void nPrint(number n);
3360
3361BOOLEAN loNewtonP( leftv res, leftv arg1 )
3362{
3363  res->data= (void*)loNewtonPolytope( (ideal)arg1->Data() );
3364  return FALSE;
3365}
3366
3367BOOLEAN loSimplex( leftv res, leftv args )
3368{
3369  if ( !(rField_is_long_R()) )
3370  {
3371    WerrorS("Ground field not implemented!");
3372    return TRUE;
3373  }
3374
3375  simplex * LP;
3376  matrix m;
3377
3378  leftv v= args;
3379  if ( v->Typ() != MATRIX_CMD ) // 1: matrix
3380    return TRUE;
3381  else
3382    m= (matrix)(v->CopyD());
3383
3384  LP = new simplex(MATROWS(m),MATCOLS(m));
3385  LP->mapFromMatrix(m);
3386
3387  v= v->next;
3388  if ( v->Typ() != INT_CMD )    // 2: m = number of constraints
3389    return TRUE;
3390  else
3391    LP->m= (int)(v->Data());
3392
3393  v= v->next;
3394  if ( v->Typ() != INT_CMD )    // 3: n = number of variables
3395    return TRUE;
3396  else
3397    LP->n= (int)(v->Data());
3398
3399  v= v->next;
3400  if ( v->Typ() != INT_CMD )    // 4: m1 = number of <= constraints
3401    return TRUE;
3402  else
3403    LP->m1= (int)(v->Data());
3404
3405  v= v->next;
3406  if ( v->Typ() != INT_CMD )    // 5: m2 = number of >= constraints
3407    return TRUE;
3408  else
3409    LP->m2= (int)(v->Data());
3410
3411  v= v->next;
3412  if ( v->Typ() != INT_CMD )    // 6: m3 = number of == constraints
3413    return TRUE;
3414  else
3415    LP->m3= (int)(v->Data());
3416
3417#ifdef mprDEBUG_PROT
3418  Print("m (constraints) %d\n",LP->m);
3419  Print("n (columns) %d\n",LP->n);
3420  Print("m1 (<=) %d\n",LP->m1);
3421  Print("m2 (>=) %d\n",LP->m2);
3422  Print("m3 (==) %d\n",LP->m3);
3423#endif
3424
3425  LP->compute();
3426
3427  lists lres= (lists)omAlloc( sizeof(slists) );
3428  lres->Init( 6 );
3429
3430  lres->m[0].rtyp= MATRIX_CMD; // output matrix
3431  lres->m[0].data=(void*)LP->mapToMatrix(m);
3432
3433  lres->m[1].rtyp= INT_CMD;   // found a solution?
3434  lres->m[1].data=(void*)LP->icase;
3435
3436  lres->m[2].rtyp= INTVEC_CMD;
3437  lres->m[2].data=(void*)LP->posvToIV();
3438
3439  lres->m[3].rtyp= INTVEC_CMD;
3440  lres->m[3].data=(void*)LP->zrovToIV();
3441
3442  lres->m[4].rtyp= INT_CMD;
3443  lres->m[4].data=(void*)LP->m;
3444
3445  lres->m[5].rtyp= INT_CMD;
3446  lres->m[5].data=(void*)LP->n;
3447
3448  res->data= (void*)lres;
3449
3450  return FALSE;
3451}
3452
3453BOOLEAN nuMPResMat( leftv res, leftv arg1, leftv arg2 )
3454{
3455  ideal gls = (ideal)(arg1->Data());
3456  int imtype= (int)arg2->Data();
3457
3458  uResultant::resMatType mtype= determineMType( imtype );
3459
3460  // check input ideal ( = polynomial system )
3461  if ( mprIdealCheck( gls, arg1->Name(), mtype, true ) != mprOk )
3462  {
3463    return TRUE;
3464  }
3465
3466  uResultant *resMat= new uResultant( gls, mtype, false );
3467
3468  res->rtyp = MODUL_CMD;
3469  res->data= (void*)resMat->accessResMat()->getMatrix();
3470
3471  delete resMat;
3472
3473  return FALSE;
3474}
3475
3476BOOLEAN nuLagSolve( leftv res, leftv arg1, leftv arg2, leftv arg3 )
3477{
3478
3479  poly gls;
3480  gls= (poly)(arg1->Data());
3481  int howclean= (int)arg3->Data();
3482
3483  if ( !(rField_is_R() ||
3484         rField_is_Q() ||
3485         rField_is_long_R() ||
3486         rField_is_long_C()) )
3487  {
3488    WerrorS("Ground field not implemented!");
3489    return TRUE;
3490  }
3491
3492  if ( !(rField_is_R()||rField_is_long_R()||rField_is_long_C()) )
3493  {
3494    unsigned long int ii = (unsigned long int)arg2->Data();
3495    setGMPFloatDigits( ii, ii );
3496  }
3497
3498  if ( gls == NULL || pIsConstant( gls ) )
3499  {
3500    WerrorS("Input polynomial is constant!");
3501    return TRUE;
3502  }
3503
3504  int ldummy;
3505  int deg= pLDeg( gls, &ldummy, currRing );
3506  //  int deg= pDeg( gls );
3507  int len= pLength( gls );
3508  int i,vpos;
3509  poly piter;
3510  lists elist;
3511  lists rlist;
3512
3513  elist= (lists)omAlloc( sizeof(slists) );
3514  elist->Init( 0 );
3515
3516  if ( pVariables > 1 )
3517  {
3518    piter= gls;
3519    for ( i= 1; i <= pVariables; i++ )
3520      if ( pGetExp( piter, i ) )
3521      {
3522        vpos= i;
3523        break;
3524      }
3525    while ( piter )
3526    {
3527      for ( i= 1; i <= pVariables; i++ )
3528        if ( (vpos != i) && (pGetExp( piter, i ) != 0) )
3529        {
3530          WerrorS("The input polynomial must be univariate!");
3531          return TRUE;
3532        }
3533      pIter( piter );
3534    }
3535  }
3536
3537  rootContainer * roots= new rootContainer();
3538  number * pcoeffs= (number *)omAlloc( (deg+1) * sizeof( number ) );
3539  piter= gls;
3540  for ( i= deg; i >= 0; i-- )
3541  {
3542    //if ( piter ) Print("deg %d, pDeg(piter) %d\n",i,pTotaldegree(piter));
3543    if ( piter && pTotaldegree(piter) == i )
3544    {
3545      pcoeffs[i]= nCopy( pGetCoeff( piter ) );
3546      //nPrint( pcoeffs[i] );PrintS("  ");
3547      pIter( piter );
3548    }
3549    else
3550    {
3551      pcoeffs[i]= nInit(0);
3552    }
3553  }
3554
3555#ifdef mprDEBUG_PROT
3556  for (i=deg; i >= 0; i--)
3557  {
3558    nPrint( pcoeffs[i] );PrintS("  ");
3559  }
3560  PrintLn();
3561#endif
3562
3563  roots->fillContainer( pcoeffs, NULL, 1, deg, rootContainer::onepoly, 1 );
3564  roots->solver( howclean );
3565
3566  int elem= roots->getAnzRoots();
3567  char *out;
3568  char *dummy;
3569  int j;
3570
3571  rlist= (lists)omAlloc( sizeof(slists) );
3572  rlist->Init( elem );
3573
3574  if (rField_is_long_C())
3575  {
3576    for ( j= 0; j < elem; j++ )
3577    {
3578      rlist->m[j].rtyp=NUMBER_CMD;
3579      rlist->m[j].data=(void *)nCopy((number)(roots->getRoot(j)));
3580      //rlist->m[j].data=(void *)(number)(roots->getRoot(j));
3581    }
3582  }
3583  else
3584  {
3585    for ( j= 0; j < elem; j++ )
3586    {
3587      dummy = complexToStr( (*roots)[j], gmp_output_digits );
3588      rlist->m[j].rtyp=STRING_CMD;
3589      rlist->m[j].data=(void *)dummy;
3590    }
3591  }
3592
3593  elist->Clean();
3594  //omFreeSize( (ADDRESS) elist, sizeof(slists) );
3595
3596  // this is (via fillContainer) the same data as in root
3597  //for ( i= deg; i >= 0; i-- ) nDelete( &pcoeffs[i] );
3598  //omFreeSize( (ADDRESS) pcoeffs, (deg+1) * sizeof( number ) );
3599
3600  delete roots;
3601
3602  res->rtyp= LIST_CMD;
3603  res->data= (void*)rlist;
3604
3605  return FALSE;
3606}
3607
3608BOOLEAN nuVanderSys( leftv res, leftv arg1, leftv arg2, leftv arg3)
3609{
3610  int i;
3611  ideal p,w;
3612  p= (ideal)arg1->Data();
3613  w= (ideal)arg2->Data();
3614
3615  // w[0] = f(p^0)
3616  // w[1] = f(p^1)
3617  // ...
3618  // p can be a vector of numbers (multivariate polynom)
3619  //   or one number (univariate polynom)
3620  // tdg = deg(f)
3621
3622  int n= IDELEMS( p );
3623  int m= IDELEMS( w );
3624  int tdg= (int)arg3->Data();
3625
3626  res->data= (void*)NULL;
3627
3628  // check the input
3629  if ( tdg < 1 )
3630  {
3631    WerrorS("Last input parameter must be > 0!");
3632    return TRUE;
3633  }
3634  if ( n != pVariables )
3635  {
3636    Werror("Size of first input ideal must be equal to %d!",pVariables);
3637    return TRUE;
3638  }
3639  if ( m != (int)pow((double)tdg+1,(double)n) )
3640  {
3641    Werror("Size of second input ideal must be equal to %d!",
3642      (int)pow((double)tdg+1,(double)n));
3643    return TRUE;
3644  }
3645  if ( !(rField_is_Q() /* ||
3646         rField_is_R() || rField_is_long_R() ||
3647         rField_is_long_C()*/ ) )
3648         {
3649    WerrorS("Ground field not implemented!");
3650    return TRUE;
3651  }
3652
3653  number tmp;
3654  number *pevpoint= (number *)omAlloc( n * sizeof( number ) );
3655  for ( i= 0; i < n; i++ )
3656  {
3657    pevpoint[i]=nInit(0);
3658    if (  (p->m)[i] )
3659    {
3660      tmp = pGetCoeff( (p->m)[i] );
3661      if ( nIsZero(tmp) || nIsOne(tmp) || nIsMOne(tmp) )
3662      {
3663        omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
3664        WerrorS("Elements of first input ideal must not be equal to -1, 0, 1!");
3665        return TRUE;
3666      }
3667    } else tmp= NULL;
3668    if ( !nIsZero(tmp) )
3669    {
3670      if ( !pIsConstant((p->m)[i]))
3671      {
3672        omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
3673        WerrorS("Elements of first input ideal must be numbers!");
3674        return TRUE;
3675      }
3676      pevpoint[i]= nCopy( tmp );
3677    }
3678  }
3679
3680  number *wresults= (number *)omAlloc( m * sizeof( number ) );
3681  for ( i= 0; i < m; i++ )
3682  {
3683    wresults[i]= nInit(0);
3684    if ( (w->m)[i] && !nIsZero(pGetCoeff((w->m)[i])) )
3685    {
3686      if ( !pIsConstant((w->m)[i]))
3687      {
3688        omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
3689        omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
3690        WerrorS("Elements of second input ideal must be numbers!");
3691        return TRUE;
3692      }
3693      wresults[i]= nCopy(pGetCoeff((w->m)[i]));
3694    }
3695  }
3696
3697  vandermonde vm( m, n, tdg, pevpoint, FALSE );
3698  number *ncpoly= vm.interpolateDense( wresults );
3699  // do not free ncpoly[]!!
3700  poly rpoly= vm.numvec2poly( ncpoly );
3701
3702  omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
3703  omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
3704
3705  res->data= (void*)rpoly;
3706  return FALSE;
3707}
3708
3709BOOLEAN nuUResSolve( leftv res, leftv args )
3710{
3711  leftv v= args;
3712
3713  ideal gls;
3714  int imtype;
3715  int howclean;
3716
3717  // get ideal
3718  if ( v->Typ() != IDEAL_CMD )
3719    return TRUE;
3720  else gls= (ideal)(v->Data());
3721  v= v->next;
3722
3723  // get resultant matrix type to use (0,1)
3724  if ( v->Typ() != INT_CMD )
3725    return TRUE;
3726  else imtype= (int)v->Data();
3727  v= v->next;
3728
3729  // get and set precision in digits ( > 0 )
3730  if ( v->Typ() != INT_CMD )
3731    return TRUE;
3732  else if ( !(rField_is_R()||rField_is_long_R()||rField_is_long_C()) )
3733  {
3734    unsigned long int ii=(unsigned long int)v->Data();
3735    setGMPFloatDigits( ii, ii );
3736  }
3737  v= v->next;
3738
3739  // get interpolation steps (0,1,2)
3740  if ( v->Typ() != INT_CMD )
3741    return TRUE;
3742  else howclean= (int)v->Data();
3743
3744  uResultant::resMatType mtype= determineMType( imtype );
3745  int i,c,count;
3746  lists listofroots= NULL;
3747  lists emptylist;
3748  number smv= NULL;
3749  BOOLEAN interpolate_det= (mtype==uResultant::denseResMat)?TRUE:FALSE;
3750
3751  //emptylist= (lists)omAlloc( sizeof(slists) );
3752  //emptylist->Init( 0 );
3753
3754  //res->rtyp = LIST_CMD;
3755  //res->data= (void *)emptylist;
3756
3757  // check input ideal ( = polynomial system )
3758  if ( mprIdealCheck( gls, args->Name(), mtype ) != mprOk )
3759  {
3760    return TRUE;
3761  }
3762
3763  uResultant * ures;
3764  rootContainer ** iproots;
3765  rootContainer ** muiproots;
3766  rootArranger * arranger;
3767
3768  // main task 1: setup of resultant matrix
3769  ures= new uResultant( gls, mtype );
3770  if ( ures->accessResMat()->initState() != resMatrixBase::ready )
3771  {
3772    WerrorS("Error occurred during matrix setup!");
3773    return TRUE;
3774  }
3775
3776  // if dense resultant, check if minor nonsingular
3777  if ( mtype == uResultant::denseResMat )
3778  {
3779    smv= ures->accessResMat()->getSubDet();
3780#ifdef mprDEBUG_PROT
3781    PrintS("// Determinant of submatrix: ");nPrint(smv);PrintLn();
3782#endif
3783    if ( nIsZero(smv) )
3784    {
3785      WerrorS("Unsuitable input ideal: Minor of resultant matrix is singular!");
3786      return TRUE;
3787    }
3788  }
3789
3790  // main task 2: Interpolate specialized resultant polynomials
3791  if ( interpolate_det )
3792    iproots= ures->interpolateDenseSP( false, smv );
3793  else
3794    iproots= ures->specializeInU( false, smv );
3795
3796  // main task 3: Interpolate specialized resultant polynomials
3797  if ( interpolate_det )
3798    muiproots= ures->interpolateDenseSP( true, smv );
3799  else
3800    muiproots= ures->specializeInU( true, smv );
3801
3802#ifdef mprDEBUG_PROT
3803  c= iproots[0]->getAnzElems();
3804  for (i=0; i < c; i++) pWrite(iproots[i]->getPoly());
3805  c= muiproots[0]->getAnzElems();
3806  for (i=0; i < c; i++) pWrite(muiproots[i]->getPoly());
3807#endif
3808
3809  // main task 4: Compute roots of specialized polys and match them up
3810  arranger= new rootArranger( iproots, muiproots, howclean );
3811  arranger->solve_all();
3812
3813  // get list of roots
3814  if ( arranger->success() )
3815  {
3816    arranger->arrange();
3817    listofroots= arranger->listOfRoots( gmp_output_digits );
3818  }
3819  else
3820  {
3821    WerrorS("Solver was unable to find any roots!");
3822    return TRUE;
3823  }
3824
3825  // free everything
3826  count= iproots[0]->getAnzElems();
3827  for (i=0; i < count; i++) delete iproots[i];
3828  omFreeSize( (ADDRESS) iproots, count * sizeof(rootContainer*) );
3829  count= muiproots[0]->getAnzElems();
3830  for (i=0; i < count; i++) delete muiproots[i];
3831  omFreeSize( (ADDRESS) muiproots, count * sizeof(rootContainer*) );
3832
3833  delete ures;
3834  delete arranger;
3835  nDelete( &smv );
3836
3837  res->data= (void *)listofroots;
3838
3839  //emptylist->Clean();
3840  //  omFreeSize( (ADDRESS) emptylist, sizeof(slists) );
3841
3842  return FALSE;
3843}
3844
3845// from mpr_numeric.cc
3846lists rootArranger::listOfRoots( const unsigned int oprec )
3847{
3848  int i,j,tr;
3849  int count= roots[0]->getAnzRoots(); // number of roots
3850  int elem= roots[0]->getAnzElems();  // number of koordinates per root
3851
3852  lists listofroots= (lists)omAlloc( sizeof(slists) ); // must be done this way!
3853
3854  if ( found_roots )
3855  {
3856    listofroots->Init( count );
3857
3858    for (i=0; i < count; i++)
3859    {
3860      lists onepoint= (lists)omAlloc(sizeof(slists)); // must be done this way!
3861      onepoint->Init(elem);
3862      for ( j= 0; j < elem; j++ )
3863      {
3864        if ( !rField_is_long_C() )
3865        {
3866          onepoint->m[j].rtyp=STRING_CMD;
3867          onepoint->m[j].data=(void *)complexToStr((*roots[j])[i],oprec);
3868        }
3869        else
3870        {
3871          onepoint->m[j].rtyp=NUMBER_CMD;
3872          onepoint->m[j].data=(void *)nCopy((number)(roots[j]->getRoot(i)));
3873        }
3874        onepoint->m[j].next= NULL;
3875        onepoint->m[j].name= NULL;
3876      }
3877      listofroots->m[i].rtyp=LIST_CMD;
3878      listofroots->m[i].data=(void *)onepoint;
3879      listofroots->m[j].next= NULL;
3880      listofroots->m[j].name= NULL;
3881    }
3882
3883  }
3884  else
3885  {
3886    listofroots->Init( 0 );
3887  }
3888
3889  return listofroots;
3890}
3891
3892#ifdef PDEBUG
3893
3894#if (OM_TRACK > 2) && defined(OM_TRACK_CUSTOM)
3895
3896void p_SetRingOfPoly(poly p, ring r)
3897{
3898  while (p != NULL)
3899  {
3900    p_SetRingOfLm(p, r);
3901    pIter(p);
3902  }
3903}
3904
3905void p_SetRingOfIdeal(ideal id, ring r)
3906{
3907  if (id == NULL) return;
3908
3909  int i, n = id->ncols*id->nrows;
3910
3911  for (i=0; i<n; i++)
3912  {
3913    p_SetRingOfPoly(id->m[i], r);
3914  }
3915}
3916
3917void p_SetRingOfList(lists L, ring r)
3918{
3919  int i;
3920  for (i=0; i<L->nr; i++)
3921  {
3922    p_SetRingOfLeftv(&(L->m[i]), r);
3923  }
3924}
3925
3926void p_SetRingOfCommand(command cmd, ring r)
3927{
3928  if (cmd->op == PROC_CMD && cmd->argc == 2)
3929    p_SetRingOfLeftv(&(cmd->arg2), r);
3930  else if (cmd->argc > 0)
3931  {
3932    p_SetRingOfLeftv(&(cmd->arg1), r);
3933    if (cmd->argc > 1)
3934    {
3935      p_SetRingOfLeftv(&(cmd->arg2), r);
3936      if (cmd->argc > 2)
3937        p_SetRingOfLeftv(&(cmd->arg3), r);
3938    }
3939  }
3940}
3941
3942void p_SetRingOfLeftv(leftv l, ring r)
3943{
3944  while (l != NULL)
3945  {
3946    switch(l->rtyp)
3947    {
3948        case POLY_CMD:
3949        case VECTOR_CMD:
3950          p_SetRingOfPoly((poly) l->data, r);
3951      break;
3952
3953      case IDEAL_CMD:
3954      case MODUL_CMD:
3955      case MATRIX_CMD:
3956      case MAP_CMD:
3957        p_SetRingOfIdeal((ideal) l->data, r);
3958        break;
3959
3960        case LIST_CMD:
3961          p_SetRingOfList((lists) l->data, r);
3962          break;
3963
3964        case COMMAND:
3965          p_SetRingOfCommand((command)l->data, r);
3966        default:
3967          break;
3968    }
3969    l = l->next;
3970  }
3971}
3972#endif // (OM_TRACK > 2) && defined(OM_TRACK_CUSTOM)
3973
3974#endif // PDEBUG
3975
3976// from ring.cc
3977void rSetHdl(idhdl h)
3978{
3979  int i;
3980  ring rg = NULL;
3981  if (h!=NULL)
3982  {
3983//   Print(" new ring:%s (l:%d)\n",IDID(h),IDLEV(h));
3984    rg = IDRING(h);
3985    omCheckAddrSize((ADDRESS)h,sizeof(idrec));
3986    if (IDID(h))  // OB: ????
3987      omCheckAddr((ADDRESS)IDID(h));
3988    rTest(rg);
3989  }
3990
3991  // clean up history
3992  if (sLastPrinted.RingDependend())
3993  {
3994    sLastPrinted.CleanUp();
3995    memset(&sLastPrinted,0,sizeof(sleftv));
3996  }
3997
3998   /*------------ change the global ring -----------------------*/
3999  rChangeCurrRing(rg);
4000  currRingHdl = h;
4001}
4002
4003BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
4004{
4005  int last = 0, o=0, n = 1, i=0, typ = 1, j;
4006  sleftv *sl = ord;
4007
4008  // determine nBlocks
4009  while (sl!=NULL)
4010  {
4011    intvec *iv = (intvec *)(sl->data);
4012    if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C)) i++;
4013    else if ((*iv)[1]==ringorder_L)
4014    {
4015      R->bitmask=(*iv)[2];
4016      n--;
4017    }
4018    else if ((*iv)[1]!=ringorder_a) o++;
4019    n++;
4020    sl=sl->next;
4021  }
4022  // check whether at least one real ordering
4023  if (o==0)
4024  {
4025    WerrorS("invalid combination of orderings");
4026    return TRUE;
4027  }
4028  // if no c/C ordering is given, increment n
4029  if (i==0) n++;
4030  else if (i != 1)
4031  {
4032    // throw error if more than one is given
4033    WerrorS("more than one ordering c/C specified");
4034    return TRUE;
4035  }
4036
4037  // initialize fields of R
4038  R->order=(int *)omAlloc0(n*sizeof(int));
4039  R->block0=(int *)omAlloc0(n*sizeof(int));
4040  R->block1=(int *)omAlloc0(n*sizeof(int));
4041  R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
4042
4043  // init order, so that rBlocks works correctly
4044  for (j=0; j < n-1; j++)
4045    R->order[j] = (int) ringorder_unspec;
4046  // set last _C order, if no c/C order was given
4047  if (i == 0) R->order[n-2] = ringorder_C;
4048
4049  /* init orders */
4050  sl=ord;
4051  n=-1;
4052  while (sl!=NULL)
4053  {
4054    intvec *iv;
4055    iv = (intvec *)(sl->data);
4056    if ((*iv)[1]!=ringorder_L)
4057    {
4058      n++;
4059
4060      /* the format of an ordering:
4061       *  iv[0]: factor
4062       *  iv[1]: ordering
4063       *  iv[2..end]: weights
4064       */
4065      R->order[n] = (*iv)[1];
4066      switch ((*iv)[1])
4067      {
4068          case ringorder_ws:
4069          case ringorder_Ws:
4070            typ=-1;
4071          case ringorder_wp:
4072          case ringorder_Wp:
4073            R->wvhdl[n]=(int*)omAlloc((iv->length()-1)*sizeof(int));
4074            for (i=2; i<iv->length(); i++)
4075              R->wvhdl[n][i-2] = (*iv)[i];
4076            R->block0[n] = last+1;
4077            last += iv->length()-2;
4078            R->block1[n] = last;
4079            break;
4080          case ringorder_ls:
4081          case ringorder_ds:
4082          case ringorder_Ds:
4083            typ=-1;
4084          case ringorder_lp:
4085          case ringorder_dp:
4086          case ringorder_Dp:
4087          case ringorder_rp:
4088            R->block0[n] = last+1;
4089            if (iv->length() == 3) last+=(*iv)[2];
4090            else last += (*iv)[0];
4091            R->block1[n] = last;
4092            if (rCheckIV(iv)) return TRUE;
4093            break;
4094          case ringorder_S:
4095          case ringorder_c:
4096          case ringorder_C:
4097            if (rCheckIV(iv)) return TRUE;
4098            break;
4099          case ringorder_aa:
4100          case ringorder_a:
4101            R->block0[n] = last+1;
4102            R->block1[n] = si_min(last+iv->length()-2 , R->N);
4103            R->wvhdl[n] = (int*)omAlloc((iv->length()-1)*sizeof(int));
4104            for (i=2; i<iv->length(); i++)
4105            {
4106              R->wvhdl[n][i-2]=(*iv)[i];
4107              if ((*iv)[i]<0) typ=-1;
4108            }
4109            break;
4110          case ringorder_M:
4111          {
4112            int Mtyp=rTypeOfMatrixOrder(iv);
4113            if (Mtyp==0) return TRUE;
4114            if (Mtyp==-1) typ = -1;
4115
4116            R->wvhdl[n] =( int *)omAlloc((iv->length()-1)*sizeof(int));
4117            for (i=2; i<iv->length();i++)
4118              R->wvhdl[n][i-2]=(*iv)[i];
4119
4120            R->block0[n] = last+1;
4121            last += (int)sqrt((double)(iv->length()-2));
4122            R->block1[n] = last;
4123            break;
4124          }
4125
4126          case ringorder_no:
4127            R->order[n] = ringorder_unspec;
4128            return TRUE;
4129
4130          default:
4131            Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
4132            R->order[n] = ringorder_unspec;
4133            return TRUE;
4134      }
4135    }
4136    sl=sl->next;
4137  }
4138
4139  // check for complete coverage
4140  if ((R->order[n]==ringorder_c) ||  (R->order[n]==ringorder_C)) n--;
4141  if (R->block1[n] != R->N)
4142  {
4143    if (((R->order[n]==ringorder_dp) ||
4144         (R->order[n]==ringorder_ds) ||
4145         (R->order[n]==ringorder_Dp) ||
4146         (R->order[n]==ringorder_Ds) ||
4147         (R->order[n]==ringorder_rp) ||
4148         (R->order[n]==ringorder_lp) ||
4149         (R->order[n]==ringorder_ls))
4150        &&
4151        R->block0[n] <= R->N)
4152    {
4153      R->block1[n] = R->N;
4154    }
4155    else
4156    {
4157      Werror("mismatch of number of vars (%d) and ordering (%d vars)",
4158             R->N,R->block1[n]);
4159      return TRUE;
4160    }
4161  }
4162  R->OrdSgn = typ;
4163  return FALSE;
4164}
4165
4166BOOLEAN rSleftvList2StringArray(sleftv* sl, char** p)
4167{
4168
4169  while(sl!=NULL)
4170  {
4171    if (sl->Name() == sNoName)
4172    {
4173      if (sl->Typ()==POLY_CMD)
4174      {
4175        sleftv s_sl;
4176        iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
4177        if (s_sl.Name() != sNoName)
4178          *p = omStrDup(s_sl.Name());
4179        else
4180          *p = NULL;
4181        sl->next = s_sl.next;
4182        s_sl.next = NULL;
4183        s_sl.CleanUp();
4184        if (*p == NULL) return TRUE;
4185      }
4186      else
4187        return TRUE;
4188    }
4189    else
4190      *p = omStrDup(sl->Name());
4191    p++;
4192    sl=sl->next;
4193  }
4194  return FALSE;
4195}
4196
4197////////////////////
4198//
4199// rInit itself:
4200//
4201// INPUT:  s: name, pn: ch & parameter (names), rv: variable (names)
4202//         ord: ordering
4203// RETURN: currRingHdl on success
4204//         NULL        on error
4205// NOTE:   * makes new ring to current ring, on success
4206//         * considers input sleftv's as read-only
4207//idhdl rInit(char *s, sleftv* pn, sleftv* rv, sleftv* ord)
4208ring rInit(sleftv* pn, sleftv* rv, sleftv* ord)
4209{
4210  int ch;
4211  int float_len=0;
4212  int float_len2=0;
4213  ring R = NULL;
4214  idhdl tmp = NULL;
4215  BOOLEAN ffChar=FALSE;
4216  int typ = 1;
4217
4218  /* ch -------------------------------------------------------*/
4219  // get ch of ground field
4220  int numberOfAllocatedBlocks;
4221
4222  if (pn->Typ()==INT_CMD)
4223  {
4224    ch=(int)pn->Data();
4225  }
4226  else if ((pn->name != NULL)
4227  && ((strcmp(pn->name,"real")==0) || (strcmp(pn->name,"complex")==0)))
4228  {
4229    BOOLEAN complex_flag=(strcmp(pn->name,"complex")==0);
4230    ch=-1;
4231    if ((pn->next!=NULL) && (pn->next->Typ()==INT_CMD))
4232    {
4233      float_len=(int)pn->next->Data();
4234      float_len2=float_len;
4235      pn=pn->next;
4236      if ((pn->next!=NULL) && (pn->next->Typ()==INT_CMD))
4237      {
4238        float_len2=(int)pn->next->Data();
4239        pn=pn->next;
4240      }
4241    }
4242    if ((pn->next==NULL) && complex_flag)
4243    {
4244      pn->next=(leftv)omAlloc0Bin(sleftv_bin);
4245      pn->next->name=omStrDup("i");
4246    }
4247  }
4248  else
4249  {
4250    Werror("Wrong ground field specification");
4251    goto rInitError;
4252  }
4253  pn=pn->next;
4254
4255  int l, last;
4256  sleftv * sl;
4257  /*every entry in the new ring is initialized to 0*/
4258
4259  /* characteristic -----------------------------------------------*/
4260  /* input: 0 ch=0 : Q     parameter=NULL    ffChar=FALSE   float_len
4261   *         0    1 : Q(a,...)        *names         FALSE
4262   *         0   -1 : R               NULL           FALSE  0
4263   *         0   -1 : R               NULL           FALSE  prec. >6
4264   *         0   -1 : C               *names         FALSE  prec. 0..?
4265   *         p    p : Fp              NULL           FALSE
4266   *         p   -p : Fp(a)           *names         FALSE
4267   *         q    q : GF(q=p^n)       *names         TRUE
4268  */
4269  if (ch!=-1)
4270  {
4271    int l = 0;
4272
4273    if (ch!=0 && (ch<2)
4274    #ifndef NV_OPS
4275    || (ch > 32003)
4276    #endif
4277    )
4278    {
4279      Warn("%d is invalid characteristic of ground field. 32003 is used.", ch);
4280      ch=32003;
4281    }
4282    // load fftable, if necessary
4283    if (pn!=NULL)
4284    {
4285      while ((ch!=fftable[l]) && (fftable[l])) l++;
4286      if (fftable[l]==0) ch = IsPrime(ch);
4287      else
4288      {
4289        char *m[1]={(char *)sNoName};
4290        nfSetChar(ch,m);
4291        if (errorreported) goto rInitError;
4292        else ffChar=TRUE;
4293      }
4294    }
4295    else
4296      ch = IsPrime(ch);
4297  }
4298  // allocated ring and set ch
4299  R = (ring) omAlloc0Bin(sip_sring_bin);
4300  R->ch = ch;
4301  if (ch == -1)
4302  {
4303    R->float_len= si_min(float_len,32767);
4304    R->float_len2= si_min(float_len2,32767);
4305  }
4306
4307  /* parameter -------------------------------------------------------*/
4308  if (pn!=NULL)
4309  {
4310    R->P=pn->listLength();
4311    //if ((ffChar|| (ch == 1)) && (R->P > 1))
4312    if ((R->P > 1) && (ffChar || (ch == -1)))
4313    {
4314      WerrorS("too many parameters");
4315      goto rInitError;
4316    }
4317    R->parameter=(char**)omAlloc0(R->P*sizeof(char_ptr));
4318    if (rSleftvList2StringArray(pn, R->parameter))
4319    {
4320      WerrorS("parameter expected");
4321      goto rInitError;
4322    }
4323    if (ch>1 && !ffChar) R->ch=-ch;
4324    else if (ch==0) R->ch=1;
4325  }
4326  else if (ffChar)
4327  {
4328    WerrorS("need one parameter");
4329    goto rInitError;
4330  }
4331  /* post-processing of field description */
4332  // we have short reals, but no short complex
4333  if ((R->ch == - 1)
4334  && (R->parameter !=NULL)
4335  && (R->float_len < SHORT_REAL_LENGTH))
4336  {
4337    R->float_len = SHORT_REAL_LENGTH;
4338    R->float_len2 = SHORT_REAL_LENGTH;
4339  }
4340
4341  /* names and number of variables-------------------------------------*/
4342  {
4343    int l=rv->listLength();
4344#if SIZEOF_SHORT == 2
4345#define MAX_SHORT 0x7fff
4346#endif
4347    if (l>MAX_SHORT)
4348    {
4349      Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
4350       goto rInitError;
4351    }
4352    R->N = l; /*rv->listLength();*/
4353  }
4354  R->names   = (char **)omAlloc0(R->N * sizeof(char_ptr));
4355  if (rSleftvList2StringArray(rv, R->names))
4356  {
4357    WerrorS("name of ring variable expected");
4358    goto rInitError;
4359  }
4360
4361  /* check names and parameters for conflicts ------------------------- */
4362  {
4363    int i,j;
4364    for(i=0;i<R->P; i++)
4365    {
4366      for(j=0;j<R->N;j++)
4367      {
4368        if (strcmp(R->parameter[i],R->names[j])==0)
4369        {
4370          Werror("parameter %d conflicts with variable %d",i+1,j+1);
4371          goto rInitError;
4372        }
4373      }
4374    }
4375  }
4376  /* ordering -------------------------------------------------------------*/
4377  if (rSleftvOrdering2Ordering(ord, R))
4378    goto rInitError;
4379
4380  // Complete the initialization
4381  if (rComplete(R,1))
4382    goto rInitError;
4383
4384  rTest(R);
4385
4386  // try to enter the ring into the name list
4387  // need to clean up sleftv here, before this ring can be set to
4388  // new currRing or currRing can be killed beacuse new ring has
4389  // same name
4390  if (pn != NULL) pn->CleanUp();
4391  if (rv != NULL) rv->CleanUp();
4392  if (ord != NULL) ord->CleanUp();
4393  //if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
4394  //  goto rInitError;
4395
4396  //memcpy(IDRING(tmp),R,sizeof(*R));
4397  // set current ring
4398  //omFreeBin(R,  ip_sring_bin);
4399  //return tmp;
4400  return R;
4401
4402  // error case:
4403  rInitError:
4404  if  (R != NULL) rDelete(R);
4405  if (pn != NULL) pn->CleanUp();
4406  if (rv != NULL) rv->CleanUp();
4407  if (ord != NULL) ord->CleanUp();
4408  return NULL;
4409}
4410
4411void rKill(ring r)
4412{
4413  if ((r->ref<=0)&&(r->order!=NULL))
4414  {
4415#ifdef RDEBUG
4416    if (traceit &TRACE_SHOW_RINGS) Print("kill ring %x\n",r);
4417#endif
4418    if (r==currRing)
4419    {
4420      if (r->qideal!=NULL)
4421      {
4422        idDelete(&r->qideal);
4423        r->qideal=NULL;
4424        currQuotient=NULL;
4425      }
4426      if (ppNoether!=NULL) pDelete(&ppNoether);
4427      if (sLastPrinted.RingDependend())
4428      {
4429        sLastPrinted.CleanUp();
4430      }
4431      if ((myynest>0) && (iiRETURNEXPR[myynest].RingDependend()))
4432      {
4433        WerrorS("return value depends on local ring variable (export missing ?)");
4434        iiRETURNEXPR[myynest].CleanUp();
4435      }
4436      currRing=NULL;
4437      currRingHdl=NULL;
4438    }
4439    else if (r->qideal!=NULL)
4440    {
4441      id_Delete(&r->qideal, r);
4442      r->qideal = NULL;
4443    }
4444    int i=1;
4445    int j;
4446    int *pi=r->order;
4447#ifdef USE_IILOCALRING
4448    for (j=0;j<iiRETURNEXPR_len;j++)
4449    {
4450      if (iiLocalRing[j]==r)
4451      {
4452        if (j<myynest) Warn("killing the basering for level %d",j);
4453        iiLocalRing[j]=NULL;
4454      }
4455    }
4456#else /* USE_IILOCALRING */
4457//#endif /* USE_IILOCALRING */
4458    {
4459      proclevel * nshdl = procstack;
4460      int lev=myynest-1;
4461
4462      for(; nshdl != NULL; nshdl = nshdl->next)
4463      {
4464        if (nshdl->cRing==r)
4465        {
4466          Warn("killing the basering for level %d",lev);
4467          nshdl->cRing=NULL;
4468          nshdl->cRingHdl=NULL;
4469        }
4470      }
4471    }
4472#endif /* USE_IILOCALRING */
4473
4474    /* nKillChar(r); will be called from inside of rDelete */
4475    rDelete(r);
4476    return;
4477  }
4478  r->ref--;
4479}
4480
4481void rKill(idhdl h)
4482{
4483  ring r = IDRING(h);
4484  int ref=0;
4485  if (r!=NULL)
4486  {
4487    ref=r->ref;
4488    rKill(r);
4489  }
4490  if (h==currRingHdl)
4491  {
4492    if (ref<=0) { currRing=NULL; currRingHdl=NULL;}
4493    else
4494    {
4495      currRingHdl=rFindHdl(r,currRingHdl,NULL);
4496    }
4497  }
4498}
4499
4500idhdl rSimpleFindHdl(ring r, idhdl root, idhdl n=NULL)
4501{
4502  //idhdl next_best=NULL;
4503  idhdl h=root;
4504  while (h!=NULL)
4505  {
4506    if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
4507    && (h!=n)
4508    && (IDRING(h)==r)
4509    )
4510    {
4511   //   if (IDLEV(h)==myynest)
4512   //     return h;
4513   //   if ((IDLEV(h)==0) || (next_best==NULL))
4514   //     next_best=h;
4515   //   else if (IDLEV(next_best)<IDLEV(h))
4516   //     next_best=h;
4517      return h;
4518    }
4519    h=IDNEXT(h);
4520  }
4521  //return next_best;
4522  return NULL;
4523}
4524
Note: See TracBrowser for help on using the repository browser.