Context Navigation

source: git/Singular/ipshell.cc @ 8b9bbe

fieker-DuValspielwiese

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

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

Download in other formats: