Context Navigation

source: git/Singular/ipshell.cc @ f6b8d2e

fieker-DuValspielwiese

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

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

Download in other formats: