Context Navigation

source: git/Singular/ipshell.cc @ 7310bdd

fieker-DuValspielwiese

Last change on this file since 7310bdd was 469903, checked in by Hans Schoenemann <hannes@…>, 8 years ago
cooperation of .lib and .so: keep example and help part from *.lib
Property mode set to `100644`
File size: 158.7 KB

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

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

Download in other formats: