Context Navigation

source: git/Singular/ipshell.cc @ d18df5

spielwiese

Last change on this file since d18df5 was d18df5, checked in by Hans Schoenemann <hannes@…>, 11 years ago
removed rField_is_Extension (alg. or trans. ext. ?)
Property mode set to `100644`
File size: 141.2 KB

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

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

Download in other formats: