Context Navigation

source: git/Singular/ipshell.cc @ cb72d2

spielwiese

Last change on this file since cb72d2 was cb72d2, checked in by Hans Schoenemann <hannes@…>, 6 years ago
fix: missing HAVE_SHIFTBBA and rIsLPRing test
Property mode set to `100644`
File size: 161.5 KB

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

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

Download in other formats: