Context Navigation

source: git/Singular/ipshell.cc @ 1f547ed

fieker-DuValspielwiese

Last change on this file since 1f547ed was 1f547ed, checked in by Hans Schoenemann <hannes@…>, 3 years ago
fix: tr. #873 (redef. trans. ext. rings)
Property mode set to `100644`
File size: 162.8 KB

Line
1	/****************************************
2	* Computer Algebra System SINGULAR *
3	****************************************/
4	/*
5	* ABSTRACT:
6	*/
7
8	#include "kernel/mod2.h"
9
10	#include "factory/factory.h"
11
12	#include "misc/options.h"
13	#include "misc/mylimits.h"
14	#include "misc/intvec.h"
15	#include "misc/prime.h"
16
17	#include "coeffs/numbers.h"
18	#include "coeffs/coeffs.h"
19
20	#include "coeffs/rmodulon.h"
21	#include "coeffs/longrat.h"
22
23	#include "polys/monomials/ring.h"
24	#include "polys/monomials/maps.h"
25
26	#include "polys/prCopy.h"
27	#include "polys/matpol.h"
28
29	#include "polys/weight.h"
30	#include "polys/clapsing.h"
31
32
33	#include "polys/ext_fields/algext.h"
34	#include "polys/ext_fields/transext.h"
35
36	#include "kernel/polys.h"
37	#include "kernel/ideals.h"
38
39	#include "kernel/numeric/mpr_base.h"
40	#include "kernel/numeric/mpr_numeric.h"
41
42	#include "kernel/GBEngine/syz.h"
43	#include "kernel/GBEngine/kstd1.h"
44	#include "kernel/GBEngine/kutil.h" // denominator_list
45
46	#include "kernel/combinatorics/stairc.h"
47	#include "kernel/combinatorics/hutil.h"
48
49	#include "kernel/spectrum/semic.h"
50	#include "kernel/spectrum/splist.h"
51	#include "kernel/spectrum/spectrum.h"
52
53	#include "kernel/oswrapper/feread.h"
54
55	#include "Singular/lists.h"
56	#include "Singular/attrib.h"
57	#include "Singular/ipconv.h"
58	#include "Singular/links/silink.h"
59	#include "Singular/ipshell.h"
60	#include "Singular/maps_ip.h"
61	#include "Singular/tok.h"
62	#include "Singular/ipid.h"
63	#include "Singular/subexpr.h"
64	#include "Singular/fevoices.h"
65	#include "Singular/sdb.h"
66
67	#include <cmath>
68	#include <ctype.h>
69
70	#include "kernel/maps/gen_maps.h"
71
72	#include "polys/clapsing.h"
73
74	#ifdef SINGULAR_4_2
75	#include "Singular/number2.h"
76	#include "coeffs/bigintmat.h"
77	#endif
78	VAR leftv iiCurrArgs=NULL;
79	VAR idhdl iiCurrProc=NULL;
80	const char *lastreserved=NULL;
81
82	STATIC_VAR BOOLEAN iiNoKeepRing=TRUE;
83
84	/0 implementation/
85
86	const char * iiTwoOps(int t)
87	{
88	if (t<127)
89	{
90	STATIC_VAR char ch[2];
91	switch (t)
92	{
93	case '&':
94	return "and";
95	case '\|':
96	return "or";
97	default:
98	ch[0]=t;
99	ch[1]='\0';
100	return ch;
101	}
102	}
103	switch (t)
104	{
105	case COLONCOLON: return "::";
106	case DOTDOT: return "..";
107	//case PLUSEQUAL: return "+=";
108	//case MINUSEQUAL: return "-=";
109	case MINUSMINUS: return "--";
110	case PLUSPLUS: return "++";
111	case EQUAL_EQUAL: return "==";
112	case LE: return "<=";
113	case GE: return ">=";
114	case NOTEQUAL: return "<>";
115	default: return Tok2Cmdname(t);
116	}
117	}
118
119	int iiOpsTwoChar(const char *s)
120	{
121	/* not handling: &&, \|\|, ** */
122	if (s[1]=='\0') return s[0];
123	else if (s[2]!='\0') return 0;
124	switch(s[0])
125	{
126	case '.': if (s[1]=='.') return DOTDOT;
127	else return 0;
128	case ':': if (s[1]==':') return COLONCOLON;
129	else return 0;
130	case '-': if (s[1]=='-') return MINUSMINUS;
131	else return 0;
132	case '+': if (s[1]=='+') return PLUSPLUS;
133	else return 0;
134	case '=': if (s[1]=='=') return EQUAL_EQUAL;
135	else return 0;
136	case '<': if (s[1]=='=') return LE;
137	else if (s[1]=='>') return NOTEQUAL;
138	else return 0;
139	case '>': if (s[1]=='=') return GE;
140	else return 0;
141	case '!': if (s[1]=='=') return NOTEQUAL;
142	else return 0;
143	}
144	return 0;
145	}
146
147	static void list1(const char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
148	{
149	char buffer[22];
150	int l;
151	char buf2[128];
152
153	if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
154	else sprintf(buf2, "%s", IDID(h));
155
156	Print("%s%-30.30s [%d] ",s,buf2,IDLEV(h));
157	if (h == currRingHdl) PrintS("*");
158	PrintS(Tok2Cmdname((int)IDTYP(h)));
159
160	ipListFlag(h);
161	switch(IDTYP(h))
162	{
163	case ALIAS_CMD: Print(" for %s",IDID((idhdl)IDDATA(h))); break;
164	case INT_CMD: Print(" %d",IDINT(h)); break;
165	case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
166	case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
167	break;
168	case POLY_CMD:
169	case VECTOR_CMD:if (c)
170	{
171	PrintS(" ");wrp(IDPOLY(h));
172	if(IDPOLY(h) != NULL)
173	{
174	Print(", %d monomial(s)",pLength(IDPOLY(h)));
175	}
176	}
177	break;
178	case MODUL_CMD: Print(", rk %d", (int)(IDIDEAL(h)->rank));// and continue
179	case IDEAL_CMD: Print(", %u generator(s)",
180	IDELEMS(IDIDEAL(h))); break;
181	case MAP_CMD:
182	Print(" from %s",IDMAP(h)->preimage); break;
183	case MATRIX_CMD:Print(" %u x %u"
184	,MATROWS(IDMATRIX(h))
185	,MATCOLS(IDMATRIX(h))
186	);
187	break;
188	case SMATRIX_CMD:Print(" %u x %u"
189	,(int)(IDIDEAL(h)->rank)
190	,IDELEMS(IDIDEAL(h))
191	);
192	break;
193	case PACKAGE_CMD:
194	paPrint(IDID(h),IDPACKAGE(h));
195	break;
196	case PROC_CMD: if((IDPROC(h)->libname!=NULL)
197	&& (strlen(IDPROC(h)->libname)>0))
198	Print(" from %s",IDPROC(h)->libname);
199	if(IDPROC(h)->language==LANG_C)
200	PrintS(" (C)");
201	if(IDPROC(h)->is_static)
202	PrintS(" (static)");
203	break;
204	case STRING_CMD:
205	{
206	char *s;
207	l=strlen(IDSTRING(h));
208	memset(buffer,0,sizeof(buffer));
209	strncpy(buffer,IDSTRING(h),si_min(l,20));
210	if ((s=strchr(buffer,'\n'))!=NULL)
211	{
212	*s='\0';
213	}
214	PrintS(" ");
215	PrintS(buffer);
216	if((s!=NULL) \|\|(l>20))
217	{
218	Print("..., %d char(s)",l);
219	}
220	break;
221	}
222	case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
223	break;
224	case RING_CMD:
225	if ((IDRING(h)==currRing) && (currRingHdl!=h))
226	PrintS("()"); / this is an alias to currRing */
227	//Print(" ref:%d",IDRING(h)->ref);
228	#ifdef RDEBUG
229	if (traceit &TRACE_SHOW_RINGS)
230	Print(" <%lx>",(long)(IDRING(h)));
231	#endif
232	break;
233	#ifdef SINGULAR_4_2
234	case CNUMBER_CMD:
235	{ number2 n=(number2)IDDATA(h);
236	Print(" (%s)",nCoeffName(n->cf));
237	break;
238	}
239	case CMATRIX_CMD:
240	{ bigintmat b=(bigintmat)IDDATA(h);
241	Print(" %d x %d (%s)",
242	b->rows(),b->cols(),
243	nCoeffName(b->basecoeffs()));
244	break;
245	}
246	#endif
247	/default: break;/
248	}
249	PrintLn();
250	}
251
252	void type_cmd(leftv v)
253	{
254	BOOLEAN oldShortOut = FALSE;
255
256	if (currRing != NULL)
257	{
258	oldShortOut = currRing->ShortOut;
259	currRing->ShortOut = 1;
260	}
261	int t=v->Typ();
262	Print("// %s %s ",v->Name(),Tok2Cmdname(t));
263	switch (t)
264	{
265	case MAP_CMD:Print(" from %s\n",((map)(v->Data()))->preimage); break;
266	case INTMAT_CMD: Print(" %d x %d\n",((intvec*)(v->Data()))->rows(),
267	((intvec*)(v->Data()))->cols()); break;
268	case MATRIX_CMD:Print(" %u x %u\n" ,
269	MATROWS((matrix)(v->Data())),
270	MATCOLS((matrix)(v->Data())));break;
271	case MODUL_CMD: Print(", rk %d\n", (int)(((ideal)(v->Data()))->rank));break;
272	case LIST_CMD: Print(", size %d\n",((lists)(v->Data()))->nr+1); break;
273
274	case PROC_CMD:
275	case RING_CMD:
276	case IDEAL_CMD: PrintLn(); break;
277
278	//case INT_CMD:
279	//case STRING_CMD:
280	//case INTVEC_CMD:
281	//case POLY_CMD:
282	//case VECTOR_CMD:
283	//case PACKAGE_CMD:
284
285	default:
286	break;
287	}
288	v->Print();
289	if (currRing != NULL)
290	currRing->ShortOut = oldShortOut;
291	}
292
293	static void killlocals0(int v, idhdl * localhdl, const ring r)
294	{
295	idhdl h = *localhdl;
296	while (h!=NULL)
297	{
298	int vv;
299	//Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
300	if ((vv=IDLEV(h))>0)
301	{
302	if (vv < v)
303	{
304	if (iiNoKeepRing)
305	{
306	//PrintS(" break\n");
307	return;
308	}
309	h = IDNEXT(h);
310	//PrintLn();
311	}
312	else //if (vv >= v)
313	{
314	idhdl nexth = IDNEXT(h);
315	killhdl2(h,localhdl,r);
316	h = nexth;
317	//PrintS("kill\n");
318	}
319	}
320	else
321	{
322	h = IDNEXT(h);
323	//PrintLn();
324	}
325	}
326	}
327
328	void killlocals_rec(idhdl *root,int v, ring r)
329	{
330	idhdl h=*root;
331	while (h!=NULL)
332	{
333	if (IDLEV(h)>=v)
334	{
335	// Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
336	idhdl n=IDNEXT(h);
337	killhdl2(h,root,r);
338	h=n;
339	}
340	else if (IDTYP(h)==PACKAGE_CMD)
341	{
342	// Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
343	if (IDPACKAGE(h)!=basePack)
344	killlocals_rec(&(IDRING(h)->idroot),v,r);
345	h=IDNEXT(h);
346	}
347	else if (IDTYP(h)==RING_CMD)
348	{
349	if ((IDRING(h)!=NULL) && (IDRING(h)->idroot!=NULL))
350	// we have to test IDRING(h)!=NULL: qring Q=groebner(...): killlocals
351	{
352	// Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
353	killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
354	}
355	h=IDNEXT(h);
356	}
357	else
358	{
359	// Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
360	h=IDNEXT(h);
361	}
362	}
363	}
364	BOOLEAN killlocals_list(int v, lists L)
365	{
366	if (L==NULL) return FALSE;
367	BOOLEAN changed=FALSE;
368	int n=L->nr;
369	for(;n>=0;n--)
370	{
371	leftv h=&(L->m[n]);
372	void *d=h->data;
373	if ((h->rtyp==RING_CMD)
374	&& (((ring)d)->idroot!=NULL))
375	{
376	if (d!=currRing) {changed=TRUE;rChangeCurrRing((ring)d);}
377	killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
378	}
379	else if (h->rtyp==LIST_CMD)
380	changed\|=killlocals_list(v,(lists)d);
381	}
382	return changed;
383	}
384	void killlocals(int v)
385	{
386	BOOLEAN changed=FALSE;
387	idhdl sh=currRingHdl;
388	ring cr=currRing;
389	if (sh!=NULL) changed=((IDLEV(sh)<v) \|\| (IDRING(sh)->ref>0));
390	//if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
391
392	killlocals_rec(&(basePack->idroot),v,currRing);
393
394	if (iiRETURNEXPR_len > myynest)
395	{
396	int t=iiRETURNEXPR.Typ();
397	if (/iiRETURNEXPR.Typ()/ t==RING_CMD)
398	{
399	leftv h=&iiRETURNEXPR;
400	if (((ring)h->data)->idroot!=NULL)
401	killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
402	}
403	else if (/iiRETURNEXPR.Typ()/ t==LIST_CMD)
404	{
405	leftv h=&iiRETURNEXPR;
406	changed \|=killlocals_list(v,(lists)h->data);
407	}
408	}
409	if (changed)
410	{
411	currRingHdl=rFindHdl(cr,NULL);
412	if (currRingHdl==NULL)
413	currRing=NULL;
414	else if(cr!=currRing)
415	rChangeCurrRing(cr);
416	}
417
418	if (myynest<=1) iiNoKeepRing=TRUE;
419	//Print("end killlocals >= %d\n",v);
420	//listall();
421	}
422
423	void list_cmd(int typ, const char* what, const char *prefix,BOOLEAN iterate, BOOLEAN fullname)
424	{
425	package savePack=currPack;
426	idhdl h,start;
427	BOOLEAN all = typ<0;
428	BOOLEAN really_all=FALSE;
429
430	if ( typ==0 )
431	{
432	if (strcmp(what,"all")==0)
433	{
434	if (currPack!=basePack)
435	list_cmd(-1,NULL,prefix,iterate,fullname); // list current package
436	really_all=TRUE;
437	h=basePack->idroot;
438	}
439	else
440	{
441	h = ggetid(what);
442	if (h!=NULL)
443	{
444	if (iterate) list1(prefix,h,TRUE,fullname);
445	if (IDTYP(h)==ALIAS_CMD) PrintS("A");
446	if ((IDTYP(h)==RING_CMD)
447	//\|\| (IDTYP(h)==PACKAGE_CMD)
448	)
449	{
450	h=IDRING(h)->idroot;
451	}
452	else if(IDTYP(h)==PACKAGE_CMD)
453	{
454	currPack=IDPACKAGE(h);
455	//Print("list_cmd:package\n");
456	all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
457	h=IDPACKAGE(h)->idroot;
458	}
459	else
460	{
461	currPack=savePack;
462	return;
463	}
464	}
465	else
466	{
467	Werror("%s is undefined",what);
468	currPack=savePack;
469	return;
470	}
471	}
472	all=TRUE;
473	}
474	else if (RingDependend(typ))
475	{
476	h = currRing->idroot;
477	}
478	else
479	h = IDROOT;
480	start=h;
481	while (h!=NULL)
482	{
483	if ((all
484	&& (IDTYP(h)!=PROC_CMD)
485	&&(IDTYP(h)!=PACKAGE_CMD)
486	&&(IDTYP(h)!=CRING_CMD)
487	)
488	\|\| (typ == IDTYP(h))
489	\|\| ((IDTYP(h)==CRING_CMD) && (typ==RING_CMD))
490	)
491	{
492	list1(prefix,h,start==currRingHdl, fullname);
493	if ((IDTYP(h)==RING_CMD)
494	&& (really_all \|\| (all && (h==currRingHdl)))
495	&& ((IDLEV(h)==0)\|\|(IDLEV(h)==myynest)))
496	{
497	list_cmd(0,IDID(h),"// ",FALSE);
498	}
499	if (IDTYP(h)==PACKAGE_CMD && really_all)
500	{
501	package save_p=currPack;
502	currPack=IDPACKAGE(h);
503	list_cmd(0,IDID(h),"// ",FALSE);
504	currPack=save_p;
505	}
506	}
507	h = IDNEXT(h);
508	}
509	currPack=savePack;
510	}
511
512	void test_cmd(int i)
513	{
514	int ii;
515
516	if (i<0)
517	{
518	ii= -i;
519	if (ii < 32)
520	{
521	si_opt_1 &= ~Sy_bit(ii);
522	}
523	else if (ii < 64)
524	{
525	si_opt_2 &= ~Sy_bit(ii-32);
526	}
527	else
528	WerrorS("out of bounds\n");
529	}
530	else if (i<32)
531	{
532	ii=i;
533	if (Sy_bit(ii) & kOptions)
534	{
535	WarnS("Gerhard, use the option command");
536	si_opt_1 \|= Sy_bit(ii);
537	}
538	else if (Sy_bit(ii) & validOpts)
539	si_opt_1 \|= Sy_bit(ii);
540	}
541	else if (i<64)
542	{
543	ii=i-32;
544	si_opt_2 \|= Sy_bit(ii);
545	}
546	else
547	WerrorS("out of bounds\n");
548	}
549
550	int exprlist_length(leftv v)
551	{
552	int rc = 0;
553	while (v!=NULL)
554	{
555	switch (v->Typ())
556	{
557	case INT_CMD:
558	case POLY_CMD:
559	case VECTOR_CMD:
560	case NUMBER_CMD:
561	rc++;
562	break;
563	case INTVEC_CMD:
564	case INTMAT_CMD:
565	rc += ((intvec *)(v->Data()))->length();
566	break;
567	case MATRIX_CMD:
568	case IDEAL_CMD:
569	case MODUL_CMD:
570	{
571	matrix mm = (matrix)(v->Data());
572	rc += mm->rows() * mm->cols();
573	}
574	break;
575	case LIST_CMD:
576	rc+=((lists)v->Data())->nr+1;
577	break;
578	default:
579	rc++;
580	}
581	v = v->next;
582	}
583	return rc;
584	}
585
586	BOOLEAN iiWRITE(leftv,leftv v)
587	{
588	sleftv vf;
589	if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
590	{
591	WerrorS("link expected");
592	return TRUE;
593	}
594	si_link l=(si_link)vf.Data();
595	if (vf.next == NULL)
596	{
597	WerrorS("write: need at least two arguments");
598	return TRUE;
599	}
600
601	BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
602	if (b)
603	{
604	const char *s;
605	if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
606	else s=sNoName_fe;
607	Werror("cannot write to %s",s);
608	}
609	vf.CleanUp();
610	return b;
611	}
612
613	leftv iiMap(map theMap, const char * what)
614	{
615	idhdl w,r;
616	leftv v;
617	int i;
618	nMapFunc nMap;
619
620	r=IDROOT->get(theMap->preimage,myynest);
621	if ((currPack!=basePack)
622	&&((r==NULL) \|\| ((r->typ != RING_CMD) )))
623	r=basePack->idroot->get(theMap->preimage,myynest);
624	if ((r==NULL) && (currRingHdl!=NULL)
625	&& (strcmp(theMap->preimage,IDID(currRingHdl))==0))
626	{
627	r=currRingHdl;
628	}
629	if ((r!=NULL) && (r->typ == RING_CMD))
630	{
631	ring src_ring=IDRING(r);
632	if ((nMap=n_SetMap(src_ring->cf, currRing->cf))==NULL)
633	{
634	Werror("can not map from ground field of %s to current ground field",
635	theMap->preimage);
636	return NULL;
637	}
638	if (IDELEMS(theMap)<src_ring->N)
639	{
640	theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
641	IDELEMS(theMap)*sizeof(poly),
642	(src_ring->N)*sizeof(poly));
643	for(i=IDELEMS(theMap);i<src_ring->N;i++)
644	theMap->m[i]=NULL;
645	IDELEMS(theMap)=src_ring->N;
646	}
647	if (what==NULL)
648	{
649	WerrorS("argument of a map must have a name");
650	}
651	else if ((w=src_ring->idroot->get(what,myynest))!=NULL)
652	{
653	char *save_r=NULL;
654	v=(leftv)omAlloc0Bin(sleftv_bin);
655	sleftv tmpW;
656	tmpW.Init();
657	tmpW.rtyp=IDTYP(w);
658	if (tmpW.rtyp==MAP_CMD)
659	{
660	tmpW.rtyp=IDEAL_CMD;
661	save_r=IDMAP(w)->preimage;
662	IDMAP(w)->preimage=0;
663	}
664	tmpW.data=IDDATA(w);
665	// check overflow
666	BOOLEAN overflow=FALSE;
667	if ((tmpW.rtyp==IDEAL_CMD)
668	\|\| (tmpW.rtyp==MODUL_CMD)
669	\|\| (tmpW.rtyp==MAP_CMD))
670	{
671	ideal id=(ideal)tmpW.data;
672	long degs=(long)omAlloc(IDELEMS(id)*sizeof(long));
673	for(int i=IDELEMS(id)-1;i>=0;i--)
674	{
675	poly p=id->m[i];
676	if (p!=NULL) degs[i]=p_Totaldegree(p,src_ring);
677	else degs[i]=0;
678	}
679	for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
680	{
681	if (theMap->m[j]!=NULL)
682	{
683	long deg_monexp=pTotaldegree(theMap->m[j]);
684
685	for(int i=IDELEMS(id)-1;i>=0;i--)
686	{
687	poly p=id->m[i];
688	if ((p!=NULL) && (degs[i]!=0) &&
689	((unsigned long)deg_monexp > (currRing->bitmask / ((unsigned long)degs[i])/2)))
690	{
691	overflow=TRUE;
692	break;
693	}
694	}
695	}
696	}
697	omFreeSize(degs,IDELEMS(id)*sizeof(long));
698	}
699	else if (tmpW.rtyp==POLY_CMD)
700	{
701	for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
702	{
703	if (theMap->m[j]!=NULL)
704	{
705	long deg_monexp=pTotaldegree(theMap->m[j]);
706	poly p=(poly)tmpW.data;
707	long deg=0;
708	if ((p!=NULL) && ((deg=p_Totaldegree(p,src_ring))!=0) &&
709	((unsigned long)deg_monexp > (currRing->bitmask / ((unsigned long)deg)/2)))
710	{
711	overflow=TRUE;
712	break;
713	}
714	}
715	}
716	}
717	if (overflow)
718	Warn("possible OVERFLOW in map, max exponent is %ld",currRing->bitmask/2);
719	#if 0
720	if (((tmpW.rtyp==IDEAL_CMD)\|\|(tmpW.rtyp==MODUL_CMD)) && idIs0(IDIDEAL(w)))
721	{
722	v->rtyp=tmpW.rtyp;
723	v->data=idInit(IDELEMS(IDIDEAL(w)),IDIDEAL(w)->rank);
724	}
725	else
726	#endif
727	{
728	if ((tmpW.rtyp==IDEAL_CMD)
729	\|\|(tmpW.rtyp==MODUL_CMD)
730	\|\|(tmpW.rtyp==MATRIX_CMD)
731	\|\|(tmpW.rtyp==MAP_CMD))
732	{
733	v->rtyp=tmpW.rtyp;
734	char *tmp = theMap->preimage;
735	theMap->preimage=(char*)1L;
736	// map gets 1 as its rank (as an ideal)
737	v->data=maMapIdeal(IDIDEAL(w), src_ring, (ideal)theMap, currRing,nMap);
738	theMap->preimage=tmp; // map gets its preimage back
739	}
740	if (v->data==NULL) /i.e. not IDEAL_CMD/MODUL_CMD/MATRIX_CMD/MAP /
741	{
742	if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,src_ring,NULL,NULL,0,nMap))
743	{
744	Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
745	omFreeBin((ADDRESS)v, sleftv_bin);
746	if (save_r!=NULL) IDMAP(w)->preimage=save_r;
747	return NULL;
748	}
749	}
750	}
751	if (save_r!=NULL)
752	{
753	IDMAP(w)->preimage=save_r;
754	IDMAP((idhdl)v)->preimage=omStrDup(save_r);
755	v->rtyp=MAP_CMD;
756	}
757	return v;
758	}
759	else
760	{
761	Werror("%s undefined in %s",what,theMap->preimage);
762	}
763	}
764	else
765	{
766	Werror("cannot find preimage %s",theMap->preimage);
767	}
768	return NULL;
769	}
770
771	#ifdef OLD_RES
772	void iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
773	intvec ** weights)
774	{
775	lists L=liMakeResolv(r,length,rlen,typ0,weights);
776	int i=0;
777	idhdl h;
778	char * s=(char *)omAlloc(strlen(name)+5);
779
780	while (i<=L->nr)
781	{
782	sprintf(s,"%s(%d)",name,i+1);
783	if (i==0)
784	h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
785	else
786	h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
787	if (h!=NULL)
788	{
789	h->data.uideal=(ideal)L->m[i].data;
790	h->attribute=L->m[i].attribute;
791	if (BVERBOSE(V_DEF_RES))
792	Print("//defining: %s as %d-th syzygy module\n",s,i+1);
793	}
794	else
795	{
796	idDelete((ideal *)&(L->m[i].data));
797	Warn("cannot define %s",s);
798	}
799	//L->m[i].data=NULL;
800	//L->m[i].rtyp=0;
801	//L->m[i].attribute=NULL;
802	i++;
803	}
804	omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
805	omFreeBin((ADDRESS)L, slists_bin);
806	omFreeSize((ADDRESS)s,strlen(name)+5);
807	}
808	#endif
809
810	//resolvente iiFindRes(char * name, int * len, int *typ0)
811	//{
812	// char s=(char )omAlloc(strlen(name)+5);
813	// int i=-1;
814	// resolvente r;
815	// idhdl h;
816	//
817	// do
818	// {
819	// i++;
820	// sprintf(s,"%s(%d)",name,i+1);
821	// h=currRing->idroot->get(s,myynest);
822	// } while (h!=NULL);
823	// *len=i-1;
824	// if (*len<=0)
825	// {
826	// Werror("no objects %s(1),.. found",name);
827	// omFreeSize((ADDRESS)s,strlen(name)+5);
828	// return NULL;
829	// }
830	// r=(ideal )omAlloc(/(len+1)/ isizeof(ideal));
831	// memset(r,0,(len)sizeof(ideal));
832	// i=-1;
833	// *typ0=MODUL_CMD;
834	// while (i<(*len))
835	// {
836	// i++;
837	// sprintf(s,"%s(%d)",name,i+1);
838	// h=currRing->idroot->get(s,myynest);
839	// if (h->typ != MODUL_CMD)
840	// {
841	// if ((i!=0) \|\| (h->typ!=IDEAL_CMD))
842	// {
843	// Werror("%s is not of type module",s);
844	// omFreeSize((ADDRESS)r,(len)sizeof(ideal));
845	// omFreeSize((ADDRESS)s,strlen(name)+5);
846	// return NULL;
847	// }
848	// *typ0=IDEAL_CMD;
849	// }
850	// if ((i>0) && (idIs0(r[i-1])))
851	// {
852	// *len=i-1;
853	// break;
854	// }
855	// r[i]=IDIDEAL(h);
856	// }
857	// omFreeSize((ADDRESS)s,strlen(name)+5);
858	// return r;
859	//}
860
861	static resolvente iiCopyRes(resolvente r, int l)
862	{
863	int i;
864	resolvente res=(ideal )omAlloc0((l+1)sizeof(ideal));
865
866	for (i=0; i<l; i++)
867	if (r[i]!=NULL) res[i]=idCopy(r[i]);
868	return res;
869	}
870
871	BOOLEAN jjMINRES(leftv res, leftv v)
872	{
873	int len=0;
874	int typ0;
875	lists L=(lists)v->Data();
876	intvec weights=(intvec)atGet(v,"isHomog",INTVEC_CMD);
877	int add_row_shift = 0;
878	if (weights==NULL)
879	weights=(intvec*)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
880	if (weights!=NULL) add_row_shift=weights->min_in();
881	resolvente rr=liFindRes(L,&len,&typ0);
882	if (rr==NULL) return TRUE;
883	resolvente r=iiCopyRes(rr,len);
884
885	syMinimizeResolvente(r,len,0);
886	omFreeSize((ADDRESS)rr,len*sizeof(ideal));
887	len++;
888	res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL,add_row_shift);
889	return FALSE;
890	}
891
892	BOOLEAN jjBETTI(leftv res, leftv u)
893	{
894	sleftv tmp;
895	tmp.Init();
896	tmp.rtyp=INT_CMD;
897	tmp.data=(void *)1;
898	if ((u->Typ()==IDEAL_CMD)
899	\|\| (u->Typ()==MODUL_CMD))
900	return jjBETTI2_ID(res,u,&tmp);
901	else
902	return jjBETTI2(res,u,&tmp);
903	}
904
905	BOOLEAN jjBETTI2_ID(leftv res, leftv u, leftv v)
906	{
907	lists l=(lists) omAllocBin(slists_bin);
908	l->Init(1);
909	l->m[0].rtyp=u->Typ();
910	l->m[0].data=u->Data();
911	attr *a=u->Attribute();
912	if (a!=NULL)
913	l->m[0].attribute=*a;
914	sleftv tmp2;
915	tmp2.Init();
916	tmp2.rtyp=LIST_CMD;
917	tmp2.data=(void *)l;
918	BOOLEAN r=jjBETTI2(res,&tmp2,v);
919	l->m[0].data=NULL;
920	l->m[0].attribute=NULL;
921	l->m[0].rtyp=DEF_CMD;
922	l->Clean();
923	return r;
924	}
925
926	BOOLEAN jjBETTI2(leftv res, leftv u, leftv v)
927	{
928	resolvente r;
929	int len;
930	int reg,typ0;
931	lists l=(lists)u->Data();
932
933	intvec *weights=NULL;
934	int add_row_shift=0;
935	intvec *ww=NULL;
936	if (l->nr>=0) ww=(intvec *)atGet(&(l->m[0]),"isHomog",INTVEC_CMD);
937	if (ww!=NULL)
938	{
939	weights=ivCopy(ww);
940	add_row_shift = ww->min_in();
941	(*weights) -= add_row_shift;
942	}
943	//Print("attr:%x\n",weights);
944
945	r=liFindRes(l,&len,&typ0);
946	if (r==NULL) return TRUE;
947	intvec* res_im=syBetti(r,len,&reg,weights,(int)(long)v->Data());
948	res->data=(void*)res_im;
949	omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
950	//Print("rowShift: %d ",add_row_shift);
951	for(int i=1;i<=res_im->rows();i++)
952	{
953	if (IMATELEM(*res_im,1,i)==0) { add_row_shift--; }
954	else break;
955	}
956	//Print(" %d\n",add_row_shift);
957	atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
958	if (weights!=NULL) delete weights;
959	return FALSE;
960	}
961
962	int iiRegularity(lists L)
963	{
964	int len,reg,typ0;
965
966	resolvente r=liFindRes(L,&len,&typ0);
967
968	if (r==NULL)
969	return -2;
970	intvec *weights=NULL;
971	int add_row_shift=0;
972	intvec ww=(intvec )atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
973	if (ww!=NULL)
974	{
975	weights=ivCopy(ww);
976	add_row_shift = ww->min_in();
977	(*weights) -= add_row_shift;
978	}
979	//Print("attr:%x\n",weights);
980
981	intvec *dummy=syBetti(r,len,&reg,weights);
982	if (weights!=NULL) delete weights;
983	delete dummy;
984	omFreeSize((ADDRESS)r,len*sizeof(ideal));
985	return reg+1+add_row_shift;
986	}
987
988	VAR BOOLEAN iiDebugMarker=TRUE;
989	#define BREAK_LINE_LENGTH 80
990	void iiDebug()
991	{
992	#ifdef HAVE_SDB
993	sdb_flags=1;
994	#endif
995	Print("\n-- break point in %s --\n",VoiceName());
996	if (iiDebugMarker) VoiceBackTrack();
997	char * s;
998	iiDebugMarker=FALSE;
999	s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
1000	loop
1001	{
1002	memset(s,0,BREAK_LINE_LENGTH+4);
1003	fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
1004	if (s[BREAK_LINE_LENGTH-1]!='\0')
1005	{
1006	Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
1007	}
1008	else
1009	break;
1010	}
1011	if (*s=='\n')
1012	{
1013	iiDebugMarker=TRUE;
1014	}
1015	#if MDEBUG
1016	else if(strncmp(s,"cont;",5)==0)
1017	{
1018	iiDebugMarker=TRUE;
1019	}
1020	#endif /* MDEBUG */
1021	else
1022	{
1023	strcat( s, "\n;~\n");
1024	newBuffer(s,BT_execute);
1025	}
1026	}
1027
1028	lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
1029	{
1030	int i;
1031	indset save;
1032	lists res=(lists)omAlloc0Bin(slists_bin);
1033
1034	hexist = hInit(S, Q, &hNexist, currRing);
1035	if (hNexist == 0)
1036	{
1037	intvec *iv=new intvec(rVar(currRing));
1038	for(i=0; i<rVar(currRing); i++) (*iv)[i]=1;
1039	res->Init(1);
1040	res->m[0].rtyp=INTVEC_CMD;
1041	res->m[0].data=(intvec*)iv;
1042	return res;
1043	}
1044	else if (hisModule!=0)
1045	{
1046	res->Init(0);
1047	return res;
1048	}
1049	save = ISet = (indset)omAlloc0Bin(indlist_bin);
1050	hMu = 0;
1051	hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
1052	hvar = (varset)omAlloc((rVar(currRing) + 1) * sizeof(int));
1053	hpure = (scmon)omAlloc0((1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1054	hrad = hexist;
1055	hNrad = hNexist;
1056	radmem = hCreate(rVar(currRing) - 1);
1057	hCo = rVar(currRing) + 1;
1058	hNvar = rVar(currRing);
1059	hRadical(hrad, &hNrad, hNvar);
1060	hSupp(hrad, hNrad, hvar, &hNvar);
1061	if (hNvar)
1062	{
1063	hCo = hNvar;
1064	hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
1065	hLexR(hrad, hNrad, hvar, hNvar);
1066	hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1067	}
1068	if (hCo && (hCo < rVar(currRing)))
1069	{
1070	hIndMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1071	}
1072	if (hMu!=0)
1073	{
1074	ISet = save;
1075	hMu2 = 0;
1076	if (all && (hCo+1 < rVar(currRing)))
1077	{
1078	JSet = (indset)omAlloc0Bin(indlist_bin);
1079	hIndAllMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1080	i=hMu+hMu2;
1081	res->Init(i);
1082	if (hMu2 == 0)
1083	{
1084	omFreeBin((ADDRESS)JSet, indlist_bin);
1085	}
1086	}
1087	else
1088	{
1089	res->Init(hMu);
1090	}
1091	for (i=0;i<hMu;i++)
1092	{
1093	res->m[i].data = (void *)save->set;
1094	res->m[i].rtyp = INTVEC_CMD;
1095	ISet = save;
1096	save = save->nx;
1097	omFreeBin((ADDRESS)ISet, indlist_bin);
1098	}
1099	omFreeBin((ADDRESS)save, indlist_bin);
1100	if (hMu2 != 0)
1101	{
1102	save = JSet;
1103	for (i=hMu;i<hMu+hMu2;i++)
1104	{
1105	res->m[i].data = (void *)save->set;
1106	res->m[i].rtyp = INTVEC_CMD;
1107	JSet = save;
1108	save = save->nx;
1109	omFreeBin((ADDRESS)JSet, indlist_bin);
1110	}
1111	omFreeBin((ADDRESS)save, indlist_bin);
1112	}
1113	}
1114	else
1115	{
1116	res->Init(0);
1117	omFreeBin((ADDRESS)ISet, indlist_bin);
1118	}
1119	hKill(radmem, rVar(currRing) - 1);
1120	omFreeSize((ADDRESS)hpure, (1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1121	omFreeSize((ADDRESS)hvar, (rVar(currRing) + 1) * sizeof(int));
1122	omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1123	hDelete(hexist, hNexist);
1124	return res;
1125	}
1126
1127	int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
1128	{
1129	BOOLEAN res=FALSE;
1130	BOOLEAN is_qring=FALSE;
1131	const char *id = name->name;
1132
1133	sy->Init();
1134	if ((name->name==NULL)\|\|(isdigit(name->name[0])))
1135	{
1136	WerrorS("object to declare is not a name");
1137	res=TRUE;
1138	}
1139	else
1140	{
1141	if (root==NULL) return TRUE;
1142	if (*root!=IDROOT)
1143	{
1144	if ((currRing==NULL) \|\| (*root!=currRing->idroot))
1145	{
1146	Werror("can not define `%s` in other package",name->name);
1147	return TRUE;
1148	}
1149	}
1150	if (t==QRING_CMD)
1151	{
1152	t=RING_CMD; // qring is always RING_CMD
1153	is_qring=TRUE;
1154	}
1155
1156	if (TEST_V_ALLWARN
1157	&& (name->rtyp!=0)
1158	&& (name->rtyp!=IDHDL)
1159	&& (currRingHdl!=NULL) && (IDLEV(currRingHdl)==myynest))
1160	{
1161	Warn("`%s` is %s in %s:%d:%s",name->name,Tok2Cmdname(name->rtyp),
1162	currentVoice->filename,yylineno,my_yylinebuf);
1163	}
1164	{
1165	sy->data = (char *)enterid(id,lev,t,root,init_b);
1166	}
1167	if (sy->data!=NULL)
1168	{
1169	sy->rtyp=IDHDL;
1170	currid=sy->name=IDID((idhdl)sy->data);
1171	if (is_qring)
1172	{
1173	IDFLAG((idhdl)sy->data)=sy->flag=Sy_bit(FLAG_QRING_DEF);
1174	}
1175	// name->name=NULL; /* used in enterid */
1176	//sy->e = NULL;
1177	if (name->next!=NULL)
1178	{
1179	sy->next=(leftv)omAllocBin(sleftv_bin);
1180	res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
1181	}
1182	}
1183	else res=TRUE;
1184	}
1185	name->CleanUp();
1186	return res;
1187	}
1188
1189	BOOLEAN iiDefaultParameter(leftv p)
1190	{
1191	attr at=NULL;
1192	if (iiCurrProc!=NULL)
1193	at=iiCurrProc->attribute->get("default_arg");
1194	if (at==NULL)
1195	return FALSE;
1196	sleftv tmp;
1197	tmp.Init();
1198	tmp.rtyp=at->atyp;
1199	tmp.data=at->CopyA();
1200	return iiAssign(p,&tmp);
1201	}
1202	BOOLEAN iiBranchTo(leftv, leftv args)
1203	{
1204	// must be inside a proc, as we simultae an proc_end at the end
1205	if (myynest==0)
1206	{
1207	WerrorS("branchTo can only occur in a proc");
1208	return TRUE;
1209	}
1210	// <string1...stringN>,<proc>
1211	// known: args!=NULL, l>=1
1212	int l=args->listLength();
1213	int ll=0;
1214	if (iiCurrArgs!=NULL) ll=iiCurrArgs->listLength();
1215	if (ll!=(l-1)) return FALSE;
1216	leftv h=args;
1217	// set up the table for type test:
1218	short t=(short)omAlloc(l*sizeof(short));
1219	t[0]=l-1;
1220	int b;
1221	int i;
1222	for(i=1;i<l;i++,h=h->next)
1223	{
1224	if (h->Typ()!=STRING_CMD)
1225	{
1226	omFree(t);
1227	Werror("arg %d is not a string",i);
1228	return TRUE;
1229	}
1230	int tt;
1231	b=IsCmd((char *)h->Data(),tt);
1232	if(b) t[i]=tt;
1233	else
1234	{
1235	omFree(t);
1236	Werror("arg %d is not a type name",i);
1237	return TRUE;
1238	}
1239	}
1240	if (h->Typ()!=PROC_CMD)
1241	{
1242	omFree(t);
1243	Werror("last(%d.) arg.(%s) is not a proc(but %s(%d)), nesting=%d",
1244	i,h->name,Tok2Cmdname(h->Typ()),h->Typ(),myynest);
1245	return TRUE;
1246	}
1247	b=iiCheckTypes(iiCurrArgs,t,0);
1248	omFree(t);
1249	if (b && (h->rtyp==IDHDL) && (h->e==NULL))
1250	{
1251	// get the proc:
1252	iiCurrProc=(idhdl)h->data;
1253	idhdl currProc=iiCurrProc; /iiCurrProc may be changed after yyparse/
1254	procinfo * pi=IDPROC(currProc);
1255	// already loaded ?
1256	if( pi->data.s.body==NULL )
1257	{
1258	iiGetLibProcBuffer(pi);
1259	if (pi->data.s.body==NULL) return TRUE;
1260	}
1261	// set currPackHdl/currPack
1262	if ((pi->pack!=NULL)&&(currPack!=pi->pack))
1263	{
1264	currPack=pi->pack;
1265	iiCheckPack(currPack);
1266	currPackHdl=packFindHdl(currPack);
1267	//Print("set pack=%s\n",IDID(currPackHdl));
1268	}
1269	// see iiAllStart:
1270	BITSET save1=si_opt_1;
1271	BITSET save2=si_opt_2;
1272	newBuffer( omStrDup(pi->data.s.body), BT_proc,
1273	pi, pi->data.s.body_lineno-(iiCurrArgs==NULL) );
1274	BOOLEAN err=yyparse();
1275	iiCurrProc=NULL;
1276	si_opt_1=save1;
1277	si_opt_2=save2;
1278	// now save the return-expr.
1279	sLastPrinted.CleanUp(currRing);
1280	memcpy(&sLastPrinted,&iiRETURNEXPR,sizeof(sleftv));
1281	iiRETURNEXPR.Init();
1282	// warning about args.:
1283	if (iiCurrArgs!=NULL)
1284	{
1285	if (err==0) Warn("too many arguments for %s",IDID(currProc));
1286	iiCurrArgs->CleanUp();
1287	omFreeBin((ADDRESS)iiCurrArgs, sleftv_bin);
1288	iiCurrArgs=NULL;
1289	}
1290	// similate proc_end:
1291	// - leave input
1292	void myychangebuffer();
1293	myychangebuffer();
1294	// - set the current buffer to its end (this is a pointer in a buffer,
1295	// not a file ptr) "branchTo" is only valid in proc)
1296	currentVoice->fptr=strlen(currentVoice->buffer);
1297	// - kill local vars
1298	killlocals(myynest);
1299	// - return
1300	newBuffer(omStrDup("\n;return(_);\n"),BT_execute);
1301	return (err!=0);
1302	}
1303	return FALSE;
1304	}
1305	BOOLEAN iiParameter(leftv p)
1306	{
1307	if (iiCurrArgs==NULL)
1308	{
1309	if (strcmp(p->name,"#")==0)
1310	return iiDefaultParameter(p);
1311	Werror("not enough arguments for proc %s",VoiceName());
1312	p->CleanUp();
1313	return TRUE;
1314	}
1315	leftv h=iiCurrArgs;
1316	leftv rest=h->next; /iiCurrArgs is not NULL here/
1317	BOOLEAN is_default_list=FALSE;
1318	if (strcmp(p->name,"#")==0)
1319	{
1320	is_default_list=TRUE;
1321	rest=NULL;
1322	}
1323	else
1324	{
1325	h->next=NULL;
1326	}
1327	BOOLEAN res=iiAssign(p,h);
1328	if (is_default_list)
1329	{
1330	iiCurrArgs=NULL;
1331	}
1332	else
1333	{
1334	iiCurrArgs=rest;
1335	}
1336	h->CleanUp();
1337	omFreeBin((ADDRESS)h, sleftv_bin);
1338	return res;
1339	}
1340
1341	static BOOLEAN iiInternalExport (leftv v, int toLev)
1342	{
1343	idhdl h=(idhdl)v->data;
1344	//Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
1345	if (IDLEV(h)==0)
1346	{
1347	if ((myynest>0) && (BVERBOSE(V_REDEFINE))) Warn("`%s` is already global",IDID(h));
1348	}
1349	else
1350	{
1351	h=IDROOT->get(v->name,toLev);
1352	idhdl *root=&IDROOT;
1353	if ((h==NULL)&&(currRing!=NULL))
1354	{
1355	h=currRing->idroot->get(v->name,toLev);
1356	root=&currRing->idroot;
1357	}
1358	BOOLEAN keepring=FALSE;
1359	if ((h!=NULL)&&(IDLEV(h)==toLev))
1360	{
1361	if (IDTYP(h)==v->Typ())
1362	{
1363	if ((IDTYP(h)==RING_CMD)
1364	&& (v->Data()==IDDATA(h)))
1365	{
1366	rIncRefCnt(IDRING(h));
1367	keepring=TRUE;
1368	IDLEV(h)=toLev;
1369	//WarnS("keepring");
1370	return FALSE;
1371	}
1372	if (BVERBOSE(V_REDEFINE))
1373	{
1374	Warn("redefining %s (%s)",IDID(h),my_yylinebuf);
1375	}
1376	if (iiLocalRing[0]==IDRING(h) && (!keepring)) iiLocalRing[0]=NULL;
1377	killhdl2(h,root,currRing);
1378	}
1379	else
1380	{
1381	return TRUE;
1382	}
1383	}
1384	h=(idhdl)v->data;
1385	IDLEV(h)=toLev;
1386	if (keepring) rDecRefCnt(IDRING(h));
1387	iiNoKeepRing=FALSE;
1388	//Print("export %s\n",IDID(h));
1389	}
1390	return FALSE;
1391	}
1392
1393	BOOLEAN iiInternalExport (leftv v, int toLev, package rootpack)
1394	{
1395	idhdl h=(idhdl)v->data;
1396	if(h==NULL)
1397	{
1398	Warn("'%s': no such identifier\n", v->name);
1399	return FALSE;
1400	}
1401	package frompack=v->req_packhdl;
1402	if (frompack==NULL) frompack=currPack;
1403	if ((RingDependend(IDTYP(h)))
1404	\|\| ((IDTYP(h)==LIST_CMD)
1405	&& (lRingDependend(IDLIST(h)))
1406	)
1407	)
1408	{
1409	//Print("// ==> Ringdependent set nesting to 0\n");
1410	return (iiInternalExport(v, toLev));
1411	}
1412	else
1413	{
1414	IDLEV(h)=toLev;
1415	v->req_packhdl=rootpack;
1416	if (h==frompack->idroot)
1417	{
1418	frompack->idroot=h->next;
1419	}
1420	else
1421	{
1422	idhdl hh=frompack->idroot;
1423	while ((hh!=NULL) && (hh->next!=h))
1424	hh=hh->next;
1425	if ((hh!=NULL) && (hh->next==h))
1426	hh->next=h->next;
1427	else
1428	{
1429	Werror("`%s` not found",v->Name());
1430	return TRUE;
1431	}
1432	}
1433	h->next=rootpack->idroot;
1434	rootpack->idroot=h;
1435	}
1436	return FALSE;
1437	}
1438
1439	BOOLEAN iiExport (leftv v, int toLev)
1440	{
1441	BOOLEAN nok=FALSE;
1442	leftv r=v;
1443	while (v!=NULL)
1444	{
1445	if ((v->name==NULL)\|\|(v->rtyp==0)\|\|(v->e!=NULL))
1446	{
1447	Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1448	nok=TRUE;
1449	}
1450	else
1451	{
1452	if(iiInternalExport(v, toLev))
1453	{
1454	r->CleanUp();
1455	return TRUE;
1456	}
1457	}
1458	v=v->next;
1459	}
1460	r->CleanUp();
1461	return nok;
1462	}
1463
1464	/assume root!=idroot/
1465	BOOLEAN iiExport (leftv v, int toLev, package pack)
1466	{
1467	// if ((pack==basePack)&&(pack!=currPack))
1468	// { Warn("'exportto' to Top is depreciated in >>%s<<",my_yylinebuf);}
1469	BOOLEAN nok=FALSE;
1470	leftv rv=v;
1471	while (v!=NULL)
1472	{
1473	if ((v->name==NULL)\|\|(v->rtyp==0)\|\|(v->e!=NULL)
1474	)
1475	{
1476	Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1477	nok=TRUE;
1478	}
1479	else
1480	{
1481	idhdl old=pack->idroot->get( v->name,toLev);
1482	if (old!=NULL)
1483	{
1484	if ((pack==currPack) && (old==(idhdl)v->data))
1485	{
1486	if (BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(old));
1487	break;
1488	}
1489	else if (IDTYP(old)==v->Typ())
1490	{
1491	if (BVERBOSE(V_REDEFINE))
1492	{
1493	Warn("redefining %s (%s)",IDID(old),my_yylinebuf);
1494	}
1495	v->name=omStrDup(v->name);
1496	killhdl2(old,&(pack->idroot),currRing);
1497	}
1498	else
1499	{
1500	rv->CleanUp();
1501	return TRUE;
1502	}
1503	}
1504	//Print("iiExport: pack=%s\n",IDID(root));
1505	if(iiInternalExport(v, toLev, pack))
1506	{
1507	rv->CleanUp();
1508	return TRUE;
1509	}
1510	}
1511	v=v->next;
1512	}
1513	rv->CleanUp();
1514	return nok;
1515	}
1516
1517	BOOLEAN iiCheckRing(int i)
1518	{
1519	if (currRing==NULL)
1520	{
1521	#ifdef SIQ
1522	if (siq<=0)
1523	{
1524	#endif
1525	if (RingDependend(i))
1526	{
1527	WerrorS("no ring active (9)");
1528	return TRUE;
1529	}
1530	#ifdef SIQ
1531	}
1532	#endif
1533	}
1534	return FALSE;
1535	}
1536
1537	poly iiHighCorner(ideal I, int ak)
1538	{
1539	int i;
1540	if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1541	poly po=NULL;
1542	if (rHasLocalOrMixedOrdering(currRing))
1543	{
1544	scComputeHC(I,currRing->qideal,ak,po);
1545	if (po!=NULL)
1546	{
1547	pGetCoeff(po)=nInit(1);
1548	for (i=rVar(currRing); i>0; i--)
1549	{
1550	if (pGetExp(po, i) > 0) pDecrExp(po,i);
1551	}
1552	pSetComp(po,ak);
1553	pSetm(po);
1554	}
1555	}
1556	else
1557	po=pOne();
1558	return po;
1559	}
1560
1561	void iiCheckPack(package &p)
1562	{
1563	if (p!=basePack)
1564	{
1565	idhdl t=basePack->idroot;
1566	while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
1567	if (t==NULL)
1568	{
1569	WarnS("package not found\n");
1570	p=basePack;
1571	}
1572	}
1573	}
1574
1575	idhdl rDefault(const char *s)
1576	{
1577	idhdl tmp=NULL;
1578
1579	if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
1580	if (tmp==NULL) return NULL;
1581
1582	// if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
1583	if (sLastPrinted.RingDependend())
1584	{
1585	sLastPrinted.CleanUp();
1586	}
1587
1588	ring r = IDRING(tmp) = (ring) omAlloc0Bin(sip_sring_bin);
1589
1590	#ifndef TEST_ZN_AS_ZP
1591	r->cf = nInitChar(n_Zp, (void*)32003); // r->cf->ch = 32003;
1592	#else
1593	mpz_t modBase;
1594	mpz_init_set_ui(modBase, (long)32003);
1595	ZnmInfo info;
1596	info.base= modBase;
1597	info.exp= 1;
1598	r->cf=nInitChar(n_Zn,(void*) &info);
1599	r->cf->is_field=1;
1600	r->cf->is_domain=1;
1601	r->cf->has_simple_Inverse=1;
1602	#endif
1603	r->N = 3;
1604	/r->P = 0; Alloc0 in idhdl::set, ipid.cc/
1605	/names/
1606	r->names = (char *) omAlloc0(3 sizeof(char_ptr));
1607	r->names[0] = omStrDup("x");
1608	r->names[1] = omStrDup("y");
1609	r->names[2] = omStrDup("z");
1610	/weights: entries for 3 blocks: NULL/
1611	r->wvhdl = (int *)omAlloc0(3 sizeof(int_ptr));
1612	/order: dp,C,0/
1613	r->order = (rRingOrder_t ) omAlloc(3 sizeof(rRingOrder_t *));
1614	r->block0 = (int )omAlloc0(3 sizeof(int *));
1615	r->block1 = (int )omAlloc0(3 sizeof(int *));
1616	/* ringorder dp for the first block: var 1..3 */
1617	r->order[0] = ringorder_dp;
1618	r->block0[0] = 1;
1619	r->block1[0] = 3;
1620	/* ringorder C for the second block: no vars */
1621	r->order[1] = ringorder_C;
1622	/* the last block: everything is 0 */
1623	r->order[2] = (rRingOrder_t)0;
1624
1625	/* complete ring intializations */
1626	rComplete(r);
1627	rSetHdl(tmp);
1628	return currRingHdl;
1629	}
1630
1631	static idhdl rSimpleFindHdl(const ring r, const idhdl root, const idhdl n);
1632	idhdl rFindHdl(ring r, idhdl n)
1633	{
1634	if ((r==NULL)\|\|(r->VarOffset==NULL))
1635	return NULL;
1636	idhdl h=rSimpleFindHdl(r,IDROOT,n);
1637	if (h!=NULL) return h;
1638	if (IDROOT!=basePack->idroot) h=rSimpleFindHdl(r,basePack->idroot,n);
1639	if (h!=NULL) return h;
1640	proclevel *p=procstack;
1641	while(p!=NULL)
1642	{
1643	if ((p->cPack!=basePack)
1644	&& (p->cPack!=currPack))
1645	h=rSimpleFindHdl(r,p->cPack->idroot,n);
1646	if (h!=NULL) return h;
1647	p=p->next;
1648	}
1649	idhdl tmp=basePack->idroot;
1650	while (tmp!=NULL)
1651	{
1652	if (IDTYP(tmp)==PACKAGE_CMD)
1653	h=rSimpleFindHdl(r,IDPACKAGE(tmp)->idroot,n);
1654	if (h!=NULL) return h;
1655	tmp=IDNEXT(tmp);
1656	}
1657	return NULL;
1658	}
1659
1660	void rDecomposeCF(leftv h,const ring r,const ring R)
1661	{
1662	lists L=(lists)omAlloc0Bin(slists_bin);
1663	L->Init(4);
1664	h->rtyp=LIST_CMD;
1665	h->data=(void *)L;
1666	// 0: char/ cf - ring
1667	// 1: list (var)
1668	// 2: list (ord)
1669	// 3: qideal
1670	// ----------------------------------------
1671	// 0: char/ cf - ring
1672	L->m[0].rtyp=INT_CMD;
1673	L->m[0].data=(void *)(long)r->cf->ch;
1674	// ----------------------------------------
1675	// 1: list (var)
1676	lists LL=(lists)omAlloc0Bin(slists_bin);
1677	LL->Init(r->N);
1678	int i;
1679	for(i=0; i<r->N; i++)
1680	{
1681	LL->m[i].rtyp=STRING_CMD;
1682	LL->m[i].data=(void *)omStrDup(r->names[i]);
1683	}
1684	L->m[1].rtyp=LIST_CMD;
1685	L->m[1].data=(void *)LL;
1686	// ----------------------------------------
1687	// 2: list (ord)
1688	LL=(lists)omAlloc0Bin(slists_bin);
1689	i=rBlocks(r)-1;
1690	LL->Init(i);
1691	i--;
1692	lists LLL;
1693	for(; i>=0; i--)
1694	{
1695	intvec *iv;
1696	int j;
1697	LL->m[i].rtyp=LIST_CMD;
1698	LLL=(lists)omAlloc0Bin(slists_bin);
1699	LLL->Init(2);
1700	LLL->m[0].rtyp=STRING_CMD;
1701	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1702	if (r->block1[i]-r->block0[i] >=0 )
1703	{
1704	j=r->block1[i]-r->block0[i];
1705	if(r->order[i]==ringorder_M) j=(j+1)*(j+1)-1;
1706	iv=new intvec(j+1);
1707	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1708	{
1709	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1710	}
1711	else switch (r->order[i])
1712	{
1713	case ringorder_dp:
1714	case ringorder_Dp:
1715	case ringorder_ds:
1716	case ringorder_Ds:
1717	case ringorder_lp:
1718	case ringorder_rp:
1719	case ringorder_ls:
1720	for(;j>=0; j--) (*iv)[j]=1;
1721	break;
1722	default: /* do nothing */;
1723	}
1724	}
1725	else
1726	{
1727	iv=new intvec(1);
1728	}
1729	LLL->m[1].rtyp=INTVEC_CMD;
1730	LLL->m[1].data=(void *)iv;
1731	LL->m[i].data=(void *)LLL;
1732	}
1733	L->m[2].rtyp=LIST_CMD;
1734	L->m[2].data=(void *)LL;
1735	// ----------------------------------------
1736	// 3: qideal
1737	L->m[3].rtyp=IDEAL_CMD;
1738	if (nCoeff_is_transExt(R->cf))
1739	L->m[3].data=(void *)idInit(1,1);
1740	else
1741	{
1742	ideal q=idInit(IDELEMS(r->qideal));
1743	q->m[0]=p_Init(R);
1744	pSetCoeff0(q->m[0],(number)(r->qideal->m[0]));
1745	L->m[3].data=(void *)q;
1746	// I->m[0] = pNSet(R->minpoly);
1747	}
1748	// ----------------------------------------
1749	}
1750	static void rDecomposeC_41(leftv h,const coeffs C)
1751	/* field is R or C */
1752	{
1753	lists L=(lists)omAlloc0Bin(slists_bin);
1754	if (nCoeff_is_long_C(C)) L->Init(3);
1755	else L->Init(2);
1756	h->rtyp=LIST_CMD;
1757	h->data=(void *)L;
1758	// 0: char/ cf - ring
1759	// 1: list (var)
1760	// 2: list (ord)
1761	// ----------------------------------------
1762	// 0: char/ cf - ring
1763	L->m[0].rtyp=INT_CMD;
1764	L->m[0].data=(void *)0;
1765	// ----------------------------------------
1766	// 1:
1767	lists LL=(lists)omAlloc0Bin(slists_bin);
1768	LL->Init(2);
1769	LL->m[0].rtyp=INT_CMD;
1770	LL->m[0].data=(void *)(long)si_max(C->float_len,SHORT_REAL_LENGTH/2);
1771	LL->m[1].rtyp=INT_CMD;
1772	LL->m[1].data=(void *)(long)si_max(C->float_len2,SHORT_REAL_LENGTH);
1773	L->m[1].rtyp=LIST_CMD;
1774	L->m[1].data=(void *)LL;
1775	// ----------------------------------------
1776	// 2: list (par)
1777	if (nCoeff_is_long_C(C))
1778	{
1779	L->m[2].rtyp=STRING_CMD;
1780	L->m[2].data=(void )omStrDup(n_ParameterNames(C));
1781	}
1782	// ----------------------------------------
1783	}
1784	static void rDecomposeC(leftv h,const ring R)
1785	/* field is R or C */
1786	{
1787	lists L=(lists)omAlloc0Bin(slists_bin);
1788	if (rField_is_long_C(R)) L->Init(3);
1789	else L->Init(2);
1790	h->rtyp=LIST_CMD;
1791	h->data=(void *)L;
1792	// 0: char/ cf - ring
1793	// 1: list (var)
1794	// 2: list (ord)
1795	// ----------------------------------------
1796	// 0: char/ cf - ring
1797	L->m[0].rtyp=INT_CMD;
1798	L->m[0].data=(void *)0;
1799	// ----------------------------------------
1800	// 1:
1801	lists LL=(lists)omAlloc0Bin(slists_bin);
1802	LL->Init(2);
1803	LL->m[0].rtyp=INT_CMD;
1804	LL->m[0].data=(void *)(long)si_max(R->cf->float_len,SHORT_REAL_LENGTH/2);
1805	LL->m[1].rtyp=INT_CMD;
1806	LL->m[1].data=(void *)(long)si_max(R->cf->float_len2,SHORT_REAL_LENGTH);
1807	L->m[1].rtyp=LIST_CMD;
1808	L->m[1].data=(void *)LL;
1809	// ----------------------------------------
1810	// 2: list (par)
1811	if (rField_is_long_C(R))
1812	{
1813	L->m[2].rtyp=STRING_CMD;
1814	L->m[2].data=(void )omStrDup(rParameter(R));
1815	}
1816	// ----------------------------------------
1817	}
1818
1819	#ifdef HAVE_RINGS
1820	void rDecomposeRing_41(leftv h,const coeffs C)
1821	/* field is R or C */
1822	{
1823	lists L=(lists)omAlloc0Bin(slists_bin);
1824	if (nCoeff_is_Ring(C)) L->Init(1);
1825	else L->Init(2);
1826	h->rtyp=LIST_CMD;
1827	h->data=(void *)L;
1828	// 0: char/ cf - ring
1829	// 1: list (module)
1830	// ----------------------------------------
1831	// 0: char/ cf - ring
1832	L->m[0].rtyp=STRING_CMD;
1833	L->m[0].data=(void *)omStrDup("integer");
1834	// ----------------------------------------
1835	// 1: modulo
1836	if (nCoeff_is_Z(C)) return;
1837	lists LL=(lists)omAlloc0Bin(slists_bin);
1838	LL->Init(2);
1839	LL->m[0].rtyp=BIGINT_CMD;
1840	LL->m[0].data=n_InitMPZ( C->modBase, coeffs_BIGINT);
1841	LL->m[1].rtyp=INT_CMD;
1842	LL->m[1].data=(void *) C->modExponent;
1843	L->m[1].rtyp=LIST_CMD;
1844	L->m[1].data=(void *)LL;
1845	}
1846	#endif
1847
1848	void rDecomposeRing(leftv h,const ring R)
1849	/* field is R or C */
1850	{
1851	#ifdef HAVE_RINGS
1852	lists L=(lists)omAlloc0Bin(slists_bin);
1853	if (rField_is_Z(R)) L->Init(1);
1854	else L->Init(2);
1855	h->rtyp=LIST_CMD;
1856	h->data=(void *)L;
1857	// 0: char/ cf - ring
1858	// 1: list (module)
1859	// ----------------------------------------
1860	// 0: char/ cf - ring
1861	L->m[0].rtyp=STRING_CMD;
1862	L->m[0].data=(void *)omStrDup("integer");
1863	// ----------------------------------------
1864	// 1: module
1865	if (rField_is_Z(R)) return;
1866	lists LL=(lists)omAlloc0Bin(slists_bin);
1867	LL->Init(2);
1868	LL->m[0].rtyp=BIGINT_CMD;
1869	LL->m[0].data=n_InitMPZ( R->cf->modBase, coeffs_BIGINT);
1870	LL->m[1].rtyp=INT_CMD;
1871	LL->m[1].data=(void *) R->cf->modExponent;
1872	L->m[1].rtyp=LIST_CMD;
1873	L->m[1].data=(void *)LL;
1874	#else
1875	WerrorS("rDecomposeRing");
1876	#endif
1877	}
1878
1879
1880	BOOLEAN rDecompose_CF(leftv res,const coeffs C)
1881	{
1882	assume( C != NULL );
1883
1884	// sanity check: require currRing==r for rings with polynomial data
1885	if ( nCoeff_is_algExt(C) && (C != currRing->cf))
1886	{
1887	WerrorS("ring with polynomial data must be the base ring or compatible");
1888	return TRUE;
1889	}
1890	if (nCoeff_is_numeric(C))
1891	{
1892	rDecomposeC_41(res,C);
1893	}
1894	#ifdef HAVE_RINGS
1895	else if (nCoeff_is_Ring(C))
1896	{
1897	rDecomposeRing_41(res,C);
1898	}
1899	#endif
1900	else if ( C->extRing!=NULL )// nCoeff_is_algExt(r->cf))
1901	{
1902	rDecomposeCF(res, C->extRing, currRing);
1903	}
1904	else if(nCoeff_is_GF(C))
1905	{
1906	lists Lc=(lists)omAlloc0Bin(slists_bin);
1907	Lc->Init(4);
1908	// char:
1909	Lc->m[0].rtyp=INT_CMD;
1910	Lc->m[0].data=(void*)(long)C->m_nfCharQ;
1911	// var:
1912	lists Lv=(lists)omAlloc0Bin(slists_bin);
1913	Lv->Init(1);
1914	Lv->m[0].rtyp=STRING_CMD;
1915	Lv->m[0].data=(void )omStrDup(n_ParameterNames(C));
1916	Lc->m[1].rtyp=LIST_CMD;
1917	Lc->m[1].data=(void*)Lv;
1918	// ord:
1919	lists Lo=(lists)omAlloc0Bin(slists_bin);
1920	Lo->Init(1);
1921	lists Loo=(lists)omAlloc0Bin(slists_bin);
1922	Loo->Init(2);
1923	Loo->m[0].rtyp=STRING_CMD;
1924	Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
1925
1926	intvec iv=new intvec(1); (iv)[0]=1;
1927	Loo->m[1].rtyp=INTVEC_CMD;
1928	Loo->m[1].data=(void *)iv;
1929
1930	Lo->m[0].rtyp=LIST_CMD;
1931	Lo->m[0].data=(void*)Loo;
1932
1933	Lc->m[2].rtyp=LIST_CMD;
1934	Lc->m[2].data=(void*)Lo;
1935	// q-ideal:
1936	Lc->m[3].rtyp=IDEAL_CMD;
1937	Lc->m[3].data=(void *)idInit(1,1);
1938	// ----------------------
1939	res->rtyp=LIST_CMD;
1940	res->data=(void*)Lc;
1941	}
1942	else
1943	{
1944	res->rtyp=INT_CMD;
1945	res->data=(void *)(long)C->ch;
1946	}
1947	// ----------------------------------------
1948	return FALSE;
1949	}
1950
1951	lists rDecompose_list_cf(const ring r)
1952	{
1953	assume( r != NULL );
1954	const coeffs C = r->cf;
1955	assume( C != NULL );
1956
1957	// sanity check: require currRing==r for rings with polynomial data
1958	if ( (r!=currRing) && (
1959	(r->qideal != NULL)
1960	#ifdef HAVE_PLURAL
1961	\|\| (rIsPluralRing(r))
1962	#endif
1963	)
1964	)
1965	{
1966	WerrorS("ring with polynomial data must be the base ring or compatible");
1967	return NULL;
1968	}
1969	// 0: char/ cf - ring
1970	// 1: list (var)
1971	// 2: list (ord)
1972	// 3: qideal
1973	// possibly:
1974	// 4: C
1975	// 5: D
1976	lists L=(lists)omAlloc0Bin(slists_bin);
1977	if (rIsPluralRing(r))
1978	L->Init(6);
1979	else
1980	L->Init(4);
1981	// ----------------------------------------
1982	// 0: char/ cf - ring
1983	L->m[0].rtyp=CRING_CMD;
1984	L->m[0].data=(char*)r->cf; r->cf->ref++;
1985	// ----------------------------------------
1986	// 1: list (var)
1987	lists LL=(lists)omAlloc0Bin(slists_bin);
1988	LL->Init(r->N);
1989	int i;
1990	for(i=0; i<r->N; i++)
1991	{
1992	LL->m[i].rtyp=STRING_CMD;
1993	LL->m[i].data=(void *)omStrDup(r->names[i]);
1994	}
1995	L->m[1].rtyp=LIST_CMD;
1996	L->m[1].data=(void *)LL;
1997	// ----------------------------------------
1998	// 2: list (ord)
1999	LL=(lists)omAlloc0Bin(slists_bin);
2000	i=rBlocks(r)-1;
2001	LL->Init(i);
2002	i--;
2003	lists LLL;
2004	for(; i>=0; i--)
2005	{
2006	intvec *iv;
2007	int j;
2008	LL->m[i].rtyp=LIST_CMD;
2009	LLL=(lists)omAlloc0Bin(slists_bin);
2010	LLL->Init(2);
2011	LLL->m[0].rtyp=STRING_CMD;
2012	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
2013
2014	if(r->order[i] == ringorder_IS) // \|\| r->order[i] == ringorder_s \|\| r->order[i] == ringorder_S)
2015	{
2016	assume( r->block0[i] == r->block1[i] );
2017	const int s = r->block0[i];
2018	assume( -2 < s && s < 2);
2019
2020	iv=new intvec(1);
2021	(*iv)[0] = s;
2022	}
2023	else if (r->block1[i]-r->block0[i] >=0 )
2024	{
2025	int bl=j=r->block1[i]-r->block0[i];
2026	if (r->order[i]==ringorder_M)
2027	{
2028	j=(j+1)*(j+1)-1;
2029	bl=j+1;
2030	}
2031	else if (r->order[i]==ringorder_am)
2032	{
2033	j+=r->wvhdl[i][bl+1];
2034	}
2035	iv=new intvec(j+1);
2036	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
2037	{
2038	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
2039	}
2040	else switch (r->order[i])
2041	{
2042	case ringorder_dp:
2043	case ringorder_Dp:
2044	case ringorder_ds:
2045	case ringorder_Ds:
2046	case ringorder_lp:
2047	for(;j>=0; j--) (*iv)[j]=1;
2048	break;
2049	default: /* do nothing */;
2050	}
2051	}
2052	else
2053	{
2054	iv=new intvec(1);
2055	}
2056	LLL->m[1].rtyp=INTVEC_CMD;
2057	LLL->m[1].data=(void *)iv;
2058	LL->m[i].data=(void *)LLL;
2059	}
2060	L->m[2].rtyp=LIST_CMD;
2061	L->m[2].data=(void *)LL;
2062	// ----------------------------------------
2063	// 3: qideal
2064	L->m[3].rtyp=IDEAL_CMD;
2065	if (r->qideal==NULL)
2066	L->m[3].data=(void *)idInit(1,1);
2067	else
2068	L->m[3].data=(void *)idCopy(r->qideal);
2069	// ----------------------------------------
2070	#ifdef HAVE_PLURAL // NC! in rDecompose
2071	if (rIsPluralRing(r))
2072	{
2073	L->m[4].rtyp=MATRIX_CMD;
2074	L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2075	L->m[5].rtyp=MATRIX_CMD;
2076	L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2077	}
2078	#endif
2079	return L;
2080	}
2081
2082	lists rDecompose(const ring r)
2083	{
2084	assume( r != NULL );
2085	const coeffs C = r->cf;
2086	assume( C != NULL );
2087
2088	// sanity check: require currRing==r for rings with polynomial data
2089	if ( (r!=currRing) && (
2090	(nCoeff_is_algExt(C) && (C != currRing->cf))
2091	\|\| (r->qideal != NULL)
2092	#ifdef HAVE_PLURAL
2093	\|\| (rIsPluralRing(r))
2094	#endif
2095	)
2096	)
2097	{
2098	WerrorS("ring with polynomial data must be the base ring or compatible");
2099	return NULL;
2100	}
2101	// 0: char/ cf - ring
2102	// 1: list (var)
2103	// 2: list (ord)
2104	// 3: qideal
2105	// possibly:
2106	// 4: C
2107	// 5: D
2108	lists L=(lists)omAlloc0Bin(slists_bin);
2109	if (rIsPluralRing(r))
2110	L->Init(6);
2111	else
2112	L->Init(4);
2113	// ----------------------------------------
2114	// 0: char/ cf - ring
2115	if (rField_is_numeric(r))
2116	{
2117	rDecomposeC(&(L->m[0]),r);
2118	}
2119	else if (rField_is_Ring(r))
2120	{
2121	rDecomposeRing(&(L->m[0]),r);
2122	}
2123	else if ( r->cf->extRing!=NULL )// nCoeff_is_algExt(r->cf))
2124	{
2125	rDecomposeCF(&(L->m[0]), r->cf->extRing, r);
2126	}
2127	else if(rField_is_GF(r))
2128	{
2129	lists Lc=(lists)omAlloc0Bin(slists_bin);
2130	Lc->Init(4);
2131	// char:
2132	Lc->m[0].rtyp=INT_CMD;
2133	Lc->m[0].data=(void*)(long)r->cf->m_nfCharQ;
2134	// var:
2135	lists Lv=(lists)omAlloc0Bin(slists_bin);
2136	Lv->Init(1);
2137	Lv->m[0].rtyp=STRING_CMD;
2138	Lv->m[0].data=(void )omStrDup(rParameter(r));
2139	Lc->m[1].rtyp=LIST_CMD;
2140	Lc->m[1].data=(void*)Lv;
2141	// ord:
2142	lists Lo=(lists)omAlloc0Bin(slists_bin);
2143	Lo->Init(1);
2144	lists Loo=(lists)omAlloc0Bin(slists_bin);
2145	Loo->Init(2);
2146	Loo->m[0].rtyp=STRING_CMD;
2147	Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
2148
2149	intvec iv=new intvec(1); (iv)[0]=1;
2150	Loo->m[1].rtyp=INTVEC_CMD;
2151	Loo->m[1].data=(void *)iv;
2152
2153	Lo->m[0].rtyp=LIST_CMD;
2154	Lo->m[0].data=(void*)Loo;
2155
2156	Lc->m[2].rtyp=LIST_CMD;
2157	Lc->m[2].data=(void*)Lo;
2158	// q-ideal:
2159	Lc->m[3].rtyp=IDEAL_CMD;
2160	Lc->m[3].data=(void *)idInit(1,1);
2161	// ----------------------
2162	L->m[0].rtyp=LIST_CMD;
2163	L->m[0].data=(void*)Lc;
2164	}
2165	else
2166	{
2167	L->m[0].rtyp=INT_CMD;
2168	L->m[0].data=(void *)(long)r->cf->ch;
2169	}
2170	// ----------------------------------------
2171	// 1: list (var)
2172	lists LL=(lists)omAlloc0Bin(slists_bin);
2173	LL->Init(r->N);
2174	int i;
2175	for(i=0; i<r->N; i++)
2176	{
2177	LL->m[i].rtyp=STRING_CMD;
2178	LL->m[i].data=(void *)omStrDup(r->names[i]);
2179	}
2180	L->m[1].rtyp=LIST_CMD;
2181	L->m[1].data=(void *)LL;
2182	// ----------------------------------------
2183	// 2: list (ord)
2184	LL=(lists)omAlloc0Bin(slists_bin);
2185	i=rBlocks(r)-1;
2186	LL->Init(i);
2187	i--;
2188	lists LLL;
2189	for(; i>=0; i--)
2190	{
2191	intvec *iv;
2192	int j;
2193	LL->m[i].rtyp=LIST_CMD;
2194	LLL=(lists)omAlloc0Bin(slists_bin);
2195	LLL->Init(2);
2196	LLL->m[0].rtyp=STRING_CMD;
2197	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
2198
2199	if((r->order[i] == ringorder_IS)
2200	\|\| (r->order[i] == ringorder_s)) //\|\| r->order[i] == ringorder_S)
2201	{
2202	assume( r->block0[i] == r->block1[i] );
2203	const int s = r->block0[i];
2204	assume( (-2 < s && s < 2)\|\|(r->order[i] != ringorder_IS));
2205
2206	iv=new intvec(1);
2207	(*iv)[0] = s;
2208	}
2209	else if (r->block1[i]-r->block0[i] >=0 )
2210	{
2211	int bl=j=r->block1[i]-r->block0[i];
2212	if (r->order[i]==ringorder_M)
2213	{
2214	j=(j+1)*(j+1)-1;
2215	bl=j+1;
2216	}
2217	else if (r->order[i]==ringorder_am)
2218	{
2219	j+=r->wvhdl[i][bl+1];
2220	}
2221	iv=new intvec(j+1);
2222	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
2223	{
2224	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
2225	}
2226	else switch (r->order[i])
2227	{
2228	case ringorder_dp:
2229	case ringorder_Dp:
2230	case ringorder_ds:
2231	case ringorder_Ds:
2232	case ringorder_lp:
2233	case ringorder_ls:
2234	case ringorder_rp:
2235	for(;j>=0; j--) (*iv)[j]=1;
2236	break;
2237	default: /* do nothing */;
2238	}
2239	}
2240	else
2241	{
2242	iv=new intvec(1);
2243	}
2244	LLL->m[1].rtyp=INTVEC_CMD;
2245	LLL->m[1].data=(void *)iv;
2246	LL->m[i].data=(void *)LLL;
2247	}
2248	L->m[2].rtyp=LIST_CMD;
2249	L->m[2].data=(void *)LL;
2250	// ----------------------------------------
2251	// 3: qideal
2252	L->m[3].rtyp=IDEAL_CMD;
2253	if (r->qideal==NULL)
2254	L->m[3].data=(void *)idInit(1,1);
2255	else
2256	L->m[3].data=(void *)idCopy(r->qideal);
2257	// ----------------------------------------
2258	#ifdef HAVE_PLURAL // NC! in rDecompose
2259	if (rIsPluralRing(r))
2260	{
2261	L->m[4].rtyp=MATRIX_CMD;
2262	L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2263	L->m[5].rtyp=MATRIX_CMD;
2264	L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2265	}
2266	#endif
2267	return L;
2268	}
2269
2270	void rComposeC(lists L, ring R)
2271	/* field is R or C */
2272	{
2273	// ----------------------------------------
2274	// 0: char/ cf - ring
2275	if ((L->m[0].rtyp!=INT_CMD) \|\| (L->m[0].data!=(char *)0))
2276	{
2277	WerrorS("invalid coeff. field description, expecting 0");
2278	return;
2279	}
2280	// R->cf->ch=0;
2281	// ----------------------------------------
2282	// 0, (r1,r2) [, "i" ]
2283	if (L->m[1].rtyp!=LIST_CMD)
2284	{
2285	WerrorS("invalid coeff. field description, expecting precision list");
2286	return;
2287	}
2288	lists LL=(lists)L->m[1].data;
2289	if ((LL->nr!=1)
2290	\|\| (LL->m[0].rtyp!=INT_CMD)
2291	\|\| (LL->m[1].rtyp!=INT_CMD))
2292	{
2293	WerrorS("invalid coeff. field description list, expected list(`int`,`int`)");
2294	return;
2295	}
2296	int r1=(int)(long)LL->m[0].data;
2297	int r2=(int)(long)LL->m[1].data;
2298	r1=si_min(r1,32767);
2299	r2=si_min(r2,32767);
2300	LongComplexInfo par; memset(&par, 0, sizeof(par));
2301	par.float_len=r1;
2302	par.float_len2=r2;
2303	if (L->nr==2) // complex
2304	{
2305	if (L->m[2].rtyp!=STRING_CMD)
2306	{
2307	WerrorS("invalid coeff. field description, expecting parameter name");
2308	return;
2309	}
2310	par.par_name=(char*)L->m[2].data;
2311	R->cf = nInitChar(n_long_C, &par);
2312	}
2313	else if ((r1<=SHORT_REAL_LENGTH) && (r2<=SHORT_REAL_LENGTH)) /* && L->nr==1*/
2314	R->cf = nInitChar(n_R, NULL);
2315	else /* && L->nr==1*/
2316	{
2317	R->cf = nInitChar(n_long_R, &par);
2318	}
2319	}
2320
2321	#ifdef HAVE_RINGS
2322	void rComposeRing(lists L, ring R)
2323	/* field is R or C */
2324	{
2325	// ----------------------------------------
2326	// 0: string: integer
2327	// no further entries --> Z
2328	mpz_t modBase;
2329	unsigned int modExponent = 1;
2330
2331	if (L->nr == 0)
2332	{
2333	mpz_init_set_ui(modBase,0);
2334	modExponent = 1;
2335	}
2336	// ----------------------------------------
2337	// 1:
2338	else
2339	{
2340	if (L->m[1].rtyp!=LIST_CMD) WerrorS("invalid data, expecting list of numbers");
2341	lists LL=(lists)L->m[1].data;
2342	if ((LL->nr >= 0) && LL->m[0].rtyp == BIGINT_CMD)
2343	{
2344	number tmp= (number) LL->m[0].data; // never use CopyD() on list elements
2345	// assume that tmp is integer, not rational
2346	mpz_init(modBase);
2347	n_MPZ (modBase, tmp, coeffs_BIGINT);
2348	}
2349	else if (LL->nr >= 0 && LL->m[0].rtyp == INT_CMD)
2350	{
2351	mpz_init_set_ui(modBase,(unsigned long) LL->m[0].data);
2352	}
2353	else
2354	{
2355	mpz_init_set_ui(modBase,0);
2356	}
2357	if (LL->nr >= 1)
2358	{
2359	modExponent = (unsigned long) LL->m[1].data;
2360	}
2361	else
2362	{
2363	modExponent = 1;
2364	}
2365	}
2366	// ----------------------------------------
2367	if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_sgn1(modBase) < 0))
2368	{
2369	WerrorS("Wrong ground ring specification (module is 1)");
2370	return;
2371	}
2372	if (modExponent < 1)
2373	{
2374	WerrorS("Wrong ground ring specification (exponent smaller than 1)");
2375	return;
2376	}
2377	// module is 0 ---> integers
2378	if (mpz_sgn1(modBase) == 0)
2379	{
2380	R->cf=nInitChar(n_Z,NULL);
2381	}
2382	// we have an exponent
2383	else if (modExponent > 1)
2384	{
2385	//R->cf->ch = R->cf->modExponent;
2386	if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(unsigned long)))
2387	{
2388	/* this branch should be active for modExponent = 2..32 resp. 2..64,
2389	depending on the size of a long on the respective platform */
2390	R->cf=nInitChar(n_Z2m,(void*)(long)modExponent); // Use Z/2^ch
2391	}
2392	else
2393	{
2394	//ringtype 3
2395	ZnmInfo info;
2396	info.base= modBase;
2397	info.exp= modExponent;
2398	R->cf=nInitChar(n_Znm,(void*) &info);
2399	}
2400	}
2401	// just a module m > 1
2402	else
2403	{
2404	//ringtype = 2;
2405	//const int ch = mpz_get_ui(modBase);
2406	ZnmInfo info;
2407	info.base= modBase;
2408	info.exp= modExponent;
2409	R->cf=nInitChar(n_Zn,(void*) &info);
2410	}
2411	mpz_clear(modBase);
2412	}
2413	#endif
2414
2415	static void rRenameVars(ring R)
2416	{
2417	int i,j;
2418	BOOLEAN ch;
2419	do
2420	{
2421	ch=0;
2422	for(i=0;i<R->N-1;i++)
2423	{
2424	for(j=i+1;j<R->N;j++)
2425	{
2426	if (strcmp(R->names[i],R->names[j])==0)
2427	{
2428	ch=TRUE;
2429	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);
2430	omFree(R->names[j]);
2431	R->names[j]=(char *)omAlloc(2+strlen(R->names[i]));
2432	sprintf(R->names[j],"@%s",R->names[i]);
2433	}
2434	}
2435	}
2436	}
2437	while (ch);
2438	for(i=0;i<rPar(R); i++)
2439	{
2440	for(j=0;j<R->N;j++)
2441	{
2442	if (strcmp(rParameter(R)[i],R->names[j])==0)
2443	{
2444	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);
2445	// omFree(rParameter(R)[i]);
2446	// rParameter(R)[i]=(char *)omAlloc(10);
2447	// sprintf(rParameter(R)[i],"@@(%d)",i+1);
2448	omFree(R->names[j]);
2449	R->names[j]=(char *)omAlloc(10);
2450	sprintf(R->names[j],"@@(%d)",i+1);
2451	}
2452	}
2453	}
2454	}
2455
2456	static inline BOOLEAN rComposeVar(const lists L, ring R)
2457	{
2458	assume(R!=NULL);
2459	if (L->m[1].Typ()==LIST_CMD)
2460	{
2461	lists v=(lists)L->m[1].Data();
2462	R->N = v->nr+1;
2463	if (R->N<=0)
2464	{
2465	WerrorS("no ring variables");
2466	return TRUE;
2467	}
2468	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
2469	int i;
2470	for(i=0;i<R->N;i++)
2471	{
2472	if (v->m[i].Typ()==STRING_CMD)
2473	R->names[i]=omStrDup((char *)v->m[i].Data());
2474	else if (v->m[i].Typ()==POLY_CMD)
2475	{
2476	poly p=(poly)v->m[i].Data();
2477	int nr=pIsPurePower(p);
2478	if (nr>0)
2479	R->names[i]=omStrDup(currRing->names[nr-1]);
2480	else
2481	{
2482	Werror("var name %d must be a string or a ring variable",i+1);
2483	return TRUE;
2484	}
2485	}
2486	else
2487	{
2488	Werror("var name %d must be `string` (not %d)",i+1, v->m[i].Typ());
2489	return TRUE;
2490	}
2491	}
2492	}
2493	else
2494	{
2495	WerrorS("variable must be given as `list`");
2496	return TRUE;
2497	}
2498	return FALSE;
2499	}
2500
2501	static inline BOOLEAN rComposeOrder(const lists L, const BOOLEAN check_comp, ring R)
2502	{
2503	assume(R!=NULL);
2504	long bitmask=0L;
2505	if (L->m[2].Typ()==LIST_CMD)
2506	{
2507	lists v=(lists)L->m[2].Data();
2508	int n= v->nr+2;
2509	int j_in_R,j_in_L;
2510	// do we have an entry "L",... ?: set bitmask
2511	for (int j=0; j < n-1; j++)
2512	{
2513	if (v->m[j].Typ()==LIST_CMD)
2514	{
2515	lists vv=(lists)v->m[j].Data();
2516	if ((vv->nr==1)
2517	&&(vv->m[0].Typ()==STRING_CMD)
2518	&&(strcmp((char*)vv->m[0].Data(),"L")==0))
2519	{
2520	number nn=(number)vv->m[1].Data();
2521	if (vv->m[1].Typ()==BIGINT_CMD)
2522	bitmask=n_Int(nn,coeffs_BIGINT);
2523	else if (vv->m[1].Typ()==INT_CMD)
2524	bitmask=(long)nn;
2525	else
2526	{
2527	Werror("illegal argument for pseudo ordering L: %d",vv->m[1].Typ());
2528	return TRUE;
2529	}
2530	break;
2531	}
2532	}
2533	}
2534	if (bitmask!=0) n--;
2535
2536	// initialize fields of R
2537	R->order=(rRingOrder_t )omAlloc0((n+1)sizeof(rRingOrder_t));
2538	R->block0=(int )omAlloc0((n+1)sizeof(int));
2539	R->block1=(int )omAlloc0((n+1)sizeof(int));
2540	R->wvhdl=(int*)omAlloc0((n+1)sizeof(int_ptr));
2541	// init order, so that rBlocks works correctly
2542	for (j_in_R= n-2; j_in_R>=0; j_in_R--)
2543	R->order[j_in_R] = ringorder_unspec;
2544	// orderings
2545	for(j_in_R=0,j_in_L=0;j_in_R<n-1;j_in_R++,j_in_L++)
2546	{
2547	// todo: a(..), M
2548	if (v->m[j_in_L].Typ()!=LIST_CMD)
2549	{
2550	WerrorS("ordering must be list of lists");
2551	return TRUE;
2552	}
2553	lists vv=(lists)v->m[j_in_L].Data();
2554	if ((vv->nr==1)
2555	&& (vv->m[0].Typ()==STRING_CMD))
2556	{
2557	if (strcmp((char*)vv->m[0].Data(),"L")==0)
2558	{
2559	j_in_R--;
2560	continue;
2561	}
2562	if ((vv->m[1].Typ()!=INTVEC_CMD) && (vv->m[1].Typ()!=INT_CMD)
2563	&& (vv->m[1].Typ()!=INTMAT_CMD))
2564	{
2565	PrintS(lString(vv));
2566	Werror("ordering name must be a (string,intvec), not (string,%s)",Tok2Cmdname(vv->m[1].Typ()));
2567	return TRUE;
2568	}
2569	R->order[j_in_R]=rOrderName(omStrDup((char*)vv->m[0].Data())); // assume STRING
2570
2571	if (j_in_R==0) R->block0[0]=1;
2572	else
2573	{
2574	int jj=j_in_R-1;
2575	while((jj>=0)
2576	&& ((R->order[jj]== ringorder_a)
2577	\|\| (R->order[jj]== ringorder_aa)
2578	\|\| (R->order[jj]== ringorder_am)
2579	\|\| (R->order[jj]== ringorder_c)
2580	\|\| (R->order[jj]== ringorder_C)
2581	\|\| (R->order[jj]== ringorder_s)
2582	\|\| (R->order[jj]== ringorder_S)
2583	))
2584	{
2585	//Print("jj=%, skip %s\n",rSimpleOrdStr(R->order[jj]));
2586	jj--;
2587	}
2588	if (jj<0) R->block0[j_in_R]=1;
2589	else R->block0[j_in_R]=R->block1[jj]+1;
2590	}
2591	intvec *iv;
2592	if (vv->m[1].Typ()==INT_CMD)
2593	{
2594	int l=si_max(1,(int)(long)vv->m[1].Data());
2595	iv=new intvec(l);
2596	for(int i=0;i<l;i++) (*iv)[i]=1;
2597	}
2598	else
2599	iv=ivCopy((intvec*)vv->m[1].Data()); //assume INTVEC/INTMAT
2600	int iv_len=iv->length();
2601	if (iv_len==0)
2602	{
2603	Werror("empty intvec for ordering %d (%s)",j_in_R+1,rSimpleOrdStr(R->order[j_in_R]));
2604	return TRUE;
2605	}
2606	if (R->order[j_in_R]==ringorder_M)
2607	{
2608	if (vv->m[1].rtyp==INTMAT_CMD) iv->makeVector();
2609	iv_len=iv->length();
2610	}
2611	if ((R->order[j_in_R]!=ringorder_s)
2612	&&(R->order[j_in_R]!=ringorder_c)
2613	&&(R->order[j_in_R]!=ringorder_C))
2614	{
2615	R->block1[j_in_R]=si_max(R->block0[j_in_R],R->block0[j_in_R]+iv_len-1);
2616	if (R->block1[j_in_R]>R->N)
2617	{
2618	if (R->block0[j_in_R]>R->N)
2619	{
2620	Werror("not enough variables for ordering %d (%s)",j_in_R,rSimpleOrdStr(R->order[j_in_R]));
2621	return TRUE;
2622	}
2623	R->block1[j_in_R]=R->N;
2624	iv_len=R->block1[j_in_R]-R->block0[j_in_R]+1;
2625	}
2626	//Print("block %d from %d to %d\n",j,R->block0[j], R->block1[j]);
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	R->block1[j_in_R]=si_max(R->block0[j_in_R],R->block0[j_in_R]+(int)sqrt((double)(iv->length())));
2661	if (R->block1[j_in_R]>R->N)
2662	{
2663	R->block1[j_in_R]=R->N;
2664	}
2665	break;
2666	case ringorder_ls:
2667	case ringorder_ds:
2668	case ringorder_Ds:
2669	case ringorder_rs:
2670	R->OrdSgn=-1;
2671	case ringorder_lp:
2672	case ringorder_dp:
2673	case ringorder_Dp:
2674	case ringorder_rp:
2675	#if 0
2676	for (i=0; i<iv_len;i++)
2677	{
2678	if (((*iv)[i]!=1)&&(iv_len!=1))
2679	{
2680	iv->show(1);
2681	Warn("ignore weight %d for ord %d (%s) at pos %d\n>>%s<<",
2682	(*iv)[i],j_in_R+1,rSimpleOrdStr(R->order[j_in_R]),i+1,my_yylinebuf);
2683	break;
2684	}
2685	}
2686	#endif // break absfact.tst
2687	break;
2688	case ringorder_S:
2689	break;
2690	case ringorder_c:
2691	case ringorder_C:
2692	R->block1[j_in_R]=R->block0[j_in_R]=0;
2693	break;
2694
2695	case ringorder_s:
2696	R->block1[j_in_R]=R->block0[j_in_R]=(*iv)[0];
2697	rSetSyzComp(R->block0[j_in_R],R);
2698	break;
2699
2700	case ringorder_IS:
2701	{
2702	R->block1[j_in_R] = R->block0[j_in_R] = 0;
2703	if( iv->length() > 0 )
2704	{
2705	const int s = (*iv)[0];
2706	assume( -2 < s && s < 2 );
2707	R->block1[j_in_R] = R->block0[j_in_R] = s;
2708	}
2709	break;
2710	}
2711	case 0:
2712	case ringorder_unspec:
2713	break;
2714	case ringorder_L: /* cannot happen */
2715	case ringorder_a64: /not implemented /
2716	WerrorS("ring order not implemented");
2717	return TRUE;
2718	}
2719	delete iv;
2720	}
2721	else
2722	{
2723	PrintS(lString(vv));
2724	WerrorS("ordering name must be a (string,intvec)");
2725	return TRUE;
2726	}
2727	}
2728	// sanity check
2729	j_in_R=n-2;
2730	if ((R->order[j_in_R]==ringorder_c)
2731	\|\| (R->order[j_in_R]==ringorder_C)
2732	\|\| (R->order[j_in_R]==ringorder_unspec)) j_in_R--;
2733	if (R->block1[j_in_R] != R->N)
2734	{
2735	if (((R->order[j_in_R]==ringorder_dp) \|\|
2736	(R->order[j_in_R]==ringorder_ds) \|\|
2737	(R->order[j_in_R]==ringorder_Dp) \|\|
2738	(R->order[j_in_R]==ringorder_Ds) \|\|
2739	(R->order[j_in_R]==ringorder_rp) \|\|
2740	(R->order[j_in_R]==ringorder_rs) \|\|
2741	(R->order[j_in_R]==ringorder_lp) \|\|
2742	(R->order[j_in_R]==ringorder_ls))
2743	&&
2744	R->block0[j_in_R] <= R->N)
2745	{
2746	R->block1[j_in_R] = R->N;
2747	}
2748	else
2749	{
2750	Werror("ordering incomplete: size (%d) should be %d",R->block1[j_in_R],R->N);
2751	return TRUE;
2752	}
2753	}
2754	if (R->block0[j_in_R]>R->N)
2755	{
2756	Werror("not enough variables (%d) for ordering block %d, scanned so far:",R->N,j_in_R+1);
2757	for(int ii=0;ii<=j_in_R;ii++)
2758	Werror("ord[%d]: %s from v%d to v%d",ii+1,rSimpleOrdStr(R->order[ii]),R->block0[ii],R->block1[ii]);
2759	return TRUE;
2760	}
2761	if (check_comp)
2762	{
2763	BOOLEAN comp_order=FALSE;
2764	int jj;
2765	for(jj=0;jj<n;jj++)
2766	{
2767	if ((R->order[jj]==ringorder_c) \|\|
2768	(R->order[jj]==ringorder_C)) { comp_order=TRUE; break; }
2769	}
2770	if (!comp_order)
2771	{
2772	R->order=(rRingOrder_t)omRealloc0Size(R->order,nsizeof(rRingOrder_t),(n+1)*sizeof(rRingOrder_t));
2773	R->block0=(int)omRealloc0Size(R->block0,nsizeof(int),(n+1)*sizeof(int));
2774	R->block1=(int)omRealloc0Size(R->block1,nsizeof(int),(n+1)*sizeof(int));
2775	R->wvhdl=(int*)omRealloc0Size(R->wvhdl,nsizeof(int_ptr),(n+1)*sizeof(int_ptr));
2776	R->order[n-1]=ringorder_C;
2777	R->block0[n-1]=0;
2778	R->block1[n-1]=0;
2779	R->wvhdl[n-1]=NULL;
2780	n++;
2781	}
2782	}
2783	}
2784	else
2785	{
2786	WerrorS("ordering must be given as `list`");
2787	return TRUE;
2788	}
2789	if (bitmask!=0) { R->bitmask=bitmask; R->wanted_maxExp=bitmask; }
2790	return FALSE;
2791	}
2792
2793	ring rCompose(const lists L, const BOOLEAN check_comp, const long bitmask,const int isLetterplace)
2794	{
2795	if ((L->nr!=3)
2796	#ifdef HAVE_PLURAL
2797	&&(L->nr!=5)
2798	#endif
2799	)
2800	return NULL;
2801	int is_gf_char=0;
2802	// 0: char/ cf - ring
2803	// 1: list (var)
2804	// 2: list (ord)
2805	// 3: qideal
2806	// possibly:
2807	// 4: C
2808	// 5: D
2809
2810	ring R = (ring) omAlloc0Bin(sip_sring_bin);
2811
2812	// ------------------------------------------------------------------
2813	// 0: char:
2814	if (L->m[0].Typ()==CRING_CMD)
2815	{
2816	R->cf=(coeffs)L->m[0].Data();
2817	R->cf->ref++;
2818	}
2819	else if (L->m[0].Typ()==INT_CMD)
2820	{
2821	int ch = (int)(long)L->m[0].Data();
2822	assume( ch >= 0 );
2823
2824	if (ch == 0) // Q?
2825	R->cf = nInitChar(n_Q, NULL);
2826	else
2827	{
2828	int l = IsPrime(ch); // Zp?
2829	if( l != ch )
2830	{
2831	Warn("%d is invalid characteristic of ground field. %d is used.", ch, l);
2832	ch = l;
2833	}
2834	#ifndef TEST_ZN_AS_ZP
2835	R->cf = nInitChar(n_Zp, (void*)(long)ch);
2836	#else
2837	mpz_t modBase;
2838	mpz_init_set_ui(modBase,(long) ch);
2839	ZnmInfo info;
2840	info.base= modBase;
2841	info.exp= 1;
2842	R->cf=nInitChar(n_Zn,(void*) &info); //exponent is missing
2843	R->cf->is_field=1;
2844	R->cf->is_domain=1;
2845	R->cf->has_simple_Inverse=1;
2846	#endif
2847	}
2848	}
2849	else if (L->m[0].Typ()==LIST_CMD) // something complicated...
2850	{
2851	lists LL=(lists)L->m[0].Data();
2852
2853	#ifdef HAVE_RINGS
2854	if (LL->m[0].Typ() == STRING_CMD) // 1st comes a string?
2855	{
2856	rComposeRing(LL, R); // Ring!?
2857	}
2858	else
2859	#endif
2860	if (LL->nr < 3)
2861	rComposeC(LL,R); // R, long_R, long_C
2862	else
2863	{
2864	if (LL->m[0].Typ()==INT_CMD)
2865	{
2866	int ch = (int)(long)LL->m[0].Data();
2867	while ((ch!=fftable[is_gf_char]) && (fftable[is_gf_char])) is_gf_char++;
2868	if (fftable[is_gf_char]==0) is_gf_char=-1;
2869
2870	if(is_gf_char!= -1)
2871	{
2872	GFInfo param;
2873
2874	param.GFChar = ch;
2875	param.GFDegree = 1;
2876	param.GFPar_name = (const char*)(((lists)(LL->m[1].Data()))->m[0].Data());
2877
2878	// nfInitChar should be able to handle the case when ch is in fftables!
2879	R->cf = nInitChar(n_GF, (void*)&param);
2880	}
2881	}
2882
2883	if( R->cf == NULL )
2884	{
2885	ring extRing = rCompose((lists)L->m[0].Data(),FALSE,0x7fff);
2886
2887	if (extRing==NULL)
2888	{
2889	WerrorS("could not create the specified coefficient field");
2890	goto rCompose_err;
2891	}
2892
2893	if( extRing->qideal != NULL ) // Algebraic extension
2894	{
2895	AlgExtInfo extParam;
2896
2897	extParam.r = extRing;
2898
2899	R->cf = nInitChar(n_algExt, (void*)&extParam);
2900	}
2901	else // Transcendental extension
2902	{
2903	TransExtInfo extParam;
2904	extParam.r = extRing;
2905	assume( extRing->qideal == NULL );
2906
2907	R->cf = nInitChar(n_transExt, &extParam);
2908	}
2909	}
2910	}
2911	}
2912	else
2913	{
2914	WerrorS("coefficient field must be described by `int` or `list`");
2915	goto rCompose_err;
2916	}
2917
2918	if( R->cf == NULL )
2919	{
2920	WerrorS("could not create coefficient field described by the input!");
2921	goto rCompose_err;
2922	}
2923
2924	// ------------------------- VARS ---------------------------
2925	if (rComposeVar(L,R)) goto rCompose_err;
2926	// ------------------------ ORDER ------------------------------
2927	if (rComposeOrder(L,check_comp,R)) goto rCompose_err;
2928
2929	// ------------------------ ??????? --------------------
2930
2931	if (!isLetterplace) rRenameVars(R);
2932	#ifdef HAVE_SHIFTBBA
2933	else
2934	{
2935	R->isLPring=isLetterplace;
2936	R->ShortOut=FALSE;
2937	R->CanShortOut=FALSE;
2938	}
2939	#endif
2940	if ((bitmask!=0)&&(R->wanted_maxExp==0)) R->wanted_maxExp=bitmask;
2941	rComplete(R);
2942
2943	// ------------------------ Q-IDEAL ------------------------
2944
2945	if (L->m[3].Typ()==IDEAL_CMD)
2946	{
2947	ideal q=(ideal)L->m[3].Data();
2948	if (q->m[0]!=NULL)
2949	{
2950	if (R->cf != currRing->cf) //->cf->ch!=currRing->cf->ch)
2951	{
2952	#if 0
2953	WerrorS("coefficient fields must be equal if q-ideal !=0");
2954	goto rCompose_err;
2955	#else
2956	ring orig_ring=currRing;
2957	rChangeCurrRing(R);
2958	int *perm=NULL;
2959	int *par_perm=NULL;
2960	int par_perm_size=0;
2961	nMapFunc nMap;
2962
2963	if ((nMap=nSetMap(orig_ring->cf))==NULL)
2964	{
2965	if (rEqual(orig_ring,currRing))
2966	{
2967	nMap=n_SetMap(currRing->cf, currRing->cf);
2968	}
2969	else
2970	// Allow imap/fetch to be make an exception only for:
2971	if ( (rField_is_Q_a(orig_ring) && // Q(a..) -> Q(a..) \|\| Q \|\| Zp \|\| Zp(a)
2972	(rField_is_Q(currRing) \|\| rField_is_Q_a(currRing) \|\|
2973	rField_is_Zp(currRing) \|\| rField_is_Zp_a(currRing) \|\|
2974	rField_is_Zn(currRing)))
2975	\|\|
2976	(rField_is_Zp_a(orig_ring) && // Zp(a..) -> Zp(a..) \|\| Zp
2977	(rField_is_Zp(currRing, rInternalChar(orig_ring)) \|\|
2978	rField_is_Zp_a(currRing, rInternalChar(orig_ring)))) )
2979	{
2980	par_perm_size=rPar(orig_ring);
2981
2982	// if ((orig_ring->minpoly != NULL) \|\| (orig_ring->qideal != NULL))
2983	// naSetChar(rInternalChar(orig_ring),orig_ring);
2984	// else ntSetChar(rInternalChar(orig_ring),orig_ring);
2985
2986	nSetChar(currRing->cf);
2987	}
2988	else
2989	{
2990	WerrorS("coefficient fields must be equal if q-ideal !=0");
2991	goto rCompose_err;
2992	}
2993	}
2994	perm=(int )omAlloc0((orig_ring->N+1)sizeof(int));
2995	if (par_perm_size!=0)
2996	par_perm=(int )omAlloc0(par_perm_sizesizeof(int));
2997	int i;
2998	#if 0
2999	// use imap:
3000	maFindPerm(orig_ring->names,orig_ring->N,orig_ring->parameter,orig_ring->P,
3001	currRing->names,currRing->N,currRing->parameter, currRing->P,
3002	perm,par_perm, currRing->ch);
3003	#else
3004	// use fetch
3005	if ((rPar(orig_ring)>0) && (rPar(currRing)==0))
3006	{
3007	for(i=si_min(rPar(orig_ring),rVar(currRing))-1;i>=0;i--) par_perm[i]=i+1;
3008	}
3009	else if (par_perm_size!=0)
3010	for(i=si_min(rPar(orig_ring),rPar(currRing))-1;i>=0;i--) par_perm[i]=-(i+1);
3011	for(i=si_min(orig_ring->N,rVar(currRing));i>0;i--) perm[i]=i;
3012	#endif
3013	ideal dest_id=idInit(IDELEMS(q),1);
3014	for(i=IDELEMS(q)-1; i>=0; i--)
3015	{
3016	dest_id->m[i]=p_PermPoly(q->m[i],perm,orig_ring, currRing,nMap,
3017	par_perm,par_perm_size);
3018	// PrintS("map:");pWrite(dest_id->m[i]);PrintLn();
3019	pTest(dest_id->m[i]);
3020	}
3021	R->qideal=dest_id;
3022	if (perm!=NULL)
3023	omFreeSize((ADDRESS)perm,(orig_ring->N+1)*sizeof(int));
3024	if (par_perm!=NULL)
3025	omFreeSize((ADDRESS)par_perm,par_perm_size*sizeof(int));
3026	rChangeCurrRing(orig_ring);
3027	#endif
3028	}
3029	else
3030	R->qideal=idrCopyR(q,currRing,R);
3031	}
3032	}
3033	else
3034	{
3035	WerrorS("q-ideal must be given as `ideal`");
3036	goto rCompose_err;
3037	}
3038
3039
3040	// ---------------------------------------------------------------
3041	#ifdef HAVE_PLURAL
3042	if (L->nr==5)
3043	{
3044	if (nc_CallPlural((matrix)L->m[4].Data(),
3045	(matrix)L->m[5].Data(),
3046	NULL,NULL,
3047	R,
3048	true, // !!!
3049	true, false,
3050	currRing, FALSE)) goto rCompose_err;
3051	// takes care about non-comm. quotient! i.e. calls "nc_SetupQuotient" due to last true
3052	}
3053	#endif
3054	return R;
3055
3056	rCompose_err:
3057	if (R->N>0)
3058	{
3059	int i;
3060	if (R->names!=NULL)
3061	{
3062	i=R->N-1;
3063	while (i>=0) { omfree(R->names[i]); i--; }
3064	omFree(R->names);
3065	}
3066	}
3067	omfree(R->order);
3068	omfree(R->block0);
3069	omfree(R->block1);
3070	omfree(R->wvhdl);
3071	omFree(R);
3072	return NULL;
3073	}
3074
3075	// from matpol.cc
3076
3077	/*2
3078	* compute the jacobi matrix of an ideal
3079	*/
3080	BOOLEAN mpJacobi(leftv res,leftv a)
3081	{
3082	int i,j;
3083	matrix result;
3084	ideal id=(ideal)a->Data();
3085
3086	result =mpNew(IDELEMS(id),rVar(currRing));
3087	for (i=1; i<=IDELEMS(id); i++)
3088	{
3089	for (j=1; j<=rVar(currRing); j++)
3090	{
3091	MATELEM(result,i,j) = pDiff(id->m[i-1],j);
3092	}
3093	}
3094	res->data=(char *)result;
3095	return FALSE;
3096	}
3097
3098	/*2
3099	* returns the Koszul-matrix of degree d of a vectorspace with dimension n
3100	* uses the first n entrees of id, if id <> NULL
3101	*/
3102	BOOLEAN mpKoszul(leftv res,leftv c/ip/, leftv b/in/, leftv id)
3103	{
3104	int n=(int)(long)b->Data();
3105	int d=(int)(long)c->Data();
3106	int k,l,sign,row,col;
3107	matrix result;
3108	ideal temp;
3109	BOOLEAN bo;
3110	poly p;
3111
3112	if ((d>n) \|\| (d<1) \|\| (n<1))
3113	{
3114	res->data=(char *)mpNew(1,1);
3115	return FALSE;
3116	}
3117	int choise = (int)omAlloc(d*sizeof(int));
3118	if (id==NULL)
3119	temp=idMaxIdeal(1);
3120	else
3121	temp=(ideal)id->Data();
3122
3123	k = binom(n,d);
3124	l = k*d;
3125	l /= n-d+1;
3126	result =mpNew(l,k);
3127	col = 1;
3128	idInitChoise(d,1,n,&bo,choise);
3129	while (!bo)
3130	{
3131	sign = 1;
3132	for (l=1;l<=d;l++)
3133	{
3134	if (choise[l-1]<=IDELEMS(temp))
3135	{
3136	p = pCopy(temp->m[choise[l-1]-1]);
3137	if (sign == -1) p = pNeg(p);
3138	sign *= -1;
3139	row = idGetNumberOfChoise(l-1,d,1,n,choise);
3140	MATELEM(result,row,col) = p;
3141	}
3142	}
3143	col++;
3144	idGetNextChoise(d,n,&bo,choise);
3145	}
3146	omFreeSize(choise,d*sizeof(int));
3147	if (id==NULL) idDelete(&temp);
3148
3149	res->data=(char *)result;
3150	return FALSE;
3151	}
3152
3153	// from syz1.cc
3154	/*2
3155	* read out the Betti numbers from resolution
3156	* (interpreter interface)
3157	*/
3158	BOOLEAN syBetti2(leftv res, leftv u, leftv w)
3159	{
3160	syStrategy syzstr=(syStrategy)u->Data();
3161
3162	BOOLEAN minim=(int)(long)w->Data();
3163	int row_shift=0;
3164	int add_row_shift=0;
3165	intvec *weights=NULL;
3166	intvec ww=(intvec )atGet(u,"isHomog",INTVEC_CMD);
3167	if (ww!=NULL)
3168	{
3169	weights=ivCopy(ww);
3170	add_row_shift = ww->min_in();
3171	(*weights) -= add_row_shift;
3172	}
3173
3174	res->data=(void *)syBettiOfComputation(syzstr,minim,&row_shift,weights);
3175	//row_shift += add_row_shift;
3176	//Print("row_shift=%d, add_row_shift=%d\n",row_shift,add_row_shift);
3177	atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
3178
3179	return FALSE;
3180	}
3181	BOOLEAN syBetti1(leftv res, leftv u)
3182	{
3183	sleftv tmp;
3184	tmp.Init();
3185	tmp.rtyp=INT_CMD;
3186	tmp.data=(void *)1;
3187	return syBetti2(res,u,&tmp);
3188	}
3189
3190	/*3
3191	* converts a resolution into a list of modules
3192	*/
3193	lists syConvRes(syStrategy syzstr,BOOLEAN toDel,int add_row_shift)
3194	{
3195	resolvente fullres = syzstr->fullres;
3196	resolvente minres = syzstr->minres;
3197
3198	const int length = syzstr->length;
3199
3200	if ((fullres==NULL) && (minres==NULL))
3201	{
3202	if (syzstr->hilb_coeffs==NULL)
3203	{ // La Scala
3204	fullres = syReorder(syzstr->res, length, syzstr);
3205	}
3206	else
3207	{ // HRES
3208	minres = syReorder(syzstr->orderedRes, length, syzstr);
3209	syKillEmptyEntres(minres, length);
3210	}
3211	}
3212
3213	resolvente tr;
3214	int typ0=IDEAL_CMD;
3215
3216	if (minres!=NULL)
3217	tr = minres;
3218	else
3219	tr = fullres;
3220
3221	resolvente trueres=NULL;
3222	intvec ** w=NULL;
3223
3224	if (length>0)
3225	{
3226	trueres = (resolvente)omAlloc0((length)*sizeof(ideal));
3227	for (int i=length-1;i>=0;i--)
3228	{
3229	if (tr[i]!=NULL)
3230	{
3231	trueres[i] = idCopy(tr[i]);
3232	}
3233	}
3234	if ( id_RankFreeModule(trueres[0], currRing) > 0)
3235	typ0 = MODUL_CMD;
3236	if (syzstr->weights!=NULL)
3237	{
3238	w = (intvec*)omAlloc0(lengthsizeof(intvec*));
3239	for (int i=length-1;i>=0;i--)
3240	{
3241	if (syzstr->weights[i]!=NULL) w[i] = ivCopy(syzstr->weights[i]);
3242	}
3243	}
3244	}
3245
3246	lists li = liMakeResolv(trueres, length, syzstr->list_length,typ0,
3247	w, add_row_shift);
3248
3249	if (toDel)
3250	syKillComputation(syzstr);
3251	else
3252	{
3253	if( fullres != NULL && syzstr->fullres == NULL )
3254	syzstr->fullres = fullres;
3255
3256	if( minres != NULL && syzstr->minres == NULL )
3257	syzstr->minres = minres;
3258	}
3259	return li;
3260	}
3261
3262	/*3
3263	* converts a list of modules into a resolution
3264	*/
3265	syStrategy syConvList(lists li)
3266	{
3267	int typ0;
3268	syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
3269
3270	resolvente fr = liFindRes(li,&(result->length),&typ0,&(result->weights));
3271	if (fr != NULL)
3272	{
3273
3274	result->fullres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3275	for (int i=result->length-1;i>=0;i--)
3276	{
3277	if (fr[i]!=NULL)
3278	result->fullres[i] = idCopy(fr[i]);
3279	}
3280	result->list_length=result->length;
3281	omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3282	}
3283	else
3284	{
3285	omFreeSize(result, sizeof(ssyStrategy));
3286	result = NULL;
3287	}
3288	return result;
3289	}
3290
3291	/*3
3292	* converts a list of modules into a minimal resolution
3293	*/
3294	syStrategy syForceMin(lists li)
3295	{
3296	int typ0;
3297	syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
3298
3299	resolvente fr = liFindRes(li,&(result->length),&typ0);
3300	result->minres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3301	for (int i=result->length-1;i>=0;i--)
3302	{
3303	if (fr[i]!=NULL)
3304	result->minres[i] = idCopy(fr[i]);
3305	}
3306	omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3307	return result;
3308	}
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);
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	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	omFree(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	omFree(hh);
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	TransExtInfo extParam;
5903	extParam.r = (ring)pn->Data();
5904	extParam.r->ref++;
5905	cf = nInitChar(n_transExt, &extParam);
5906	}
5907	//else if ((pn->Typ()==QRING_CMD) && (P == 1)) // same for qrings - which should be fields!?
5908	//{
5909	// AlgExtInfo extParam;
5910	// extParam.r = (ring)pn->Data();
5911
5912	// cf = nInitChar(n_algExt, &extParam); // Q[a]/<minideal>
5913	//}
5914	else
5915	{
5916	WerrorS("Wrong or unknown ground field specification");
5917	#if 0
5918	// debug stuff for unknown cf descriptions:
5919	sleftv* p = pn;
5920	while (p != NULL)
5921	{
5922	Print( "pn[%p]: type: %d [%s]: %p, name: %s", (void*)p, p->Typ(), Tok2Cmdname(p->Typ()), p->Data(), (p->name == NULL? "NULL" : p->name) );
5923	PrintLn();
5924	p = p->next;
5925	}
5926	#endif
5927	goto rInitError;
5928	}
5929
5930	/every entry in the new ring is initialized to 0/
5931
5932	/* characteristic -----------------------------------------------*/
5933	/* input: 0 ch=0 : Q parameter=NULL ffChar=FALSE float_len
5934	* 0 1 : Q(a,...) *names FALSE
5935	* 0 -1 : R NULL FALSE 0
5936	* 0 -1 : R NULL FALSE prec. >6
5937	* 0 -1 : C *names FALSE prec. 0..?
5938	* p p : Fp NULL FALSE
5939	* p -p : Fp(a) *names FALSE
5940	* q q : GF(q=p^n) *names TRUE
5941	*/
5942	if (cf==NULL)
5943	{
5944	WerrorS("Invalid ground field specification");
5945	goto rInitError;
5946	// const int ch=32003;
5947	// cf=nInitChar(n_Zp, (void*)(long)ch);
5948	}
5949
5950	assume( R != NULL );
5951
5952	R->cf = cf;
5953
5954	/* names and number of variables-------------------------------------*/
5955	{
5956	int l=rv->listLength();
5957
5958	if (l>MAX_SHORT)
5959	{
5960	Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
5961	goto rInitError;
5962	}
5963	R->N = l; /rv->listLength();/
5964	}
5965	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
5966	if (rSleftvList2StringArray(rv, R->names))
5967	{
5968	WerrorS("name of ring variable expected");
5969	goto rInitError;
5970	}
5971
5972	/* check names and parameters for conflicts ------------------------- */
5973	rRenameVars(R); // conflicting variables will be renamed
5974	/* ordering -------------------------------------------------------------*/
5975	if (rSleftvOrdering2Ordering(ord, R))
5976	goto rInitError;
5977
5978	// Complete the initialization
5979	if (rComplete(R,1))
5980	goto rInitError;
5981
5982	/*#ifdef HAVE_RINGS
5983	// currently, coefficients which are ring elements require a global ordering:
5984	if (rField_is_Ring(R) && (R->OrdSgn==-1))
5985	{
5986	WerrorS("global ordering required for these coefficients");
5987	goto rInitError;
5988	}
5989	#endif*/
5990
5991	rTest(R);
5992
5993	// try to enter the ring into the name list
5994	// need to clean up sleftv here, before this ring can be set to
5995	// new currRing or currRing can be killed beacuse new ring has
5996	// same name
5997	pn->CleanUp();
5998	rv->CleanUp();
5999	ord->CleanUp();
6000	//if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
6001	// goto rInitError;
6002
6003	//memcpy(IDRING(tmp),R,sizeof(*R));
6004	// set current ring
6005	//omFreeBin(R, ip_sring_bin);
6006	//return tmp;
6007	return R;
6008
6009	// error case:
6010	rInitError:
6011	if ((R != NULL)&&(R->cf!=NULL)) rDelete(R);
6012	pn->CleanUp();
6013	rv->CleanUp();
6014	ord->CleanUp();
6015	return NULL;
6016	}
6017
6018	ring rSubring(ring org_ring, sleftv* rv)
6019	{
6020	ring R = rCopy0(org_ring);
6021	int perm=(int )omAlloc0((org_ring->N+1)*sizeof(int));
6022	int n = rBlocks(org_ring), i=0, j;
6023
6024	/* names and number of variables-------------------------------------*/
6025	{
6026	int l=rv->listLength();
6027	if (l>MAX_SHORT)
6028	{
6029	Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
6030	goto rInitError;
6031	}
6032	R->N = l; /rv->listLength();/
6033	}
6034	omFree(R->names);
6035	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
6036	if (rSleftvList2StringArray(rv, R->names))
6037	{
6038	WerrorS("name of ring variable expected");
6039	goto rInitError;
6040	}
6041
6042	/* check names for subring in org_ring ------------------------- */
6043	{
6044	i=0;
6045
6046	for(j=0;j<R->N;j++)
6047	{
6048	for(;i<org_ring->N;i++)
6049	{
6050	if (strcmp(org_ring->names[i],R->names[j])==0)
6051	{
6052	perm[i+1]=j+1;
6053	break;
6054	}
6055	}
6056	if (i>org_ring->N)
6057	{
6058	Werror("variable %d (%s) not in basering",j+1,R->names[j]);
6059	break;
6060	}
6061	}
6062	}
6063	//Print("perm=");
6064	//for(i=1;i<org_ring->N;i++) Print("v%d -> v%d\n",i,perm[i]);
6065	/* ordering -------------------------------------------------------------*/
6066
6067	for(i=0;i<n;i++)
6068	{
6069	int min_var=-1;
6070	int max_var=-1;
6071	for(j=R->block0[i];j<=R->block1[i];j++)
6072	{
6073	if (perm[j]>0)
6074	{
6075	if (min_var==-1) min_var=perm[j];
6076	max_var=perm[j];
6077	}
6078	}
6079	if (min_var!=-1)
6080	{
6081	//Print("block %d: old %d..%d, now:%d..%d\n",
6082	// i,R->block0[i],R->block1[i],min_var,max_var);
6083	R->block0[i]=min_var;
6084	R->block1[i]=max_var;
6085	if (R->wvhdl[i]!=NULL)
6086	{
6087	omFree(R->wvhdl[i]);
6088	R->wvhdl[i]=(int)omAlloc0((max_var-min_var+1)sizeof(int));
6089	for(j=org_ring->block0[i];j<=org_ring->block1[i];j++)
6090	{
6091	if (perm[j]>0)
6092	{
6093	R->wvhdl[i][perm[j]-R->block0[i]]=
6094	org_ring->wvhdl[i][j-org_ring->block0[i]];
6095	//Print("w%d=%d (orig_w%d)\n",perm[j],R->wvhdl[i][perm[j]-R->block0[i]],j);
6096	}
6097	}
6098	}
6099	}
6100	else
6101	{
6102	if(R->block0[i]>0)
6103	{
6104	//Print("skip block %d\n",i);
6105	R->order[i]=ringorder_unspec;
6106	if (R->wvhdl[i] !=NULL) omFree(R->wvhdl[i]);
6107	R->wvhdl[i]=NULL;
6108	}
6109	//else Print("keep block %d\n",i);
6110	}
6111	}
6112	i=n-1;
6113	while(i>0)
6114	{
6115	// removed unneded blocks
6116	if(R->order[i-1]==ringorder_unspec)
6117	{
6118	for(j=i;j<=n;j++)
6119	{
6120	R->order[j-1]=R->order[j];
6121	R->block0[j-1]=R->block0[j];
6122	R->block1[j-1]=R->block1[j];
6123	if (R->wvhdl[j-1] !=NULL) omFree(R->wvhdl[j-1]);
6124	R->wvhdl[j-1]=R->wvhdl[j];
6125	}
6126	R->order[n]=ringorder_unspec;
6127	n--;
6128	}
6129	i--;
6130	}
6131	n=rBlocks(org_ring)-1;
6132	while (R->order[n]==0) n--;
6133	while (R->order[n]==ringorder_unspec) n--;
6134	if ((R->order[n]==ringorder_c) \|\| (R->order[n]==ringorder_C)) n--;
6135	if (R->block1[n] != R->N)
6136	{
6137	if (((R->order[n]==ringorder_dp) \|\|
6138	(R->order[n]==ringorder_ds) \|\|
6139	(R->order[n]==ringorder_Dp) \|\|
6140	(R->order[n]==ringorder_Ds) \|\|
6141	(R->order[n]==ringorder_rp) \|\|
6142	(R->order[n]==ringorder_rs) \|\|
6143	(R->order[n]==ringorder_lp) \|\|
6144	(R->order[n]==ringorder_ls))
6145	&&
6146	R->block0[n] <= R->N)
6147	{
6148	R->block1[n] = R->N;
6149	}
6150	else
6151	{
6152	Werror("mismatch of number of vars (%d) and ordering (%d vars) in block %d",
6153	R->N,R->block1[n],n);
6154	return NULL;
6155	}
6156	}
6157	omFree(perm);
6158	// find OrdSgn:
6159	R->OrdSgn = org_ring->OrdSgn; // IMPROVE!
6160	//for(i=1;i<=R->N;i++)
6161	//{ if (weights[i]<0) { R->OrdSgn=-1;break; }}
6162	//omFree(weights);
6163	// Complete the initialization
6164	if (rComplete(R,1))
6165	goto rInitError;
6166
6167	rTest(R);
6168
6169	if (rv != NULL) rv->CleanUp();
6170
6171	return R;
6172
6173	// error case:
6174	rInitError:
6175	if (R != NULL) rDelete(R);
6176	if (rv != NULL) rv->CleanUp();
6177	return NULL;
6178	}
6179
6180	void rKill(ring r)
6181	{
6182	if ((r->ref<=0)&&(r->order!=NULL))
6183	{
6184	#ifdef RDEBUG
6185	if (traceit &TRACE_SHOW_RINGS) Print("kill ring %lx\n",(long)r);
6186	#endif
6187	int j;
6188	for (j=0;j<myynest;j++)
6189	{
6190	if (iiLocalRing[j]==r)
6191	{
6192	if (j==0) WarnS("killing the basering for level 0");
6193	iiLocalRing[j]=NULL;
6194	}
6195	}
6196	// any variables depending on r ?
6197	while (r->idroot!=NULL)
6198	{
6199	r->idroot->lev=myynest; // avoid warning about kill global objects
6200	killhdl2(r->idroot,&(r->idroot),r);
6201	}
6202	if (r==currRing)
6203	{
6204	// all dependend stuff is done, clean global vars:
6205	if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
6206	if (sLastPrinted.RingDependend())
6207	{
6208	sLastPrinted.CleanUp();
6209	}
6210	//if ((myynest>0) && (iiRETURNEXPR.RingDependend()))
6211	//{
6212	// WerrorS("return value depends on local ring variable (export missing ?)");
6213	// iiRETURNEXPR.CleanUp();
6214	//}
6215	currRing=NULL;
6216	currRingHdl=NULL;
6217	}
6218
6219	/* nKillChar(r); will be called from inside of rDelete */
6220	rDelete(r);
6221	return;
6222	}
6223	rDecRefCnt(r);
6224	}
6225
6226	void rKill(idhdl h)
6227	{
6228	ring r = IDRING(h);
6229	int ref=0;
6230	if (r!=NULL)
6231	{
6232	// avoid, that sLastPrinted is the last reference to the base ring:
6233	// clean up before killing the last "named" refrence:
6234	if ((sLastPrinted.rtyp==RING_CMD)
6235	&& (sLastPrinted.data==(void*)r))
6236	{
6237	sLastPrinted.CleanUp(r);
6238	}
6239	ref=r->ref;
6240	if ((ref<=0)&&(r==currRing))
6241	{
6242	// cleanup DENOMINATOR_LIST
6243	if (DENOMINATOR_LIST!=NULL)
6244	{
6245	denominator_list dd=DENOMINATOR_LIST;
6246	if (TEST_V_ALLWARN)
6247	Warn("deleting denom_list for ring change from %s",IDID(h));
6248	do
6249	{
6250	n_Delete(&(dd->n),currRing->cf);
6251	dd=dd->next;
6252	omFree(DENOMINATOR_LIST);
6253	DENOMINATOR_LIST=dd;
6254	} while(DENOMINATOR_LIST!=NULL);
6255	}
6256	}
6257	rKill(r);
6258	}
6259	if (h==currRingHdl)
6260	{
6261	if (ref<=0) { currRing=NULL; currRingHdl=NULL;}
6262	else
6263	{
6264	currRingHdl=rFindHdl(r,currRingHdl);
6265	}
6266	}
6267	}
6268
6269	static idhdl rSimpleFindHdl(const ring r, const idhdl root, const idhdl n)
6270	{
6271	idhdl h=root;
6272	while (h!=NULL)
6273	{
6274	if ((IDTYP(h)==RING_CMD)
6275	&& (h!=n)
6276	&& (IDRING(h)==r)
6277	)
6278	{
6279	return h;
6280	}
6281	h=IDNEXT(h);
6282	}
6283	return NULL;
6284	}
6285
6286	extern BOOLEAN jjPROC(leftv res, leftv u, leftv v);
6287
6288	static void jjINT_S_TO_ID(int n,int *e, leftv res)
6289	{
6290	if (n==0) n=1;
6291	ideal l=idInit(n,1);
6292	int i;
6293	poly p;
6294	for(i=rVar(currRing);i>0;i--)
6295	{
6296	if (e[i]>0)
6297	{
6298	n--;
6299	p=pOne();
6300	pSetExp(p,i,1);
6301	pSetm(p);
6302	l->m[n]=p;
6303	if (n==0) break;
6304	}
6305	}
6306	res->data=(char*)l;
6307	setFlag(res,FLAG_STD);
6308	omFreeSize((ADDRESS)e,(rVar(currRing)+1)*sizeof(int));
6309	}
6310	BOOLEAN jjVARIABLES_P(leftv res, leftv u)
6311	{
6312	int e=(int )omAlloc0((rVar(currRing)+1)*sizeof(int));
6313	int n=pGetVariables((poly)u->Data(),e);
6314	jjINT_S_TO_ID(n,e,res);
6315	return FALSE;
6316	}
6317
6318	BOOLEAN jjVARIABLES_ID(leftv res, leftv u)
6319	{
6320	int e=(int )omAlloc0((rVar(currRing)+1)*sizeof(int));
6321	ideal I=(ideal)u->Data();
6322	int i;
6323	int n=0;
6324	for(i=I->nrows*I->ncols-1;i>=0;i--)
6325	{
6326	int n0=pGetVariables(I->m[i],e);
6327	if (n0>n) n=n0;
6328	}
6329	jjINT_S_TO_ID(n,e,res);
6330	return FALSE;
6331	}
6332
6333	void paPrint(const char *n,package p)
6334	{
6335	Print(" %s (",n);
6336	switch (p->language)
6337	{
6338	case LANG_SINGULAR: PrintS("S"); break;
6339	case LANG_C: PrintS("C"); break;
6340	case LANG_TOP: PrintS("T"); break;
6341	case LANG_MAX: PrintS("M"); break;
6342	case LANG_NONE: PrintS("N"); break;
6343	default: PrintS("U");
6344	}
6345	if(p->libname!=NULL)
6346	Print(",%s", p->libname);
6347	PrintS(")");
6348	}
6349
6350	BOOLEAN iiApplyINTVEC(leftv res, leftv a, int op, leftv proc)
6351	{
6352	intvec aa=(intvec)a->Data();
6353	sleftv tmp_out;
6354	sleftv tmp_in;
6355	leftv curr=res;
6356	BOOLEAN bo=FALSE;
6357	for(int i=0;i<aa->length(); i++)
6358	{
6359	tmp_in.Init();
6360	tmp_in.rtyp=INT_CMD;
6361	tmp_in.data=(void)(long)(aa)[i];
6362	if (proc==NULL)
6363	bo=iiExprArith1(&tmp_out,&tmp_in,op);
6364	else
6365	bo=jjPROC(&tmp_out,proc,&tmp_in);
6366	if (bo)
6367	{
6368	res->CleanUp(currRing);
6369	Werror("apply fails at index %d",i+1);
6370	return TRUE;
6371	}
6372	if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6373	else
6374	{
6375	curr->next=(leftv)omAllocBin(sleftv_bin);
6376	curr=curr->next;
6377	memcpy(curr,&tmp_out,sizeof(tmp_out));
6378	}
6379	}
6380	return FALSE;
6381	}
6382	BOOLEAN iiApplyBIGINTMAT(leftv, leftv, int, leftv)
6383	{
6384	WerrorS("not implemented");
6385	return TRUE;
6386	}
6387	BOOLEAN iiApplyIDEAL(leftv, leftv, int, leftv)
6388	{
6389	WerrorS("not implemented");
6390	return TRUE;
6391	}
6392	BOOLEAN iiApplyLIST(leftv res, leftv a, int op, leftv proc)
6393	{
6394	lists aa=(lists)a->Data();
6395	sleftv tmp_out;
6396	sleftv tmp_in;
6397	leftv curr=res;
6398	BOOLEAN bo=FALSE;
6399	for(int i=0;i<=aa->nr; i++)
6400	{
6401	tmp_in.Init();
6402	tmp_in.Copy(&(aa->m[i]));
6403	if (proc==NULL)
6404	bo=iiExprArith1(&tmp_out,&tmp_in,op);
6405	else
6406	bo=jjPROC(&tmp_out,proc,&tmp_in);
6407	tmp_in.CleanUp();
6408	if (bo)
6409	{
6410	res->CleanUp(currRing);
6411	Werror("apply fails at index %d",i+1);
6412	return TRUE;
6413	}
6414	if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6415	else
6416	{
6417	curr->next=(leftv)omAllocBin(sleftv_bin);
6418	curr=curr->next;
6419	memcpy(curr,&tmp_out,sizeof(tmp_out));
6420	}
6421	}
6422	return FALSE;
6423	}
6424	BOOLEAN iiApply(leftv res, leftv a, int op, leftv proc)
6425	{
6426	res->Init();
6427	res->rtyp=a->Typ();
6428	switch (res->rtyp /a->Typ()/)
6429	{
6430	case INTVEC_CMD:
6431	case INTMAT_CMD:
6432	return iiApplyINTVEC(res,a,op,proc);
6433	case BIGINTMAT_CMD:
6434	return iiApplyBIGINTMAT(res,a,op,proc);
6435	case IDEAL_CMD:
6436	case MODUL_CMD:
6437	case MATRIX_CMD:
6438	return iiApplyIDEAL(res,a,op,proc);
6439	case LIST_CMD:
6440	return iiApplyLIST(res,a,op,proc);
6441	}
6442	WerrorS("first argument to `apply` must allow an index");
6443	return TRUE;
6444	}
6445
6446	BOOLEAN iiTestAssume(leftv a, leftv b)
6447	{
6448	// assume a: level
6449	if ((a->Typ()==INT_CMD)&&((long)a->Data()>=0))
6450	{
6451	if ((TEST_V_ALLWARN) && (myynest==0)) WarnS("ASSUME at top level is of no use: see documentation");
6452	char assume_yylinebuf[80];
6453	strncpy(assume_yylinebuf,my_yylinebuf,79);
6454	int lev=(long)a->Data();
6455	int startlev=0;
6456	idhdl h=ggetid("assumeLevel");
6457	if ((h!=NULL)&&(IDTYP(h)==INT_CMD)) startlev=(long)IDINT(h);
6458	if(lev <=startlev)
6459	{
6460	BOOLEAN bo=b->Eval();
6461	if (bo) { WerrorS("syntax error in ASSUME");return TRUE;}
6462	if (b->Typ()!=INT_CMD) { WerrorS("ASUMME(<level>,<int expr>)");return TRUE; }
6463	if (b->Data()==NULL) { Werror("ASSUME failed:%s",assume_yylinebuf);return TRUE;}
6464	}
6465	}
6466	b->CleanUp();
6467	a->CleanUp();
6468	return FALSE;
6469	}
6470
6471	#include "libparse.h"
6472
6473	BOOLEAN iiARROW(leftv r, char* a, char *s)
6474	{
6475	char ss=(char)omAlloc(strlen(a)+strlen(s)+30); /* max. 27 currently */
6476	// find end of s:
6477	int end_s=strlen(s);
6478	while ((end_s>0) && ((s[end_s]<=' ')\|\|(s[end_s]==';'))) end_s--;
6479	s[end_s+1]='\0';
6480	char name=(char )omAlloc(strlen(a)+strlen(s)+30);
6481	sprintf(name,"%s->%s",a,s);
6482	// find start of last expression
6483	int start_s=end_s-1;
6484	while ((start_s>=0) && (s[start_s]!=';')) start_s--;
6485	if (start_s<0) // ';' not found
6486	{
6487	sprintf(ss,"parameter def %s;return(%s);\n",a,s);
6488	}
6489	else // s[start_s] is ';'
6490	{
6491	s[start_s]='\0';
6492	sprintf(ss,"parameter def %s;%s;return(%s);\n",a,s,s+start_s+1);
6493	}
6494	r->Init();
6495	// now produce procinfo for PROC_CMD:
6496	r->data = (void *)omAlloc0Bin(procinfo_bin);
6497	((procinfo *)(r->data))->language=LANG_NONE;
6498	iiInitSingularProcinfo((procinfo *)r->data,"",name,0,0);
6499	((procinfo *)r->data)->data.s.body=ss;
6500	omFree(name);
6501	r->rtyp=PROC_CMD;
6502	//r->rtyp=STRING_CMD;
6503	//r->data=ss;
6504	return FALSE;
6505	}
6506
6507	BOOLEAN iiAssignCR(leftv r, leftv arg)
6508	{
6509	char* ring_name=omStrDup((char*)r->Name());
6510	int t=arg->Typ();
6511	if (t==RING_CMD)
6512	{
6513	sleftv tmp;
6514	tmp.Init();
6515	tmp.rtyp=IDHDL;
6516	idhdl h=rDefault(ring_name);
6517	tmp.data=(char*)h;
6518	if (h!=NULL)
6519	{
6520	tmp.name=h->id;
6521	BOOLEAN b=iiAssign(&tmp,arg);
6522	if (b) return TRUE;
6523	rSetHdl(ggetid(ring_name));
6524	omFree(ring_name);
6525	return FALSE;
6526	}
6527	else
6528	return TRUE;
6529	}
6530	else if (t==CRING_CMD)
6531	{
6532	sleftv tmp;
6533	sleftv n;
6534	n.Init();
6535	n.name=ring_name;
6536	if (iiDeclCommand(&tmp,&n,myynest,CRING_CMD,&IDROOT)) return TRUE;
6537	if (iiAssign(&tmp,arg)) return TRUE;
6538	//Print("create %s\n",r->Name());
6539	//Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6540	return FALSE;
6541	}
6542	//Print("create %s\n",r->Name());
6543	//Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6544	return TRUE;// not handled -> error for now
6545	}
6546
6547	static void iiReportTypes(int nr,int t,const short *T)
6548	{
6549	char buf[250];
6550	buf[0]='\0';
6551	if (nr==0)
6552	sprintf(buf,"wrong length of parameters(%d), expected ",t);
6553	else
6554	sprintf(buf,"par. %d is of type `%s`, expected ",nr,Tok2Cmdname(t));
6555	for(int i=1;i<=T[0];i++)
6556	{
6557	strcat(buf,"`");
6558	strcat(buf,Tok2Cmdname(T[i]));
6559	strcat(buf,"`");
6560	if (i<T[0]) strcat(buf,",");
6561	}
6562	WerrorS(buf);
6563	}
6564
6565	BOOLEAN iiCheckTypes(leftv args, const short *type_list, int report)
6566	{
6567	int l=0;
6568	if (args==NULL)
6569	{
6570	if (type_list[0]==0) return TRUE;
6571	}
6572	else l=args->listLength();
6573	if (l!=(int)type_list[0])
6574	{
6575	if (report) iiReportTypes(0,l,type_list);
6576	return FALSE;
6577	}
6578	for(int i=1;i<=l;i++,args=args->next)
6579	{
6580	short t=type_list[i];
6581	if (t!=ANY_TYPE)
6582	{
6583	if (((t==IDHDL)&&(args->rtyp!=IDHDL))
6584	\|\| (t!=args->Typ()))
6585	{
6586	if (report) iiReportTypes(i,args->Typ(),type_list);
6587	return FALSE;
6588	}
6589	}
6590	}
6591	return TRUE;
6592	}
6593
6594	void iiSetReturn(const leftv source)
6595	{
6596	if ((source->next==NULL)&&(source->e==NULL))
6597	{
6598	if ((source->rtyp!=IDHDL)&&(source->rtyp!=ALIAS_CMD))
6599	{
6600	memcpy(&iiRETURNEXPR,source,sizeof(sleftv));
6601	source->Init();
6602	return;
6603	}
6604	if (source->rtyp==IDHDL)
6605	{
6606	if ((IDLEV((idhdl)source->data)==myynest)
6607	&&(IDTYP((idhdl)source->data)!=RING_CMD))
6608	{
6609	iiRETURNEXPR.Init();
6610	iiRETURNEXPR.rtyp=IDTYP((idhdl)source->data);
6611	iiRETURNEXPR.data=IDDATA((idhdl)source->data);
6612	iiRETURNEXPR.flag=IDFLAG((idhdl)source->data);
6613	iiRETURNEXPR.attribute=IDATTR((idhdl)source->data);
6614	IDATTR((idhdl)source->data)=NULL;
6615	IDDATA((idhdl)source->data)=NULL;
6616	source->name=NULL;
6617	source->attribute=NULL;
6618	return;
6619	}
6620	}
6621	}
6622	iiRETURNEXPR.Copy(source);
6623	}

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

Download in other formats: