Context Navigation

source: git/Singular/ipshell.cc @ d033ef8

fieker-DuValspielwiese

Last change on this file since d033ef8 was d033ef8, checked in by Hans Schoenemann <hannes@…>, 7 years ago
fix: undefined memeory in rComposeRing ("integer",2,10)
Property mode set to `100644`
File size: 159.1 KB

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

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

Download in other formats: