Context Navigation

source: git/Singular/ipshell.cc @ e6f922f

spielwiese

Last change on this file since e6f922f was e6f922f, checked in by Hans Schönemann <hannes@…>, 18 years ago
*hannes: fixed q-ideal with different mon. representations git-svn-id: file:///usr/local/Singular/svn/trunk@8339 2c84dea3-7e68-4137-9b89-c4e89433aadc
Property mode set to `100644`
File size: 108.2 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: