Context Navigation

ipshell.cc @ c46f94

spielwiese

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