Context Navigation

source: git/Singular/ipshell.cc @ 95e3732

spielwiese

Last change on this file since 95e3732 was 95e3732, checked in by Hans Schoenemann <hannes@…>, 4 years ago
compiler warnings about memset
Property mode set to `100644`
File size: 163.6 KB

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

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

Download in other formats: