Context Navigation

source: git/Singular/ipshell.cc @ 0033756

fieker-DuValspielwiese

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

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

Download in other formats: