Context Navigation

source: git/Singular/ipshell.cc @ a78130e

fieker-DuValspielwiese

Last change on this file since a78130e was 7976e12, checked in by Hans Schoenemann <hannes@…>, 4 years ago
error message improved (rCompose)
Property mode set to `100644`
File size: 162.6 KB

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

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

Download in other formats: