Context Navigation

source: git/Singular/ipshell.cc @ 9d864a

spielwiese

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

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

Download in other formats: