Context Navigation

source: git/Singular/ipshell.cc @ e7e815

spielwiese

Last change on this file since e7e815 was e7e815, checked in by Oleksandr Motsak <motsak@…>, 13 years ago
FIX: rCompose uses nInitChar now!
Property mode set to `100644`
File size: 134.3 KB

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

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

Download in other formats: