Context Navigation

source: git/Singular/ipshell.cc @ 313806

spielwiese

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

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

Download in other formats: