Context Navigation

source: git/Singular/ipshell.cc @ 0b0d1e

fieker-DuValspielwiese

Last change on this file since 0b0d1e was 52e6ef, checked in by Hans Schoenemann <hannes@…>, 8 years ago
chg: use misc/auxiliary.h in libpolys and kernel/mod2.h in Singular for config
Property mode set to `100644`
File size: 158.9 KB

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

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

Download in other formats: