Context Navigation

source: git/Singular/ipshell.cc @ 4bada2

spielwiese

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

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

Download in other formats: