Context Navigation

source: git/Singular/ipshell.cc @ c1b1bf0

spielwiese

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

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

Download in other formats: