Context Navigation

source: git/Singular/ipshell.cc @ ba5e9e

spielwiese

Last change on this file since ba5e9e was ba5e9e, checked in by Oleksandr Motsak <motsak@…>, 11 years ago
Changed configure-scripts to generate individual public config files for each package: resources, libpolys, singular (main) fix: sources should include correct corresponding config headers.
Property mode set to `100644`
File size: 141.2 KB

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

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

Download in other formats: