Context Navigation

source: git/Singular/ipshell.cc @ b3594cb

spielwiese

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

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

Download in other formats: