Context Navigation

source: git/Singular/ipshell.cc @ 90adf83

spielwiese

Last change on this file since 90adf83 was 90adf83, checked in by Hans Schoenemann <hannes@…>, 5 years ago
fix: rComposeOrder
Property mode set to `100644`
File size: 162.3 KB

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

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

Download in other formats: