Context Navigation

derham.lib @ 0e8a5a

spielwiese

Last change on this file since 0e8a5a was 0e8a5a, checked in by Hans Schoenemann <hannes@…>, 11 years ago
new version of derham.lib
Property mode set to `100644`
File size: 228.7 KB

Line
1	///////////////////////////////////////////////////////////////////////////////
2	version="";
3	category="Noncommutative";
4	info="
5	LIBRARY: derham.lib Computation of deRham cohomology
6	AUTHORS: Cornelia Rottner, rottner@mathematik.uni-kl.de
7	OVERVIEW:
8	PROCEDURES:
9
10	";
11
12
13	LIB "nctools.lib";
14	LIB "matrix.lib";
15	LIB "qhmoduli.lib";
16	LIB "general.lib";
17	LIB "dmod.lib";
18	LIB "bfun.lib";
19	LIB "dmodapp.lib";
20	LIB "poly.lib";
21
22	/////////////////////////////////////////////////////////////////////////////
23
24	static proc divdr(matrix m, matrix n)
25	{
26	m=transpose(m);
27	n=transpose(n);
28	matrix con=concat(m,n);
29	matrix s=syz(con);
30	s=submat(s,1..ncols(m),1..ncols(s));
31	s=transpose(compress(s));
32	return(s);
33	}
34
35	/////////////////////////////////////////////////////////////////////////////
36
37
38	static proc matrixlift(matrix M, matrix N)
39	{
40	// option(noreturnSB);
41	matrix l=transpose(lift(transpose(M),transpose(N)));
42	return(l);
43	}
44
45	///////////////////////////////////////////////////////////////////////////////
46
47	proc shortexactpieces(list #)
48	{
49	matrix Bnew= divdr(#[2],#[3]);
50	matrix Bold=Bnew;
51	matrix Z=divdr(Bnew,#[1]);
52	list bzh; list zcb;
53	bzh=list(list(),list(),Z,unitmat(ncols(Z)),Z);
54	zcb=(Z, Bnew, #[1], unitmat(ncols(#[1])), Bnew);
55	list sep;
56	sep[1]=(list(bzh,zcb));
57	int i;
58	list out;
59	for (i=3; i<=size(#)-2; i=i+2)
60	{
61	out=bzhzcb(Bold, #[i-1] , #[i], #[i+1], #[i+2]);
62	sep[size(sep)+1]=out[1];
63	Bold=out[2];
64	}
65	bzh=(divdr(#[size(#)-2], #[size(#)-1]),#[size(#)-2], #[size(#)-1],unitmat(ncols(#[size(#)-1])),transpose(concat(transpose(#[size(#)-2]),transpose(#[size(#)-1]))));
66	zcb=(#[size(#)-1], unitmat(ncols(#[size(#)-1])), #[size(#)-1],list(),list());
67	sep[size(sep)+1]=list(bzh,zcb);
68	return(sep);
69	}
70
71	////////////////////////////////////////////////////////////////////////////////////////
72
73	static proc bzhzcb (matrix Bold, matrix f0, matrix C1, matrix f1,matrix C2)
74	{
75	matrix Bnew=divdr(f1,C2);
76	matrix Z= divdr(Bnew,C1);
77	matrix lift1= matrixlift(Bnew,f0);
78	list bzh=(Bold, lift1, Z, unitmat(ncols(Z)), transpose(concat(transpose(lift1),transpose(Z))));
79	list zcb=(Z, Bnew, C1, unitmat(ncols(C1)),Bnew);
80	list out=(list(bzh, zcb), Bnew);
81	return(out);
82	}
83
84	//////////////////////////////////////////////////////////////////////////////////////
85
86	proc VdstrictGB (matrix M, int d ,list #);
87	"USAGE:VdstrictGB(M,d[,v]); M a matrix, d an integer, v an optional intvec(shift vector)
88	RETURN:matrix M; the rows of M foem a Vd-strict Groebner basis for imM
89	ASSUME:1<=d<=nvars(basering)/2; size(v)=ncols(M)
90	"
91	{
92	if (M==matrix(0,nrows(M),ncols(M)))
93	{
94	return (matrix(0,1,ncols(M)));
95	}
96	def W =basering;
97	int ncM=ncols(M);
98	list Data=ringlist(W);
99	Data[2]=list("nhv")+Data[2];
100	Data[3][3]=Data[3][1];
101	Data[3][1]=Data[3][2];
102	Data[3][2]=list("dp",intvec(1));
103	matrix re[size(Data[2])][size(Data[2])]=UpOneMatrix(size(Data[2]));
104	Data[5]=re;
105	int k; int l;
106	Data[6]=transpose(concat(matrix(0,1,1),transpose(concat(matrix(0,1,1),Data[6]))));
107	def Whom=ring(Data);
108	setring Whom;
109	matrix Mnew=imap(W,M);
110	intvec v;
111	if (size(#)!=0)
112	{
113	v=#[1];
114	}
115	if (size(v) < ncM)
116	{
117	v=v,0:(ncM-size(v));
118	}
119	Mnew=homogenize(Mnew, d, v);
120	Mnew=transpose(Mnew);
121	Mnew=std(Mnew);
122	Mnew=subst(Mnew,nhv,1);
123	Mnew=transpose(Mnew);
124	setring W;
125	M=imap(Whom,Mnew);
126	return(M);
127	}
128
129	////////////////////////////////////////////////////////////////////////////////////
130
131	static proc Vdnormalform(matrix F, matrix M, int d, intvec v)
132	{
133	def W =basering;
134	int c=ncols(M);
135	F=submat(F,intvec(1..nrows(F)),intvec(1..c));
136	list Data=ringlist(W);
137	Data[2]=list("nhv")+Data[2];
138	Data[3][3]=Data[3][1];
139	Data[3][1]=Data[3][2];
140	Data[3][2]=list("dp",intvec(1));
141	matrix re[size(Data[2])][size(Data[2])]=UpOneMatrix(size(Data[2]));
142	Data[5]=re;
143	int k;
144	int l;
145	matrix rep[size(Data[2])][size(Data[2])];
146	for (l=size(Data[2])-1;l>=1; l--)
147	{
148	for (k=l-1; k>=1;k--)
149	{
150	rep[k+1,l+1]=Data[6][k,l];
151	}
152	}
153	Data[6]=rep;
154	def Whom=ring(Data);
155	setring Whom;
156	matrix Mnew=imap(W,M);
157	Mnew=(homogenize(Mnew, d, v));//doppelte Berechung unnötig->muss noch geändert werden!!!
158	matrix Fnew=imap(W,F);
159	matrix Fb;
160	for (l=1; l<=nrows(Fnew); l++)
161	{
162	Fb=homogenize(submat(Fnew,l,intvec(1..ncols(Fnew))),d,v);
163	Fb=transpose(reduce(transpose(Fb),std(transpose(Mnew))));// doppelte Berechnung unnötig, unterdrückt aber Fehler meldung
164	for (k=1; k<=ncols(Fnew);k++)
165	{
166	Fnew[l,k]=Fb[1,k];
167	}
168	}
169	Fnew=subst(Fnew,nhv,1);
170	setring W;
171	F=imap(Whom,Fnew);
172	return(F);
173	}
174
175
176	///////////////////////////////////////////////////////////////////////////////
177
178	static proc homogenize (matrix M, int d, intvec v)
179	{
180	int l; poly f; int s; int i; intvec vnm;int kmin; list findmin;
181	int n=(nvars(basering)-1) div 2;
182	list rempoly;
183	list remk;
184	list rem1;
185	list rem2;
186	for (int k=1; k<=nrows(M); k++) //man könnte auch paralell immer weiter homogenisieren, d.h. immer ein enues Minimum finden und das dann machen
187	{
188	for (l=1; l<=ncols (M); l++)
189	{
190	f=M[k,l];
191	s=size(f);
192	for (i=1; i<=s; i++)
193	{
194	vnm=leadexp(f);
195	vnm=vnm[n+2..n+d+1]-vnm[2..d+1];
196	kmin=sum(vnm)+v[l];
197	rem1[size(rem1)+1]=lead(f);
198	rem2[size(rem2)+1]=kmin;
199	findmin=insert(findmin,kmin);
200	f=f-lead(f);
201	}
202	rempoly[l]=rem1;
203	remk[l]=rem2;
204	rem1=list();
205	rem2=list();
206	}
207	if (size(findmin)!=0)
208	{
209	kmin=Min(findmin);
210	}
211	for (l=1; l<=ncols(M); l++)
212	{
213	if (M[k,l]!=0)
214	{
215	M[k,l]=0;
216	for (i=1; i<=size(rempoly[l]);i++)
217	{
218	M[k,l]=M[k,l]+nhv^(remk[l][i]-kmin)*rempoly[l][i];
219	}
220	}
221	}
222	rempoly=list();
223	remk=list();
224	findmin=list();
225	}
226	return(M);
227	}
228
229
230	//////////////////////////////////////////////////////////////////////////////////////
231
232	static proc soldr (matrix M, matrix N)
233	{
234	int n=nrows(M);
235	int q=ncols(M);
236	matrix S=concat(transpose(M),transpose(N));
237	def W=basering;
238	list Data=ringlist(W);
239	list Save=Data[3];
240	Data[3]=list(list("c",0),list("dp",intvec(1..nvars(W))));
241	def Wmod=ring(Data);
242	setring Wmod;
243	matrix Smod=imap(W,S);
244	matrix E[q][1];
245	matrix Smod2;
246	matrix Smodnew;
247	option(returnSB);
248	int i; int j;
249	for (i=1;i<=q;i++)
250	{
251	E[i,1]=1;
252	Smod2=concat(E,Smod);
253	print (Smod2);
254	Smod2=syz(Smod2);
255	E[i,1]=0;
256	for (j=1;j<=ncols(Smod2);j++)
257	{
258	if (Smod2[1,j]==1)
259	{
260	Smodnew=concat(Smodnew,(-1)*(submat(Smod2,intvec(2..n+1),j)));
261	break;
262	}
263	}
264	}
265	Smodnew=transpose(submat(Smodnew,intvec(1..n),intvec(2..q+1)));
266	setring W;
267	matrix Snew=imap(Wmod,Smodnew);
268	return (Snew);
269	}
270
271
272	/////////////////////////////////////////////////////////////////////////////
273
274	proc toVdstrictsequence (list C,int n, intvec v)
275
276	{
277	matrix J_C=VdstrictGB(C[5],n,list(v));
278	matrix J_A=C[1];
279	matrix f_CB=C[4];
280	matrix f_ACB=transpose(concat(transpose(C[2]),transpose(f_CB)));
281	matrix J_AC=divdr(f_ACB,C[3]);
282	matrix P=matrixlift(J_AC * prodr(ncols(C[1]),ncols(C[5])) ,J_C);
283	list storePi;
284	matrix Pi[1][ncols(J_AC)];
285	int i;int j;
286	for (i=1; i<=nrows(J_C); i++)
287	{
288	for (j=1; j<=nrows(J_AC);j++)
289	{
290	Pi=Pi+P[i,j]*submat(J_AC,j,intvec(1..ncols(J_AC)));
291	}
292	storePi[i]=Pi;
293	Pi=0;
294	}
295	intvec m_a;
296	list findMin;
297	int comMin;
298	for (i=1; i<=ncols(J_A); i++)
299	{
300	for (j=1; j<=size(storePi);j++)
301	{
302	if (storePi[j][1,i]!=0)
303	{
304	comMin=Vddeg(storePi[j]*prodr(ncols(J_A),ncols(C[5])),n,v)-Vddeg(storePi[j][1,i],n,intvec(0));
305	findMin[size(findMin)+1]=comMin;
306	}
307	}
308	if (size(findMin)!=0)
309	{
310	m_a[i]=Min(findMin);
311	findMin=list();
312	}
313	else
314	{
315	m_a[i]=0;
316	}
317	}
318	matrix zero[ncols(J_A)][ncols(J_C)];
319
320	matrix g_AB=concat(unitmat(ncols(J_A)),zero);
321	matrix g_BC= transpose(concat(transpose(zero),transpose(unitmat(ncols(J_C)))));
322	intvec m_b=m_a,v;
323
324	J_A=VdstrictGB(J_A,n,m_a);
325	J_AC=transpose(storePi[1]);
326	for (i=2; i<= size(storePi); i++)
327	{
328	J_AC=concat(J_AC, transpose(storePi[i]));
329	}
330	J_AC=transpose(concat(transpose(matrix(J_A,nrows(J_A),nrows(J_AC))),J_AC));
331
332	list Vdstrict=(list(J_A),list(g_AB),list(J_AC),list(g_BC),list(J_C),list(m_a),list(m_b),list(v));
333	return (Vdstrict);
334	}
335
336
337	/////////////////////////////////////////////////////////////////////////
338
339	static proc prodr (int k, int l)
340	{
341	if (k==0)
342	{
343	matrix P=unitmat(l);
344	return (P);
345	}
346	matrix O[l][k];
347	matrix P=transpose(concat(O,unitmat(l)));
348	return (P);
349	}
350
351	/////////////////////////////////////////////////////////////////////////
352
353	proc Vddeg(matrix M, int d, intvec v, list #)//Aternative: in WHom Leadmonom ausrechnen!!
354	"USAGE: Vddeg(M,d,v); M 1xr-matrix, d int, v intvec of size r
355	RETURN:int; the Vd-degree of M
356	"
357	{
358	int i;int j;
359	int n=nvars(basering) div 2;
360	intvec e;
361	int etoint;
362	list findmax;
363	int c=ncols(M);
364	poly l;
365	list positionpoly;
366	list positionVd;
367	for (i=1; i<=c; i++)
368	{
369	positionpoly[i]=list();
370	positionVd[i]=list();
371	while (M[1,i]!=0)
372	{
373	l=lead(M[1,i]);
374	positionpoly[i][size(positionpoly[i])+1]=l;
375	e=leadexp(l);
376	e=-e[1..d]+e[n+1..n+d];
377	e=sum(e)+v[i];
378	etoint=e[1];
379	positionVd[i][size(positionVd[i])+1]=etoint;
380	findmax[size(findmax)+1]=etoint;
381	M[1,i]=M[1,i]-l;
382	}
383	}
384	if (size(findmax)!=0)
385	{
386	int maxVd=Max(findmax);
387	if (size(#)==0)
388	{
389	return (maxVd);
390	}
391	}
392	else // M is 0-modul
393	{
394	return(int(0));
395	}
396	l=0;
397	for (i=c; i>=1; i--)
398	{
399	for (j=1; j<=size(positionVd[i]); j++)
400	{
401	if (positionVd[i][j]==maxVd)
402	{
403	l=l+positionpoly[i][j];
404	}
405	}
406	if (l!=0)
407	{
408	return (list(l,i));
409	}
410	}
411
412	}
413
414
415	///////////////////////////////////////////////////////////////////////////////
416
417	proc toVdstrictsequences (list L,int d, intvec v)
418	"USAGE: toVdstrictsequences(L,d,v); L list, d int, v intvec, L contains two lists of short exact sequences(D,f_DA,A,f_AF,F) and (A,f_AB,B,f_BC,C), v is a shift vector on the range of C
419	RETURN: list of two lists; each lists contains Vd-strict exact sequences with corresponding shift vectors
420	"
421	{
422	matrix J_F=L[1][5];
423	matrix J_D=L[1][1];
424	matrix f_FA=L[1][4];
425	matrix f_DFA=transpose(concat(transpose(L[1][2]),transpose(f_FA)));
426	matrix J_DF=divdr(f_DFA,L[1][3]);
427	matrix J_C=L[2][5];
428	matrix f_CB=L[2][4];
429	matrix f_DFCB=transpose(concat(transpose(f_DFA*L[2][2]),transpose(f_CB)));
430	matrix J_DFC=divdr(f_DFCB,L[2][3]);
431	matrix P=matrixlift(J_DFC*prodr(ncols(J_DF),ncols(L[2][5])),J_C);
432	list storePi;
433	matrix Pi[1][ncols(J_DFC)];
434	int i; int j;
435	for (i=1; i<=nrows(J_C); i++)
436	{
437
438	for (j=1; j<=nrows(J_DFC);j++)
439	{
440	Pi=Pi+P[i,j]*submat(J_DFC,j,intvec(1..ncols(J_DFC)));
441	}
442	storePi[i]=Pi;
443	Pi=0;
444	}
445	intvec m_a;
446	list findMin;
447	list noMin;
448	int comMin;
449	for (i=1; i<=ncols(J_DF); i++)
450	{
451	for (j=1; j<=size(storePi);j++)
452	{
453	if (storePi[j][1,i]!=0)
454	{
455	comMin=Vddeg(storePi[j]*prodr(ncols(J_DF),ncols(J_C)),d,v)-Vddeg(storePi[j][1,i],d,intvec(0));
456	findMin[size(findMin)+1]=comMin;
457	}
458	}
459	if (size(findMin)!=0)
460	{
461	m_a[i]=Min(findMin);
462	findMin=list();
463	noMin[i]=0;
464	}
465	else
466	{
467	noMin[i]=1;
468	}
469	}
470	if (size(m_a) < ncols(J_DF))
471	{
472	m_a[ncols(J_DF)]=0;
473	}
474	intvec m_f=m_a[ncols(J_D)+1..size(m_a)];
475	J_F=VdstrictGB(J_F,d,m_f);
476	P=matrixlift(J_DF * prodr(ncols(L[1][1]),ncols(L[1][5])) ,J_F);// selbe Prinzip wie oben--> evtl auslagern
477	list storePinew;
478	matrix Pidf[1][ncols(J_DF)];
479	for (i=1; i<=nrows(J_F); i++)
480	{
481	for (j=1; j<=nrows(J_DF);j++)
482	{
483	Pidf=Pidf+P[i,j]*submat(J_DF,j,intvec(1..ncols(J_DF)));
484	}
485	storePinew[i]=Pidf;
486	Pidf=0;
487	}
488	intvec m_d;
489	for (i=1; i<=ncols(J_D); i++)
490	{
491	for (j=1; j<=size(storePinew);j++)
492	{
493	if (storePinew[j][1,i]!=0)
494	{
495	comMin=Vddeg(storePinew[j]*prodr(ncols(J_D),ncols(L[1][5])),d,m_f)-Vddeg(storePinew[j][1,i],d,intvec(0));
496	findMin[size(findMin)+1]=comMin;
497	}
498	}
499	if (size(findMin)!=0)
500	{
501	if (noMin[i]==0)
502	{
503	m_d[i]=Min(insert(findMin,m_a[i]));
504	m_a[i]=m_d[i];
505	}
506	else
507	{
508	m_d[i]=Min(findMin);
509	m_a[i]=m_d[i];
510	}
511	}
512	else
513	{
514	m_d[i]=m_a[i];
515	}
516	findMin=list();
517	}
518	J_D=VdstrictGB(J_D,d,m_d);
519	J_DF=transpose(storePinew[1]);
520	for (i=2; i<=nrows(J_F); i++)
521	{
522	J_DF=concat(J_DF,transpose(storePinew[i]));
523	}
524	J_DF=transpose(concat(transpose(matrix(J_D,nrows(J_D),nrows(J_DF))),J_DF));
525	J_DFC=transpose(storePi[1]);
526	for (i=2; i<=nrows(J_C); i++)
527	{
528	J_DFC=concat(J_DFC,transpose(storePi[i]));
529	}
530	J_DFC=transpose(concat(transpose(matrix(J_DF,nrows(J_DF),nrows(J_DFC))),J_DFC));
531	intvec m_b=m_a,v;
532	matrix zero[ncols(J_D)][ncols(J_F)];
533	matrix g_DA=concat(unitmat(ncols(J_D)),zero);
534	matrix g_AF=transpose(concat(transpose(zero),unitmat(ncols(J_F))));
535	matrix zero1[ncols(J_DF)][ncols(J_C)];
536	matrix g_AB=concat(unitmat(ncols(J_DF)),zero1);
537	matrix g_BC=transpose(concat(transpose(zero1),unitmat(ncols(J_C))));
538	list out=(list(list(J_D),list(g_DA),list(J_DF),list(g_AF),list(J_F),list(m_d),list(m_a),list(m_f)),list(list(J_DF),list(g_AB),list(J_DFC),list(g_BC),list(J_C),list(m_a),list(m_b),list(v)));
539	return(out),
540	}
541
542	///////////////////////////////////////////////////////////////////////////////////////////
543
544	proc shortexactpiecestoVdstrict(list C, int d,list #)
545
546	{
547
548	int s =size(C);
549	if (size(#)==0)
550	{
551	intvec v=0:ncols(C[s][1][5]);
552	}
553	else
554	{
555	intvec v=#[1];
556	}
557	list out;
558	out[s]=list(toVdstrictsequence(C[s][1],d,v));
559	out[s][2]=list(list(out[s][1][3][1]),list(unitmat(ncols(out[s][1][3][1]))),list(out[s][1][3][1]),list(list()),list(list()));
560	out[s][2][6]=list(out[s][1][7][1]);
561	out[s][2][7]=list(out[s][2][6][1]);
562	out[s][2][8]=list(list());
563	int i;
564	for (i=s-1; i>=2; i--)
565	{
566	C[i][2][5]=out[i+1][1][1][1];
567	out[i]=toVdstrictsequences(C[i],d,out[i+1][1][6][1]);
568	}
569	out[1]=list(list());
570	out[1][2]=toVdstrictsequence(C[1][2],d,out[2][1][6][1]);
571	out[1][1][3]=list(out[1][2][1][1]);
572	out[1][1][5]=list(out[1][2][1][1]);
573	out[1][1][4]=list(unitmat(ncols(out[1][1][3][1])));
574	out[1][1][7]=list(out[1][2][6][1]);
575	out[1][1][8]=list(out[1][2][6][1]);
576	out[1][1][1]=list(list());
577	out[1][1][2]=list(list());
578	out[1][1][6]=list(list());
579	list Hi;
580	for (i=1; i<=size(out); i++)
581	{
582	Hi[i]=list(out[i][1][5][1],out[i][1][8][1]);
583	}
584	list outall;
585	outall[1]=out;
586	print (out);
587	outall[2]=Hi;
588	return(outall);
589
590
591	}
592
593	///////////////////////////////////////////////////////////////////////////////////////////
594
595	proc toVdstrict2x3complex(list L, int d, list #)
596	{
597	matrix rem; int i; int j;
598	list J_A=list(list());
599	list J_B=list(list());
600	list J_C=list(list());
601	list g_AB=list(list());
602	list g_BC=list(list());
603	list n_a=list(list());
604	list n_b=list(list());
605	list n_c=list(list());
606	intvec n_b1;
607	if (size(L[5])!=0)
608	{
609	intvec n_c1;
610	for (i=1; i<=nrows(L[5]); i++)
611	{
612	rem=submat(L[5],i,intvec(1..ncols(L[5])));
613	n_c1[i]=Vddeg(rem,d, L[8]);
614	}
615	n_c[1]=n_c1;
616	J_C[1]=transpose(syz(transpose(L[5])));
617	if (J_C[1]!=matrix(0,nrows(J_C[1]),ncols(J_C[1])))
618	{
619	J_C[1]=VdstrictGB(J_C[1],d,n_c1);
620	if (size(#[2])!=0)
621	{
622	n_a[1]=#[2];
623	n_b1=n_a[1],n_c[1];
624	n_b[1]=n_b1;
625	matrix zero[nrows(L[1])][nrows(L[5])];
626	g_AB=concat(unitmat(nrows(L[1])),matrix(0,nrows(L[1]),nrows(L[5])));
627	if (size(#[1])!=0)
628	{
629	J_A=#[1];
630	J_B=transpose(matrix(syz(transpose(L[3]))));
631	matrix P=matrixlift(J_B[1] * prodr(nrows(L[1]),nrows(L[5])) ,J_C[1]);
632
633	matrix Pi[1][ncols(J_B[1])];
634	matrix Picombined;
635	for (i=1; i<=nrows(J_C[1]); i++)
636	{
637	for (j=1; j<=nrows(J_B[1]);j++)
638	{
639	Pi=Pi+P[i,j]*submat(J_B[1],j,intvec(1..ncols(J_B[1])));
640
641	}
642	if (i==1)
643	{
644	Picombined=transpose(Pi);
645	}
646	else
647	{
648	Picombined=concat(Picombined,transpose(Pi));
649	}
650	Pi=0;
651	}
652	Picombined=transpose(Picombined);
653	Picombined=concat(Vdnormalform(Picombined,J_A[1],d,n_a[1]),submat(Picombined,intvec(1..nrows(Picombined)),intvec((ncols(J_A[1])+1)..ncols(Picombined))));
654	J_B[1]=transpose(concat(transpose(matrix(J_A[1],nrows(J_A[1]),ncols(J_B[1]))),transpose(Picombined)));
655	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
656	}
657	else
658	{
659	J_B[1]=concat(matrix(0,nrows(J_C[1]),nrows(L[3])-nrows(L[5])),J_C[1]);
660	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
661	}
662	}
663	else
664	{
665	n_b=n_c[1];
666	J_B[1]=J_C[1];
667	g_BC=unitmat(ncols(J_C[1]));
668	}
669	}
670	else
671	{
672	J_C=list(list());
673	if (size(#[2])!=0)
674	{
675	matrix zero[nrows(L[1])][nrows(L[5])];
676	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
677	n_a[1]=#[2];
678	n_b1=n_a[1],n_c[1];
679	n_b[1]=n_b1;
680	g_AB=concat(unitmat(nrows(L[1])),matrix(0,nrows(L[1]),nrows(L[5])));;
681
682	if (size(#[1])!=0)
683	{
684	J_A=#[1];
685	J_B=concat(J_A[1],matrix(0,nrows(J_A[1]),nrows(L[3])-nrows(L[1])));
686	}
687	}
688	else
689	{
690	n_b=n_c[1];
691	g_BC=unitmat(ncols(L[5]));
692	}
693
694	}
695	}
696	else
697	{
698	if (size(#[2])!=0)
699	{
700	n_a[1]=#[2];
701	n_b=n_a[1];
702	g_AB=unitmat(size(n_b[1]));
703	if (size(#[1])!=0)
704	{
705	J_A=#[1];
706	J_B[1]=J_A[1];
707	}
708	}
709	}
710	list out=(J_A[1],g_AB[1],J_B[1],g_BC[1],J_C[1],n_a[1],n_b[1],n_c[1]);
711	return (out);
712	}
713
714
715	//////////////////////////////////////////////////////////////////////////
716
717	proc Vdstrictdoublecompexes(list L, int d)
718	{
719	int i; int k; int c; int j;
720	intvec n_b;
721	matrix rem;
722	matrix J_B;
723	list store;
724	int t=size(L)+nvars(basering) div 2-2;
725	for (k=1; k<=(size(L)+nvars(basering) div 2-3); k++)//
726	{
727	L[1][1][1][k+1]=list();
728	L[1][1][2][k+1]=list();
729	L[1][1][6][k+1]=list();
730	if (size(L[1][1][3][k])!=0)
731	{
732	for (i=1; i<=nrows(L[1][1][3][k]); i++)
733	{
734	rem=submat(L[1][1][3][k],i,(1..ncols(L[1][1][3][k])));
735	n_b[i]=Vddeg(rem,d,L[1][1][7][k]);
736	}
737	J_B=transpose(syz(transpose(L[1][1][3][k])));
738	L[1][1][7][k+1]=n_b;
739	L[1][1][8][k+1]=n_b;
740	L[1][1][4][k+1]=unitmat(nrows(L[1][1][3][k]));
741	if (J_B!=matrix(0,nrows(J_B),ncols(J_B)))
742	{
743	J_B=VdstrictGB(J_B,d,n_b);
744	L[1][1][3][k+1]=J_B;
745	L[1][1][5][k+1]=J_B;
746	}
747	else
748	{
749	L[1][1][3][k+1]=list();
750	L[1][1][5][k+1]=list();
751	}
752	n_b=0;
753	}
754	else
755	{
756	L[1][1][3][k+1]=list();
757	L[1][1][5][k+1]=list();
758	L[1][1][7][k+1]=list();
759	L[1][1][8][k+1]=list();
760	L[1][1][4][k+1]=list();
761	}
762	for (i=1; i<size(L); i++)
763	{
764	store=toVdstrict2x3complex(list(L[i][2][1][k],L[i][2][2][k],L[i][2][3][k],L[i][2][4][k],L[i][2][5][k],L[i][2][6][k],L[i][2][7][k],L[i][2][8][k]),d,L[i][1][3][k+1],L[i][1][7][k+1]);
765	for (j=1; j<=8; j++)
766	{
767	L[i][2][j][k+1]=store[j];
768	}
769
770	store=toVdstrict2x3complex(list(L[i+1][1][1][k],L[i+1][1][2][k],L[i+1][1][3][k],L[i+1][1][4][k],L[i+1][1][5][k],L[i+1][1][6][k],L[i+1][1][7][k],L[i+1][1][8][k]),d,L[i][2][5][k+1],L[i][2][8][k+1]);
771
772	for (j=1; j<=8; j++)
773	{
774	L[i+1][1][j][k+1]=store[j];
775	}
776	}
777	if (size(L[size(L)][1][7][k+1])!=0)
778	{
779	L[size(L)][2][4][k+1]=list();
780	L[size(L)][2][5][k+1]=list();
781	L[size(L)][2][6][k+1]=L[size(L)][1][7][k+1];
782	L[size(L)][2][7][k+1]=L[size(L)][1][7][k+1];
783	L[size(L)][2][8][k+1]=list();
784	L[size(L)][2][2][k+1]=unitmat(size(L[size(L)][1][7][k+1]));
785
786	if (size(L[size(L)][1][3][k+1])!=0)
787	{
788	L[size(L)][2][1][k+1]=L[size(L)][1][3][k+1];
789	L[size(L)][2][3][k+1]=L[size(L)][1][3][k+1];
790	}
791	else
792	{
793	L[size(L)][2][1][k+1]=list();
794	L[size(L)][2][3][k+1]=list();
795	}
796	}
797	else
798	{
799	for (j=1; j<=8; j++)
800	{
801	L[size(L)][2][j][k+1]=list();
802	}
803	}
804	}
805
806
807	k=t;
808	intvec n_c;
809	intvec vn_b;
810	list N_b;
811	int n;
812	for (i=1; i<=size(L); i++)
813	{
814	for (n=1; n<=2; n++)
815	{
816	if (i==1 and n==1)
817	{
818	L[i][n][6][k+1]=list();
819	}
820	else
821	{
822	if (n==1)
823	{
824	L[i][1][6][k+1]=L[i-1][2][8][k+1];
825	}
826	else
827	{
828	L[i][2][6][k+1]=L[i][1][7][k+1];
829	}
830	}
831	N_b[1]=L[i][n][6][k+1];
832	if (size(L[i][n][5][k])!=0)
833	{
834	for (j=1; j<=nrows(L[i][n][5][k]); j++)
835	{
836	rem=submat(L[i][n][5][k],j,(1..ncols(L[i][n][5][k])));
837	n_c[j]=Vddeg(rem,d,L[i][n][8][k]);
838	}
839	L[i][n][8][k+1]=n_c;
840	}
841	else
842	{
843	L[i][n][8][k+1]=list();
844	}
845	N_b[2]=L[i][n][8][k+1];
846	n_c=0;
847	if (size(N_b[1])!=0)
848	{
849	vn_b=N_b[1];
850	if (size(N_b[2])!=0)
851	{
852	vn_b=vn_b,N_b[2];
853	}
854	L[i][n][7][k+1]=vn_b;
855	}
856	else
857	{
858	if (size(N_b[2])!=0)
859	{
860	L[i][n][7][k+1]=N_b[2];
861	}
862	else
863	{
864	L[i][n][7][k+1]=list();
865	}
866	}
867
868	}
869	}
870	return(L);
871	}
872
873	////////////////////////////////////////////////////////////////////////////
874
875	proc assemblingdoublecomplexes(list L)
876	{
877	list out;
878	int i; int j;int k;int l; int oldj; int newj;
879	for (i=1; i<=size(L); i++)
880	{
881	out[i]=list(list());
882	out[i][1][1]=ncols(L[i][2][3][1]);
883	if (size(L[i][2][5][1])!=0)
884	{
885	out[i][1][4]=prodr(ncols(L[i][2][3][1])-ncols(L[i][2][5][1]),ncols(L[i][2][5][1]));
886	}
887	else
888	{
889	out[i][1][4]=matrix(0,ncols(L[i][2][3][1]),1);
890	}
891
892	oldj=newj;
893	for (j=1; j<=size(L[i][2][3]);j++)
894	{
895	out[i][j][2]=L[i][2][7][j];
896	if (size(L[i][2][3][j])==0)
897	{
898	newj =j;
899	break;
900	}
901	out[i][j+1]=list();
902	out[i][j+1][1]=nrows(L[i][2][3][j]);
903	out[i][j+1][3]=L[i][2][3][j];
904	if (size(L[i][2][5][j])!=0)
905	{
906	out[i][j+1][4]=(-1)^j*prodr(nrows(L[i][2][3][j])-nrows(L[i][2][5][j]),nrows(L[i][2][5][j]));
907	}
908	else
909	{
910	out[i][j+1][4]=matrix(0,nrows(L[i][2][3][j]),1);
911	}
912	if(j==size(L[i][2][3]))
913	{
914	out[i][j+1][2]=L[i][2][7][j+1];
915	newj=j+1;
916	}
917	}
918	if (i>1)
919	{
920	for (k=1; k<=Min(list(oldj,newj)); k++)
921	{
922	out[i-1][k][4]=matrix(out[i-1][k][4],nrows(out[i-1][k][4]),out[i][k][1]);
923	}
924	for (k=newj+1; k<=oldj; k++)
925	{
926	out[i-1][k]=delete(out[i-1][k],4);
927	}
928	}
929	}
930	return (out);
931	}
932
933	//////////////////////////////////////////////////////////////////////////////
934
935	proc totalcomplex(list L);
936	{
937	list out;intvec rem1;intvec v; list remsize; int emp;
938	int i; int j; int c; int d; matrix M; int k; int l;
939	int n=nvars(basering) div 2;
940	list K;
941	for (i=1; i<=n; i++)
942	{
943	K[i]=list();
944	}
945	L=K+L;
946	for (i=1; i<=size(L); i++)
947	{
948	emp=0;
949	if (size(L[i])!=0)
950	{
951	out[3*i-2]=L[i][1][1];
952	v=L[i][1][1];
953	rem1=L[i][1][2];
954	emp=1;
955	}
956	else
957	{
958	out[3*i-2]=0;
959	v=0;
960	}
961
962	for (j=i+1; j<=size(L); j++)
963	{
964	if (size(L[j])>=j-i+1)
965	{
966	out[3i-2]=out[3i-2]+L[j][j-i+1][1];
967	if (emp==0)
968	{
969	rem1=L[j][j-i+1][2];
970	emp=1;
971	}
972	else
973	{
974	rem1=rem1,L[j][j-i+1][2];
975	}
976	v[size(v)+1]=L[j][j-i+1][1];
977	}
978	else
979	{
980	v[size(v)+1]=0;
981	}
982	}
983	out[3*i-1]=rem1;
984	v[size(v)+1]=0;
985	remsize[i]=v;
986	}
987	int o1;
988	int o2;
989	for (i=1; i<=size(L)-1; i++)
990	{
991	o1=1;
992	o2=1;
993	if (size(out[3*i-2])!=0)
994	{
995	o1=out[3*i-2];
996	}
997	if (size(out[3*i+1])!=0)
998	{
999	o2=out[3*i+1];
1000	}
1001	M=matrix(0,o1,o2);
1002	if (size(L[i])!=0)
1003	{
1004	if (size(L[i][1][4])!=0)
1005	{
1006	M=matrix(L[i][1][4],o1,o2);
1007	}
1008	}
1009	c=remsize[i][1];
1010	// d=remsize[i+1][1];
1011	for (j=i+1; j<=size(L); j++)
1012	{
1013	if (remsize[i][j-i+1]!=0)
1014	{
1015	for (k=c+1; k<=c+remsize[i][j-i+1]; k++)
1016	{
1017	for (l=d+1; l<=d+remsize[i+1][j-i];l++)
1018	{
1019	M[k,l]=L[j][j-i+1][3][(k-c),(l-d)];
1020	}
1021	}
1022	d=d+remsize[i+1][j-i];
1023	if (remsize[i+1][j-i+1]!=0)
1024	{
1025	for (k=c+1; k<=c+remsize[i][j-i+1]; k++)
1026	{
1027	for (l=d+1; l<=d+remsize[i+1][j-i+1];l++)
1028	{
1029	M[k,l]=L[j][j-i+1][4][k-c,l-d];
1030	}
1031	}
1032	c=c+remsize[i][j-i+1];
1033	}
1034	}
1035	else
1036	{
1037	d=d+remsize[i+1][j-i];
1038	}
1039	}
1040	out[3*i]=M;
1041	d=0; c=0;
1042	}
1043	out[3size(L)]=matrix(0,out[3size(L)-2],1);
1044	return (out);
1045	}
1046
1047	/////////////////////////////////////////////////////////////////////////////////////
1048
1049	proc toVdstrictfreecomplex(list L,list #)
1050	{
1051	def B=basering;
1052	int n=nvars(B) div 2+2;
1053	int d=nvars(B) div 2;
1054	intvec v;
1055	list out;list outall;
1056	int i;int j;
1057	matrix mem;
1058	int k;
1059	if (size(#)!=0)
1060	{
1061	for (i=1; i<=size(#); i++)
1062	{
1063	if (typeof(#[i])==intvec)
1064	{
1065	v=#[i];
1066	}
1067	if (typeof(#[i])==int)
1068	{
1069	d=#[i];
1070	}
1071	}
1072	}
1073	if (size(L)==2)
1074	{
1075	v=(0:ncols(L[1]));
1076	out[3*n-1]=v;
1077	out[3*n-2]=ncols(L[1]);
1078	out[3*n]=L[2];
1079	out[3*n-3]=VdstrictGB(L[1],d,v);
1080	for (i=n-1; i>=1; i--)
1081	{
1082	out[3i-2]=nrows(out[3i]);
1083	v=0;
1084	for (j=1; j<=out[3*i-2]; j++)
1085	{
1086	mem=submat(out[3i],j,intvec(1..ncols(out[3i])));
1087	v[j]=Vddeg(mem,d, out[3*i+2]);
1088	}
1089	out[3*i-1]=v;
1090	if (i!=1)
1091	{
1092	out[3i-3]=transpose(syz(transpose(out[3i])));
1093	if (out[3i-3]!=matrix(0,nrows(out[3i-3]),ncols(out[3*i-3])))
1094	{
1095	out[3i-3]=VdstrictGB(out[3i-3],d,out[3*i-1]);
1096	}
1097	else
1098	{
1099	out[3i-3]=matrix(0,1,ncols(out[3i-3]));
1100	out[3*i-4]=intvec(0);
1101	out[3*i-5]=int(0);
1102	for (j=i-2; j>=1; j--)
1103	{
1104	out[3*j]=matrix(0,1,1);
1105	out[3*j-1]=intvec(0);
1106	out[3*j-2]=int(0);
1107	}
1108	break;
1109	}
1110	}
1111	}
1112	outall[1]=out;
1113	outall[2]=list(list(out[3n-3],out[3n-1]));
1114	return(outall);
1115	}
1116	out=shortexactpieces(L);
1117	list rem;
1118	if (v!=intvec(0:size(v)))
1119	{
1120	rem=shortexactpiecestoVdstrict(out,d,v);
1121	}
1122	else
1123	{
1124	rem=shortexactpiecestoVdstrict(out,d);
1125	}
1126	out=Vdstrictdoublecompexes(rem[1],d);
1127	out=assemblingdoublecomplexes(out);
1128	out=totalcomplex(out);
1129	outall[1]=out;
1130	outall[2]=rem[2];
1131	return (outall);
1132	}
1133
1134	////////////////////////////////////////////////////////////////////////////////
1135
1136	proc derhamcohomology(list L)
1137	{
1138	def R=basering;
1139	int n=nvars(R);int le=2*size(L)+n-1;
1140	def W=makeWeyl(n);
1141	setring W;
1142	list man=ringlist(W);
1143	if (n==1)
1144	{
1145	man[2][1]="x(1)";
1146	man[2][2]="D(1)";
1147	def Wi=ring(man);
1148	setring Wi;
1149	kill W;
1150	def W=Wi;
1151	setring W;
1152	list man=ringlist(W);
1153	}
1154	man[2][size(man[2])+1]="s";;
1155	man[3][3]=man[3][2];
1156	man[3][2]=list("dp",intvec(1));
1157	matrix N=UpOneMatrix(size(man[2]));
1158	man[5]=N;
1159	matrix M[1][1];
1160	man[6]=transpose(concat(transpose(concat(man[6],M)),M));
1161	def Ws=ring(man); setring R; int r=size(L); int i; int j;int k; int l; int count; list Fi; list subsets; list maxnum; list bernsteinpolys; list annideals; list minint; list diffmaps;
1162	for (i=1; i<=r; i++)
1163	{
1164	Fi[i]=list(); bernsteinpolys[i]=list(); annideals[i]=list(); subsets[i]=list();
1165	maxnum[i]=list();
1166	Fi[1][i]=L[i];
1167	maxnum[1][i]=i;
1168	subsets[1][i]=intvec(i);
1169	}
1170	intvec v;
1171	for (i=2; i<=r; i++)
1172	{
1173	count=1;
1174	for (j=1; j<=size(Fi[i-1]);j++)
1175	{
1176	for (k=maxnum[i-1][j]+1; k<=r; k++)
1177	{
1178	maxnum[i][count]=k;
1179	v=subsets[i-1][j],k;
1180	subsets[i][count]=v;
1181	Fi[i][count]=lcm(Fi[i-1][j],L[k]);/////////
1182	count=count+1;
1183	}
1184	}
1185	}
1186	for (i=1; i<=r; i++)
1187	{
1188	for (j=1; j<=size(Fi[i]); j++)
1189	{
1190	bernsteinpolys[i][j]=bfct(Fi[i][j])[1];
1191	for (k=1; k<=ncols(bernsteinpolys[i][j]); k++)
1192	{
1193	if (isInt(number(bernsteinpolys[i][j][k]))==1)
1194	{
1195	minint[size(minint)+1]=int(bernsteinpolys[i][j][k]);
1196	}
1197	}
1198	def D=Sannfs(Fi[i][j]);
1199	setring Ws;
1200	annideals[i][j]=fetch(D,LD);
1201	kill D;
1202	setring R;
1203	}
1204	}
1205	int m=Min(minint);
1206	list zw;
1207	for (i=1; i<r; i++)
1208	{
1209	diffmaps[i]=matrix(0,size(subsets[i]),size(subsets[i+1]));
1210	for (j=1; j<=size(subsets[i]); j++)
1211	{
1212	for (k=1; k<=size(subsets[i+1]); k++)
1213	{
1214	zw=mysubset(subsets[i][j],subsets[i+1][k]);
1215	diffmaps[i][j,k]=zw[2]*(L[zw[1]]/gcd(L[zw[1]],Fi[i][j]))^(-m);
1216	}
1217	}
1218	}
1219	diffmaps[r]=matrix(0,1,1);
1220	setring Ws;
1221	for (i=1; i<=r; i++)
1222	{
1223	for (j=1; j<=size(annideals[i]); j++)
1224	{
1225	annideals[i][j]=subst(annideals[i][j],s,m);
1226	}
1227	}
1228	setring W;
1229	list annideals=imap(Ws,annideals);
1230	list diffmaps=fetch(R,diffmaps);
1231	list fortoVdstrict;
1232	ideal IFourier=var(n+1);
1233	for (i=2;i<=n;i++)
1234	{
1235	IFourier=IFourier,var(n+i);
1236	}
1237	for (i=1; i<=n;i++)
1238	{
1239	IFourier=IFourier,-var(i);
1240	}
1241	map cFourier=W,IFourier;
1242	matrix sup;
1243	for (i=1; i<=r; i++)
1244	{
1245	sup=matrix(annideals[i][1]);
1246	fortoVdstrict[2*i-1]=transpose(cFourier(sup));
1247	for (j=2; j<=size(annideals[i]); j++)
1248	{
1249	sup=matrix(annideals[i][j]);
1250	fortoVdstrict[2i-1]=dsum(fortoVdstrict[2i-1],transpose(cFourier(sup)));
1251	}
1252	sup=diffmaps[i];
1253	fortoVdstrict[2*i]=cFourier(sup);
1254	}
1255	list rem=toVdstrictfreecomplex(fortoVdstrict);
1256	list newcomplex=rem[1];
1257	list minmaxk=globalbfun(rem[2]);
1258	if (size(minmaxk)==0)
1259	{
1260	return (0);
1261	}
1262	list truncatedcomplex; list shorten; list upto;
1263	for (i=1; i<=size(newcomplex) div 3; i++)
1264	{
1265	shorten[3*i-1]=list();
1266	for (j=1; j<=size(newcomplex[3*i-1]); j++)
1267	{
1268	shorten[3i-1][j]=list(minmaxk[1]-newcomplex[3i-1][j]+1,minmaxk[2]-newcomplex[3*i-1][j]+1);
1269	upto[size(upto)+1]=shorten[3*i-1][j][2];
1270	if (shorten[3*i-1][j][2]<=0)
1271	{
1272	shorten[3*i-1][j]=list();
1273	}
1274	else
1275	{
1276	if (shorten[3*i-1][j][1]<=0)
1277	{
1278	shorten[3*i-1][j][1]=1;
1279	}
1280	}
1281	}
1282	}
1283	int iupto=Max(upto);
1284	if (iupto<=0)
1285	{
1286	/////die Kohomologie ist dann überall 0, muss noch entsprechend ausgegeben werden
1287	}
1288	list allpolys;
1289	allpolys[1]=list(1);
1290	list minvar;
1291	minvar[1]=list(1);
1292	for (i=1; i<=iupto-1; i++)
1293	{
1294	allpolys[i+1]=list();
1295	minvar[i+1]=list();
1296	for (k=1; k<=size(allpolys[i]); k++)
1297	{
1298	for (j=minvar[i][k]; j<=nvars(W) div 2; j++)
1299	{
1300	allpolys[i+1][size(allpolys[i+1])+1]=allpolys[i][k]*D(j);
1301	minvar[i+1][size(minvar[i+1])+1]=j;
1302	}
1303	}
1304	}
1305	list keepformatrix;list sizetruncom;int stc;list fortrun;
1306	for (i=1; i<=size(newcomplex) div 3; i++)
1307	{
1308	truncatedcomplex[2*i-1]=list();
1309	sizetruncom[2*i-1]=list();
1310	sizetruncom[2*i]=list();
1311	truncatedcomplex[2i]=newcomplex[3i];
1312	v=0;count=0;
1313	sizetruncom[2*i][1]=0;
1314	for (j=1; j<=newcomplex[3*i-2]; j++)
1315	{
1316	if (size(shorten[3*i-1][j])!=0)
1317	{
1318	fortrun=sublist(allpolys,shorten[3i-1][j][1],shorten[3i-1][j][2]);
1319	truncatedcomplex[2i-1][size(truncatedcomplex[2i-1])+1]=fortrun[1];
1320	count=count+fortrun[2];
1321	sizetruncom[2i-1][size(sizetruncom[2i-1])+1]=list(int(shorten[3i-1][j][1])-1,int(shorten[3i-1][j][2])-1);
1322	sizetruncom[2i][size(sizetruncom[2i])+1]=count;
1323	if (v!=0)
1324	{
1325	v[size(v)+1]=j;
1326	}
1327	else
1328	{
1329	v[1]=j;
1330	}
1331	}
1332	}
1333
1334	if (v!=0)
1335	{
1336	truncatedcomplex[2i]=submat(truncatedcomplex[2i],v,1..ncols(truncatedcomplex[2*i]));
1337	if (i!=1)
1338	{
1339	truncatedcomplex[2(i-1)]=submat(truncatedcomplex[2(i-1)],1..nrows(truncatedcomplex[2*(i-1)]),v);
1340	}
1341	}
1342	else
1343	{
1344	truncatedcomplex[2i]=matrix(0,1,ncols(truncatedcomplex[2i]));
1345	if (i!=1)
1346	{
1347	truncatedcomplex[2(i-1)]=matrix(0,nrows(truncatedcomplex[2(i-1)]),1);
1348	}
1349	}
1350	}
1351	int b;int d;poly form;poly lform; poly nform;int ideg;int kplus; int lplus;
1352	for (i=1; i<size(truncatedcomplex) div 2; i++)
1353	{
1354	M=matrix(0,max(1,sizetruncom[2i][size(sizetruncom[2i])]),sizetruncom[2i+2][size(sizetruncom[2i+2])]);
1355	for (k=1; k<=size(truncatedcomplex[2*i-1]);k++)
1356	{
1357	for (l=1; l<=size(truncatedcomplex[2*(i+1)-1]); l++)
1358	{
1359	if (size(sizetruncom[2*i])!=1)//?
1360	{
1361	for (j=1; j<=size(truncatedcomplex[2*i-1][k]); j++)
1362	{
1363	for (b=1; b<=size(truncatedcomplex[2*i-1][k][j]); b++)
1364	{
1365	form=truncatedcomplex[2i-1][k][j][b][1]truncatedcomplex[2*i][k,l];
1366	while (form!=0)
1367	{
1368	lform=lead(form);
1369	v=leadexp(lform);
1370	v=v[1..n];
1371	if (v==(0:n))
1372	{
1373	ideg=deg(lform)-sizetruncom[2*(i+1)-1][l][1];
1374	if (ideg>=0)
1375	{
1376	for (d=1; d<=size(truncatedcomplex[2*(i+1)-1][l][ideg+1]);d++)
1377	{
1378	if (leadmonom(lform)==truncatedcomplex[2*(i+1)-1][l][ideg+1][d][1])
1379	{
1380	M[sizetruncom[2i][k]+truncatedcomplex[2i-1][k][j][b][2],sizetruncom[2(i+1)][l]+truncatedcomplex[2(i+1)-1][l][ideg+1][d][2]]=leadcoef(lform);
1381	break;
1382	}
1383	}
1384	}
1385	}
1386	form=form-lform;
1387	}
1388	}
1389	}
1390	}
1391	}
1392	}
1393	truncatedcomplex[2*i]=M;
1394	truncatedcomplex[2i-1]=sizetruncom[2i][size(sizetruncom[2*i])];
1395	}
1396	truncatedcomplex[2i-1]=sizetruncom[2i][size(sizetruncom[2*i])];
1397	if (truncatedcomplex[2*i-1]!=0)
1398	{
1399	truncatedcomplex[2i]=matrix(0,truncatedcomplex[2i-1],1);
1400	}
1401	setring R;
1402	list truncatedcomplex=imap(W,truncatedcomplex);
1403	list derhamhom=findhomology(truncatedcomplex,le);
1404	return (derhamhom);
1405	}
1406
1407	///////////////////////////////////
1408	static proc sublist(list L, int m, int n)
1409	{
1410	list out;
1411	int i; int j;
1412	int count;
1413	for (i=m; i<=n; i++)
1414	{
1415	out[size(out)+1]=list();
1416	for (j=1; j<=size(L[i]); j++)
1417	{
1418	count=count+1;
1419	out[size(out)][j]=list(L[i][j],count);
1420	}
1421	}
1422	list o=list(out,count);
1423	return(o);
1424	}
1425
1426	//////////////////////////////////////////////////////////////////////////
1427	static proc mysubset(intvec L, intvec M)
1428	{
1429	int i;
1430	int j=1;
1431	list position=(M[size(M)],(-1)^(size(L)));
1432	for (i=1; i<=size(L); i++)
1433	{
1434	if (L[i]!=M[j])
1435	{
1436	if (L[i]!=M[j+1] or j!=i)
1437	{
1438	return (L[i],0);
1439	}
1440	else
1441	{
1442	position=(M[i],(-1)^(i-1));
1443	j=j+i;
1444	}
1445	}
1446	j=j+1;
1447	}
1448	return (position);
1449	}
1450
1451
1452
1453	////////////////////////////////////////////////////////////////////////////
1454
1455	proc globalbfun(list L)
1456	{
1457	int i; int j;
1458	def W=basering;
1459	int n=nvars(W) div 2;
1460	list G0;
1461	ideal I;
1462	for (j=1; j<=size(L); j++)
1463	{
1464	G0[j]=list();
1465	for (i=1; i<=ncols(L[j][1]); i++)
1466	{
1467	G0[j][i]=I;
1468	}
1469	}
1470	list out;
1471	for (j=1; j<=size(L); j++)
1472	{
1473	for (i=1; i<=nrows(L[j][1]); i++)
1474	{
1475	out=Vddeg(submat(L[j][1],i,(1..ncols(L[j][1]))),n,L[j][2],1);
1476	G0[j][out[2]][size(G0[j][out[2]])+1]=(out[1]);
1477	}
1478	}
1479	list Data=ringlist(W);
1480	for (i=1; i<=n; i++)
1481	{
1482	Data[2][2*n+i]=Data[2][i];
1483	Data[2][3*n+i]=Data[2][n+i];
1484	Data[2][i]="v("+string(i)+")";
1485	Data[2][n+i]="w("+string(i)+")";
1486	}
1487	Data[3][1][1]="M";
1488	intvec mord=(0:16*n^2);
1489	mord[1..2n]=(1:2n);
1490	mord[6n+1..8n]=(1:2*n);
1491	for (i=0; i<=2*n-2; i++)
1492	{
1493	mord[(3+i)4n-i]=-1;
1494	mord[(2n+2+i)4n-2n-i]=-1;
1495	}
1496	Data[3][1][2]=mord;//ordering mh?????????
1497	matrix Ones=UpOneMatrix(4*n);
1498	Data[5]=Ones;
1499	matrix con[2n][2n];
1500	Data[6]=transpose(concat(con,transpose(concat(con,Data[6]))));
1501
1502	def Wuv=ring(Data);
1503	setring Wuv;
1504	list G0=imap(W,G0); list G3; poly lterm;intvec lexp;
1505	list G1; list G2; intvec e; intvec f; int kapp; int k; int l; poly h; ideal I;
1506	for (l=1; l<=size(G0); l++)
1507	{
1508	G1[l]=list(); G2[l]=list(); G3[l]=list();
1509	for (i=1; i<=size(G0[l]); i++)
1510	{
1511	for (j=1; j<=ncols(G0[l][i]);j++)
1512	{
1513	G0[l][i][j]=mhom(G0[l][i][j]);
1514	}
1515	for (j=1; j<=nvars(Wuv) div 4; j++)
1516	{
1517	G0[l][i][size(G0[l][i])+1]=1-v(j)*w(j);
1518	}
1519	G1[l][i]=std(G0[l][i]);
1520	G2[l][i]=I;
1521	G3[l][i]=list();
1522	for (j=1; j<=ncols(G1[l][i]); j++)
1523	{
1524	e=leadexp(G1[l][i][j]);
1525	f=e[1..2*n];
1526	if (f==intvec(0:(2*n)))
1527	{
1528	for (k=1; k<=n; k++)
1529	{
1530	kapp=-e[2n+k]+e[3n+k];
1531	if (kapp>0)
1532	{
1533	G1[l][i][j]=(x(k)^kapp)*G1[l][i][j];
1534	}
1535	if (kapp<0)
1536	{
1537	G1[l][i][j]=(D(k)^(-kapp))*G1[l][i][j];
1538	}
1539	}
1540	G2[l][i][size(G2[l][i])+1]=G1[l][i][j];
1541	G3[l][i][size(G3[l][i])+1]=list();
1542	while (G1[l][i][j]!=0)
1543	{
1544	lterm=lead(G1[l][i][j]);
1545	G1[l][i][j]=G1[l][i][j]-lterm;
1546	lexp=leadexp(lterm);
1547	lexp=lexp[2n+1..3n];
1548	G3[l][i][size(G3[l][i])][size(G3[l][i][size(G3[l][i])])+1]=list(lexp,leadcoef(lterm));
1549	}
1550
1551	}
1552	}
1553	}
1554	}
1555	ring r=0,(s(1..n)),dp;
1556	ideal I;
1557	map G3forr=Wuv,I;
1558	list G3=G3forr(G3);
1559	poly fs;
1560	poly gs;
1561	int a;
1562	list G4;
1563	for (l=1; l<=size(G3); l++)
1564	{
1565	G4[l]=list();
1566	for (i=1; i<=size(G3[l]);i++)
1567	{
1568	G4[l][i]=I;
1569	for (j=1; j<=size(G3[l][i]); j++)
1570	{
1571	fs=0;
1572	for (k=1; k<=size(G3[l][i][j]); k++)
1573	{
1574	gs=1;
1575	for (a=1; a<=n; a++)
1576	{
1577	if (G3[l][i][j][k][1][a]!=0)
1578	{
1579	gs=gs*permutevar(list(G3[l][i][j][k][1][a]),a);
1580	}
1581	}
1582	gs=gs*G3[l][i][j][k][2];
1583	fs=fs+gs;
1584	}
1585	G4[l][i]=G4[l][i],fs;
1586	}
1587	}
1588	}
1589	if (n==1)
1590	{
1591	ring rnew=0,t,dp;
1592	}
1593	else
1594	{
1595	ring rnew=0,(t,s(2..n)),dp;
1596	}
1597	ideal Iformap;
1598	Iformap[1]=t;
1599	poly forel=1;
1600	for (i=2; i<=n; i++)
1601	{
1602	Iformap[1]=Iformap[1]-s(i);
1603	Iformap[i]=s(i);
1604	forel=forel*s(i);
1605	}
1606	map rtornew=r,Iformap;
1607	list G4=rtornew(G4);
1608	list getintvecs=fetch(W,L);
1609	ideal J;
1610	option(redSB);
1611	for (l=1; l<=size(G4); l++)
1612	{
1613	J=1;
1614	for (i=1; i<=size(G4[l]); i++)
1615	{
1616	G4[l][i]=eliminate(G4[l][i],forel);
1617	G4[l][i]=subst(G4[l][i],t,t-getintvecs[l][2][i]);
1618	J=intersect(J,G4[l][i]);
1619	}
1620	G4[l]=poly(std(J)[1]);
1621	}
1622	list minmax=minmaxintroot(G4);//besser factorize nehmen
1623	// Fall: keine Nullstelle muss noch weiter beruecksichtigt werden
1624	return(minmax);
1625	}
1626
1627
1628
1629
1630	//////////////////////////////////////////////////////////////////////////
1631
1632	proc minmaxintroot(list L);
1633	{
1634	int i; int j; int k; int l; int sa; int s; number d; poly f; poly rest; list a0; list possk; list alldiv; intvec e;
1635	possk[1]=list();
1636	for (i=1; i<=size(L); i++)
1637	{
1638	d=1;
1639	f=L[i];
1640	while (f!=0)
1641	{
1642	rest=lead(f);
1643	d=d*denominator(leadcoef(rest));
1644	f=f-rest;
1645	}
1646	e=leadexp(rest);
1647	if (e[1]!=0)
1648	{
1649	rest=rest/(t^(e[1]));
1650	possk[1][size(possk[1])+1]=i;
1651	}
1652	a0[i]=int(absValue(d*rest));
1653	}
1654	int m=Max(a0);
1655	for (i=2; i<=m+1; i++)
1656	{
1657	possk[i]=list();
1658	}
1659	list allprimefac;
1660	for (i=1; i<=size(L); i++)
1661	{
1662	allprimefac=primefactors(a0[i]);
1663	alldiv=1;
1664	possk[2][size(possk[2])+1]=i;
1665
1666	for (j=1; j<=size(allprimefac[1]); j++)
1667	{
1668	s=size(alldiv);
1669	for (k=1; k<=s; k++)
1670	{
1671	for (l=1; l<=allprimefac[2][j]; l++)
1672	{
1673	alldiv[size(alldiv)+1]=alldiv[k]*allprimefac[1][j]^l;
1674	possk[alldiv[size(alldiv)]+1][size(possk[alldiv[size(alldiv)]+1])+1]=i;
1675	}
1676	}
1677	}
1678	}
1679	int mink;
1680	int maxk;
1681	int indi;
1682	for (i=m+1; i>=1; i--)
1683	{
1684	if (size(possk[i])!=0)
1685	{
1686	for (j=1; j<=size(possk[i]); j++)
1687	{
1688	if (subst(L[possk[i][j]],t,(i-1))==0)
1689	{
1690	maxk=i-1;
1691	indi=1;
1692	break;
1693	}
1694	}
1695	}
1696	if (maxk!=0)
1697	{
1698	break;
1699	}
1700	}
1701	int indi2;
1702	for (i=m+1; i>=1; i--)
1703	{
1704	if (size(possk[i])!=0)
1705	{
1706	for (j=1; j<=size(possk[i]); j++)
1707	{
1708	if (subst(L[possk[i][j]],t,-(i-1))==0)
1709	{
1710	mink=-i+1;
1711	indi2=1;
1712	break;
1713	}
1714	}
1715	}
1716	if (mink!=0)
1717	{
1718	break;
1719	}
1720	}
1721	list mima=mink,maxk;
1722	if (indi==0)
1723	{
1724	if (indi2==0)
1725	{
1726	mima=list();//es gibt keine ganzzahlige NS
1727	}
1728	else
1729	{
1730	mima[2]=mima[1];
1731	}
1732	}
1733	else
1734	{
1735	if (indi2==0)
1736	{
1737	mima[1]=mima[2];
1738	}
1739	}
1740	return (mima);
1741	}
1742
1743	///////////////////////////////////////////////////////
1744
1745
1746	proc findhomology(list L, int le)
1747	{
1748	int li;
1749	matrix M; matrix N;
1750	matrix N1;
1751	matrix lift1;
1752	list out;
1753	int i;
1754	option (redSB);
1755	for (i=2; i<=size(L); i=i+2)
1756	{
1757	if (L[i-1]==0)
1758	{
1759	li=0;
1760	out[i div 2]=0;
1761	}
1762	else
1763	{
1764
1765	if (li==0)
1766	{
1767
1768
1769	li=L[i-1];
1770	N1=transpose(syz(transpose(L[i])));
1771	out[i div 2]=matrix(transpose(syz(transpose(N1))));
1772	out[i div 2]=transpose(matrix(std(transpose(out[i div 2]))));
1773
1774	}
1775
1776	else
1777	{
1778
1779
1780	li=L[i-1];
1781	N1=transpose(syz(transpose(L[i])));
1782	N=transpose(syz(transpose(N1)));
1783	lift1=matrixlift(N1,L[i-2]);
1784	out[i div 2]=transpose(concat(transpose(lift1),transpose(N)));
1785	out[i div 2]=transpose(matrix(std(transpose(out[i div 2]))));
1786	}
1787	}
1788	if (out[i div 2]!=matrix(0,1,ncols(out[i div 2])))
1789	{
1790	out[i div 2]=ncols(out[i div 2])-nrows(out[i div 2]);
1791	}
1792	else
1793	{
1794	out[i div 2]=ncols(out[i div 2]);
1795	}
1796	}
1797	if (size(out)>le)
1798	{
1799	out=delete(out,1);
1800	}
1801	return(out);
1802	}
1803
1804
1805
1806
1807	/////////////////////////////////////////////////////////////////////
1808
1809	static proc mhom(poly f)
1810	{
1811	poly g;
1812	poly l;
1813	poly add;
1814	intvec e;
1815	list minint;
1816	list remf;
1817	int i;
1818	int j;
1819	int n=nvars(basering) div 4;
1820	if (f==0)
1821	{
1822	return(f);
1823	}
1824	while (f!=0)
1825	{
1826	l=lead(f);
1827	e=leadexp(l);
1828	remf[size(remf)+1]=list();
1829	remf[size(remf)][1]=l;
1830	for (i=1; i<=n; i++)
1831	{
1832	remf[size(remf)][i+1]=-e[2n+i]+e[3n+i];
1833	if (size(minint)<i)
1834	{
1835	minint[i]=list();
1836	}
1837	minint[i][size(minint[i])+1]=-e[2n+i]+e[3n+i];
1838	}
1839	f=f-l;
1840	}
1841	for (i=1; i<=n; i++)
1842	{
1843	minint[i]=Min(minint[i]);
1844	}
1845	for (i=1; i<=size(remf); i++)
1846	{
1847	add=remf[i][1];
1848	for (j=1; j<=n; j++)
1849	{
1850	add=v(j)^(remf[i][j+1]-minint[j])*add;
1851	}
1852	g=g+add;
1853	}
1854	return (g);
1855	}
1856
1857
1858
1859
1860	//////////////////////////////////////////////////////////////////////////
1861
1862	static proc permutevar(list L,int n)
1863	{
1864	if (typeof(L[1])=="intvec")
1865	{
1866	intvec v=L[1];
1867	}
1868	else
1869	{
1870	intvec v=(1:L[1]),(0:L[1]);
1871	}
1872	int i;int k; int indi=0;
1873	int j;
1874	int s=size(v);
1875	poly e;
1876	intvec fore;
1877	for (i=2; i<=size(v); i=i+2)
1878	{
1879	if (v[i]!=0)
1880	{
1881	j=i+1;
1882	while (v[j]!=0)
1883	{
1884	j=j+1;
1885	}
1886	v[i]=0;
1887	v[j]=1;
1888	fore=0;
1889	indi=0;
1890	for (k=1; k<=size(v); k++)
1891	{
1892	if (k!=i and k!=j)
1893	{
1894	if (indi==0)
1895	{
1896	indi=1;
1897	fore[1]=v[k];
1898	}
1899	else
1900	{
1901	fore[size(fore)+1]=v[k];
1902	}
1903	}
1904	}
1905	e=e-(j-i)*permutevar(list(fore),n);
1906	}
1907	}
1908	e=e+s(n)^(size(v) div 2);
1909	return (e);
1910	}
1911
1912	///////////////////////////////////////////////////////////////////////////////
1913	static proc max(int i,int j)
1914	{
1915	if(i>j){return(i);}
1916	return(j);
1917	}
1918
1919	////////////////////////////////////////////////////////////////////////////////////
1920	version="$Id$";
1921	category="Noncommutative";
1922	info="
1923	LIBRARY: derham.lib Computation of deRham cohomology
1924
1925	AUTHORS: Cornelia Rottner, rottner@mathematik.uni-kl.de
1926
1927	OVERVIEW:
1928	A library for computing the de Rham cohomology of complements of complex affine
1929	varieties.
1930
1931
1932	REFERENCES:
1933	[OT] Oaku, T.; Takayama, N.: Algorithms of D-modules - restriction, tensor product,
1934	localzation, and local cohomology groups}, J. Pure Appl. Algebra 156, 267-308
1935	(2001)
1936	[R] Rottner, C.: Computing de Rham Cohomology,diploma thesis (2012)
1937	[W1] Walther, U.: Algorithmic computation of local cohomology modules and the local
1938	cohomological dimension of algebraic varieties}, J. Pure Appl. Algebra 139,
1939	303-321 (1999)
1940	[W2] Walther, U.: Algorithmic computation of de Rham Cohomology of Complements of
1941	Complex Affine Varieties}, J. Symbolic Computation 29, 796-839 (2000)
1942	[W3] Walther, U.: Computing the cup product structure for complements of complex
1943	affine varieties, J. Pure Appl. Algebra 164, 247-273 (2001)
1944
1945
1946	PROCEDURES:
1947
1948	deRhamCohomology(list[,opt]); computes the de Rham cohomology
1949	MVComplex(list); computes the Mayer-Vietoris complex
1950	";
1951
1952	LIB "nctools.lib";
1953	LIB "matrix.lib";
1954	LIB "qhmoduli.lib";
1955	LIB "general.lib";
1956	LIB "dmod.lib";
1957	LIB "bfun.lib";
1958	LIB "dmodapp.lib";
1959	LIB "poly.lib";
1960	LIB "schreyer.lib";
1961	LIB "dmodloc.lib";
1962
1963
1964	////////////////////////////////////////////////////////////////////////////////////
1965
1966	proc deRhamCohomology(list L,list #)
1967	"USAGE: deRhamCohomology(L[,choices]); L a list consisting of polynomials, choices
1968	optional list consisting of one up to three strings @*
1969	The optional strings may be one of the strings@*
1970	-'noCE': compute quasi-isomorphic complexes without using Cartan-Eilenberg
1971	resolutionsq@*
1972	-'Vdres': compute quasi-isomorphic complexes using Cartan-Eilenberg
1973	resolutions; the CE resolutions are computed via V__d-homogenization
1974	and without using Schreyer's method @*
1975	-'Sres': compute quasi-isomorphic complexes using Cartan-Eilenberg
1976	resolutions in the homogenized Weyl algebra via Schreyer's method@*
1977	one of the strings@*
1978	-'iterativeloc': compute localizations by factorizing the polynomials and
1979	sucessive localization of the factors @*
1980	-'no iterativeloc': compute localizations by directly localizing the
1981	product@*
1982	and one of the strings
1983	-'onlybounds': computes bounds for the minimal and maximal interger roots
1984	of the global b-function
1985	-'exactroots' computes the minimal and maximal integer root of the global
1986	b-function
1987	The default is 'noCE', 'iterativeloc' and 'onlybounds'.
1988	ASSUME: -The basering must be a polynomial ring over the field of rational numbers@*
1989	RETURN: list, where the ith entry is the (i-1)st de Rham cohomology group of the
1990	complement of the complex affine variety given by the polynomials in L
1991	EXAMPLE:example deRhamCohomology; shows an example
1992	"
1993	{
1994	intvec saveoptions=option(get);
1995	intvec i1,i2;
1996	option(none);
1997	int recursiveloc=1;
1998	int i,j,nr,nc;
1999	def R=basering;
2000	poly islcm, forlcm;
2001	int n=nvars(R);
2002	int le=size(L)+n;
2003	string Syzstring="noCE";
2004	int onlybounds=1;
2005	int diffforms;
2006	for (i=1; i<=size(#); i++)
2007	{
2008	if (#[i]=="Sres")
2009	{
2010	Syzstring="Sres";
2011	}
2012	if (#[i]=="Vdres")
2013	{
2014	Syzstring="Vdres";
2015	}
2016	if (#[i]=="noiterativeloc")
2017	{
2018	recursiveloc=0;
2019	}
2020	if (#[i]=="exactroots")
2021	{
2022	onlybounds=0;
2023	}
2024	if (#[i]=="diffforms")
2025	{
2026	diffforms=1;
2027	}
2028	}
2029	for (i=1; i<=size(L); i++)
2030	{
2031	if (L[i]==0)
2032	{
2033	L=delete(L,i);
2034	i=i-1;
2035	}
2036	}
2037	if (size(L)==0)
2038	{
2039	return (list(0));//////////////////////////////////////////////////////////////////stimmt das jetzt?!??????????????????????????????????
2040	}
2041	for (i=1; i<= size(L); i++)
2042	{
2043	if (leadcoef(L[i])-L[i]==0)
2044	{
2045	return(list(1)); ///////////////////////////////////////////////////////////////stimmt das jetzt?!????????????????????????????????????
2046	}
2047	}
2048	if (size(L)==0)
2049	{
2050	/the complement of the variety given by the input is the whole space/
2051	return(list(1));
2052	}
2053	for (i=1; i<=size(L); i++)
2054	{
2055	if (typeof(L[i])!="poly")
2056	{
2057	print("The input list must consist of polynomials");
2058	return();
2059	}
2060	}
2061	if (size(L)==1 and Syzstring=="noCE")
2062	{
2063	Syzstring="Sres";
2064	}
2065	/* 1st step: compute the Mayer-Vietoris Complex and its Fourier transform*/
2066	def W=MVComplex(L,recursiveloc);//new ring that contains the MV complex
2067	setring W;
2068	list fortoVdstrict=MV;
2069	if (diffforms==0)
2070	{
2071	ideal IFourier=var(n+1);
2072	for (i=2;i<=n;i++)
2073	{
2074	IFourier=IFourier,var(n+i);
2075	}
2076	for (i=1; i<=n;i++)
2077	{
2078	IFourier=IFourier,-var(i);
2079	}
2080	map cFourier=W,IFourier;
2081	matrix sup;
2082	for (i=1; i<=size(MV); i++)
2083	{
2084	sup=fortoVdstrict[i];
2085	/takes the Fourier transform of the MV complex/
2086	fortoVdstrict[i]=cFourier(sup);
2087	}
2088	}
2089	/* 2nd step: Compute a V_d-strict free complex that is quasi-isomorphic to the
2090	complex fortoVdstrict
2091	The 1st entry of the list rem will be the quasi-isomorphic complex, the 2nd
2092	entry contains the cohomology modules and is needed for the computation of the
2093	global b-function*/
2094	if (Syzstring=="noCE")
2095	{
2096	list rem=quasiisomorphicVdComplex(fortoVdstrict,diffforms);
2097	list quasiiso=rem[3];
2098	}
2099	else
2100	{
2101	list rem=toVdStrictFreeComplex(fortoVdstrict,Syzstring,diffforms);
2102	if (diffforms==1)
2103	{
2104	list quasiiso=list(matrix(1,1,1));
2105	}
2106	}
2107	list newcomplex=rem[1];
2108	////////////////////////////////////////////////////////////////////////////////////
2109	/* 3rd step: Compute the bounds for the minimal and maximal integer root of the
2110	global b-function of newcomplex(i.e. compute the lcm of the b-functions of its
2111	cohomology modules)(if onlybouns=1). Else we compute the minimal and maximal
2112	integer root.
2113
2114	If we compute only the bounds, we omit additional Groebner basis computations.
2115	However this leads to a higher-dimensional truncated complex.
2116
2117	Note that the cohomology modules are already contained in rem[2].
2118	minmaxk[1] and minmaxk[2] will contain the bounds resp exact roots.*/
2119	if (diffforms==1)
2120	{
2121	list minmaxk=exactGlobalBFunIntegration(rem[2]);
2122	}
2123	else
2124	{
2125	if (onlybounds==1)
2126	{
2127	list minmaxk=globalBFun(rem[2],Syzstring);
2128	}
2129	else
2130	{
2131	list minmaxk=exactGlobalBFun(rem[2],Syzstring);
2132	}
2133	}
2134	if (size(minmaxk)==0)
2135	{
2136	return (0);
2137	}
2138	///////////////////////////////////////////////////////////////////////////Bis hierhin angepasst
2139	/*4th step: Truncate the complex D_n/(x_1,...,x_n)\otimes C, (where
2140	C=(C^i[m^i],d^i) is given by newcomplex, i.e. C^i=D_n^newcomplex[3*i-2],
2141	m^i=newcomplex[3i-1], d^i=newcomplex[3i]), using Thm 5.7 in [W1]:
2142	The truncated module D_n/(x_1,..,x_n)\otimes C[i] is generated by the set
2143	(0,...,P_(i_j),0,...), where P_(i_j) is a monomial in C[D(1),...,D(n)] and
2144	if it is placed in component k it holds that
2145	minmaxk[1]-m^i[k]<=deg(P_(i_j))<=minmaxk[2]-m^i[k]*/
2146	int k,l;
2147	list truncatedcomplex,shorten,upto;
2148	for (i=1; i<=size(newcomplex) div 3; i++)
2149	{
2150	shorten[3*i-1]=list();
2151	for (j=1; j<=size(newcomplex[3*i-1]); j++)
2152	{
2153	/shorten[3i-1][j][k]=minmaxk[k]-m^i[j]+1 (for k=1,2) if this value is
2154	positive otherwise we will set it to be list();
2155	.- we added +1, because we will use a list, where we put in position l
2156	polys of degree l+1*/
2157	shorten[3i-1][j]=list(minmaxk[1]-newcomplex[3i-1][j]+1);
2158	if (diffforms==1)
2159	{
2160	shorten[3*i-1][j][1]=1;
2161	}
2162	shorten[3i-1][j][2]=minmaxk[2]-newcomplex[3i-1][j]+1;
2163	upto[size(upto)+1]=shorten[3*i-1][j][2];
2164	if (shorten[3*i-1][j][2]<=0)
2165	{
2166	shorten[3*i-1][j]=list();
2167	}
2168	else
2169	{
2170	if (shorten[3*i-1][j][1]<=0)
2171	{
2172	shorten[3*i-1][j][1]=1;
2173	}
2174	}
2175	}
2176	}
2177	int iupto=Max(upto);//maximal degree +1 of the polynomials we have to consider
2178	if (iupto<=0)
2179	{
2180	return(list(0));
2181	}
2182	list allpolys;
2183	/allpolys[i] will consist list of all monomials in D(1),...,D(n) of degree i-1/
2184	allpolys[1]=list(1);
2185	list minvar;
2186	list keepv;
2187	minvar[1]=list(1);
2188	for (i=1; i<=iupto-1; i++)
2189	{
2190	allpolys[i+1]=list();
2191	minvar[i+1]=list();
2192	for (k=1; k<=size(allpolys[i]); k++)
2193	{
2194	for (j=minvar[i][k]; j<=nvars(W) div 2; j++)
2195	{
2196	if (diffforms==0)
2197	{
2198	allpolys[i+1][size(allpolys[i+1])+1]=allpolys[i][k]*D(j);
2199	}
2200	else
2201	{
2202	allpolys[i+1][size(allpolys[i+1])+1]=allpolys[i][k]*x(j);
2203	}
2204	minvar[i+1][size(minvar[i+1])+1]=j;
2205	}
2206	}
2207	}
2208	list keepformatrix,sizetruncom,fortrun,fst;
2209	int count,stc;
2210	intvec v,forin;
2211	matrix subm;
2212	list keepcount;
2213	list passendespoly;
2214	/now we compute the truncation/
2215	for (i=1; i<=size(newcomplex) div 3; i++)
2216	{
2217	/truncatedcomplex[2i-1] will contain all the generators for the truncation
2218	of D_n/(x(1),..,x(n))\otimes C[i]*/
2219	truncatedcomplex[2*i-1]=list();
2220	sizetruncom[2*i-1]=list();
2221	sizetruncom[2*i]=list();
2222	passendespoly[i]=list();
2223	/truncatedcomplex[2i] will be the map trunc(D_n/(x(1),..,x(n))\otimes C[i])
2224	->trunc(D_n/(x(1),..,x(n))\otimes C[i+1])*/
2225	truncatedcomplex[2i]=newcomplex[3i];
2226	v=0;count=0;
2227	sizetruncom[2*i][1]=0;
2228	for (j=1; j<=newcomplex[3*i-2]; j++)
2229	{
2230	if (size(shorten[3*i-1][j])!=0)
2231	{
2232	fortrun=sublist(allpolys,shorten[3i-1][j][1],shorten[3i-1][j][2]);
2233	truncatedcomplex[2i-1][size(truncatedcomplex[2i-1])+1]=fortrun[1];
2234	for (k=1; k<=size(fortrun[1]); k++)
2235	{
2236	for (l=1; l<=size(fortrun[1][k]); l++)
2237	{
2238	passendespoly[i][size(passendespoly[i])+1]=list(fortrun[1][k][l][1],j);
2239	}
2240	}
2241	count=count+fortrun[2];
2242	fst=list(int(shorten[3i-1][j][1])-1,int(shorten[3i-1][j][2])-1);
2243	sizetruncom[2i-1][size(sizetruncom[2i-1])+1]=fst;
2244	sizetruncom[2i][size(sizetruncom[2i])+1]=count;
2245	if (v!=0)
2246	{
2247	v[size(v)+1]=j;
2248	}
2249	else
2250	{
2251	v[1]=j;
2252	}
2253	}
2254	}
2255	if (v!=0)
2256	{
2257	keepv[i]=v;
2258	subm=submat(truncatedcomplex[2i],v,1..ncols(truncatedcomplex[2i]));
2259	truncatedcomplex[2*i]=subm;
2260	if (i!=1)
2261	{
2262	i1=1..nrows(truncatedcomplex[2*(i-1)]);
2263	subm=submat(truncatedcomplex[2*(i-1)],i1,v);
2264	truncatedcomplex[2*(i-1)]=subm;
2265	}
2266	}
2267	else
2268	{
2269	keepv[i]=list();
2270	truncatedcomplex[2i]=matrix(0,1,ncols(truncatedcomplex[2i]));
2271	if (i!=1)
2272	{
2273	nr=nrows(truncatedcomplex[2*(i-1)]);
2274	truncatedcomplex[2*(i-1)]=matrix(0,nr,1);
2275	}
2276	}
2277	}
2278	list keeptruncatedcomplex=truncatedcomplex;
2279	matrix M;
2280	int st,pi,pj;
2281	poly ptc;
2282	int b,d,ideg,kplus,lplus;
2283	int z;
2284	poly form,lform,nform;
2285	/computation of the maps/
2286	if (diffforms==1)
2287	{
2288	def ConvWeyl=makeConverseWeyl(nvars(basering) div 2);
2289	setring ConvWeyl;
2290	poly form,lform,nform;
2291	poly ptc;
2292	list truncatedcomplex;
2293	matrix M;
2294	ideal I=x(1);
2295	for (i=2; i<=nvars(basering) div 2; i++)
2296	{
2297	I=I,var(nvars(basering) div 2 + i);
2298	}
2299	for (i=1; i<=nvars(basering) div 2; i++)
2300	{
2301	I=I,var(i);
2302	}
2303	map transtc=W,I;
2304	truncatedcomplex=transtc(truncatedcomplex);
2305	}
2306	for (i=1; i<size(truncatedcomplex) div 2; i++)
2307	{
2308	nr=max(1,sizetruncom[2i][size(sizetruncom[2i])]);
2309	nc=max(1,sizetruncom[2i+2][size(sizetruncom[2i+2])]);
2310	M=matrix(0,nr,nc);
2311	for (k=1; k<=size(truncatedcomplex[2*i-1]);k++)
2312	{
2313	for (l=1; l<=size(truncatedcomplex[2*(i+1)-1]); l++)
2314	{
2315	if (size(sizetruncom[2*i])!=1)
2316	{
2317	for (j=1; j<=size(truncatedcomplex[2*i-1][k]); j++)
2318	{
2319	for (b=1; b<=size(truncatedcomplex[2*i-1][k][j]); b++)
2320	{
2321	form=truncatedcomplex[2*i-1][k][j][b][1];
2322	form=formtruncatedcomplex[2i][k,l];
2323
2324
2325	for (z=1; z<=nvars(basering) div 2; z++)//neu
2326	{//
2327	form=subst(form,var(z),0);//
2328	}//
2329
2330	while (form!=0)
2331	{
2332	lform=lead(form);
2333	v=leadexp(lform);
2334	v=v[1..n];
2335	// if (v==(0:n))
2336	//{
2337	ideg=deg(lform)-sizetruncom[2*(i+1)-1][l][1];
2338	if (ideg>=0)
2339	{
2340	nr=ideg+1;
2341	st=size(truncatedcomplex[2*(i+1)-1][l][nr]);
2342	for (d=1; d<=st;d++)
2343	{
2344	nc=2*(i+1)-1;
2345	ptc=truncatedcomplex[nc][l][ideg+1][d][1];
2346	if (leadmonom(lform)==ptc)
2347	{
2348	nr=2*i-1;
2349	pi=truncatedcomplex[nr][k][j][b][2];
2350	pi=pi+sizetruncom[2*i][k];
2351	nc=2*(i+1)-1;
2352	nr=ideg+1;
2353	pj=truncatedcomplex[nc][l][nr][d][2];
2354	pj=pj+sizetruncom[2*(i+1)][l];
2355	M[pi,pj]=leadcoef(lform);
2356	break;
2357	}
2358	}
2359	}
2360	// }
2361
2362	form=form-lform;
2363	}
2364	}
2365	}
2366	}
2367	}
2368	}
2369	truncatedcomplex[2*i]=M;
2370	truncatedcomplex[2i-1]=sizetruncom[2i][size(sizetruncom[2*i])];
2371	}
2372	truncatedcomplex[2i-1]=sizetruncom[2i][size(sizetruncom[2*i])];
2373	if (truncatedcomplex[2*i-1]!=0)
2374	{
2375	truncatedcomplex[2i]=matrix(0,truncatedcomplex[2i-1],1);
2376	}
2377	if (diffforms==1)
2378	{
2379	setring W;
2380	truncatedcomplex=imap(ConvWeyl,truncatedcomplex);
2381	}
2382	setring R;
2383	list truncatedcomplex=imap(W,truncatedcomplex);
2384	/*computes the cohomology of the complex (D^i,d^i) given by truncatedcomplex,
2385	i.e. D^i=C^truncatedcomplex[2i-1] and d^i=truncatedcomplex[2i]*/
2386	if (diffforms==0)
2387	{
2388	list derhamhom=findCohomology(truncatedcomplex,le);
2389	option(set,saveoptions);
2390	return (derhamhom);
2391	}
2392	list outall=findCohomologyDiffForms(truncatedcomplex,le);
2393	setring W;
2394	list dimanddiff=imap(R,outall);
2395	list alldiffforms=dimanddiff[2];
2396	while(size(alldiffforms)<size(passendespoly))
2397	{
2398	passendespoly=delete(passendespoly,1);
2399	}
2400	list newdiffforms;
2401	matrix Diff;
2402	for (i=1; i<=size(alldiffforms); i++)
2403	{
2404	newdiffforms[i]=list();
2405	for (j=1; j<=size(alldiffforms[i]); j++)
2406	{
2407	Diff=matrix(0,1,newcomplex[3*(i+size(newcomplex) div 3 - size(alldiffforms))-2]);
2408	for (k=1; k<=ncols(alldiffforms[i][j]); k++)
2409	{
2410	if (alldiffforms[i][j][1,k]!=0)
2411	{
2412	Diff[1,passendespoly[i][k][2]]=Diff[1,passendespoly[i][k][2]]+alldiffforms[i][j][1,k]*passendespoly[i][k][1];
2413	}
2414	}
2415	newdiffforms[i][j]=Diff;
2416	}
2417	}
2418	list omegacomplex=makeOmega(nvars(W) div 2);
2419	list newcomplexmod;
2420	for (i=1; i<=size(newcomplex) div 3; i++)
2421	{
2422	newcomplexmod[2i-1]=newcomplex[3i-2];
2423	newcomplexmod[2i]=newcomplex[3i];
2424	}
2425	while (size(dimanddiff[1])<size(newcomplexmod) div 2)
2426	{
2427	newcomplexmod=delete(newcomplexmod,1);
2428	newcomplexmod=delete(newcomplexmod,1);
2429	}
2430	while (size(dimanddiff[1])<size(quasiiso))
2431	{
2432	quasiiso=delete(quasiiso,1);
2433	}
2434	while (size(dimanddiff[1])>size(generators))
2435	{
2436	generators=insert(generators,list());
2437	}
2438	while (size(dimanddiff[1])>size(quasiiso))
2439	{
2440	quasiiso=insert(quasiiso,list());
2441	}
2442	int keepsign;
2443	list derhamdiff;
2444	list doublecom=makeDoubleComplex(newcomplexmod,omegacomplex,quasiiso,generators);
2445	matrix diffform;
2446	int stopping;
2447	int p;
2448	matrix convert;
2449	list interim;
2450	list correspondingposition;
2451	list allforms=list();
2452	for (i=1; i<=size(newdiffforms); i++)
2453	{
2454	derhamdiff[i]=list();
2455	allforms[i]=list();
2456	for (j=1; j<=size(newdiffforms[i]); j++)
2457	{
2458	allforms[i][j]=list();
2459	keepsign=1;
2460	derhamdiff[i][j]=0;
2461	diffform=newdiffforms[i][j];//Zeilenform
2462	correspondingposition=doublecom[i][1];//needed fpr transformation process
2463	interim=transferDiffforms(diffform,correspondingposition);
2464	if (size(interim)!=0)
2465	{
2466	allforms[i][j][size(allforms[i][j])+1]=interim;
2467	}
2468	stopping=0;
2469	p=1;
2470	for (k=i; k<=size(newdiffforms); k++)
2471	{
2472	keepsign=(-1)*keepsign;
2473	if (stopping==0)
2474	{
2475	if (size(doublecom[k][p][2])==0)
2476	{
2477	stopping=1;
2478	}
2479	else
2480	{
2481	if (size(doublecom[k+1][p][3])!=0)
2482	{
2483	diffform=diffform*doublecom[k][p][2];//Spaltenform
2484	if (diffform!=matrix(0,nrows(diffform),ncols(diffform)))
2485	{
2486	diffform=findPreimage(doublecom[k+1][p][3],transpose(diffform));//Zeilenform
2487	correspondingposition=doublecom[k+1][p+1];//needed for transformation process
2488	interim=transferDiffforms(keepsign*diffform,correspondingposition);
2489	if (size(interim)!=0)
2490	{
2491	allforms[i][j][size(allforms[i][j])+1]=interim;
2492	}
2493	p=p+1;
2494	}
2495	else
2496	{
2497	stopping=1;
2498	}
2499	}
2500	else
2501	{
2502	stopping=1;
2503	}
2504	}
2505	}
2506	}
2507	}
2508	}
2509	setring R;
2510	list allforms=fetch(W,allforms);
2511	option(set,saveoptions);
2512	return (allforms);
2513	}
2514
2515	example
2516	{ "EXAMPLE:";
2517	ring r = 0,(x,y,z),dp;
2518	list L=(xy,xz);
2519	deRhamCohomology(L);
2520	}
2521
2522	////////////////////////////////////////////////////////////////////////////////////
2523	//COMPUTATION OF THE MAYER-VIETORIS COMPLEX
2524	////////////////////////////////////////////////////////////////////////////////////
2525
2526	proc MVComplex(list L,list #)
2527	"USAGE:MVComplex(L); L a list of polynomials
2528	ASSUME: -Basering is a polynomial ring with n vwariables and rational coefficients
2529	-L is a list of non-constant polynomials
2530	RETURN: ring W: the nth Weyl algebra @*
2531	W contains a list MV, which represents the Mayer-Vietrois complex (C^i,d^i) of the
2532	polynomials contained in L as follows:@*
2533	the C^i are given by D_n^ncols(C[2i-1])/im(C[2i-1]) and the differentials
2534	d^i are given by C[2*i]
2535	EXAMPLE:example MVComplex; shows an example
2536	"
2537	{
2538	/* We follow algorithm 3.2.5 in [R],if #!=0 we use also Remark 3.2.6 in [R] for
2539	an additional iterative localization*/
2540	def R=basering;
2541	int i;
2542	int iterative=1;
2543	if (size(#)!=0)
2544	{
2545	iterative=#[1];
2546	}
2547	for (i=1; i<=size(L); i++)
2548	{
2549	if (L[i]==0)
2550	{
2551	print("localization with respect to 0 not possible");
2552	return();
2553	}
2554	if (leadcoef(L[i])-L[i]==0)
2555	{
2556	print("polynomials must be non-constant");
2557	return();
2558	}
2559	}
2560	if (iterative==1)
2561	{
2562	/*compute the localizations by factorizing the polynomials and iterative
2563	localization of the factors */
2564	for (i=1; i<=size(L); i++)
2565	{
2566	L[i]=factorize(L[i],1);
2567	}
2568	}
2569	int r=size(L);
2570	int n=nvars(basering);
2571	int le=size(L)+n;
2572	/construct the ring Ws/
2573	def W=makeWeyl(n);
2574	setring W;
2575	list man=ringlist(W);
2576	if (n==1)
2577	{
2578	man[2][1]="x(1)";
2579	man[2][2]="D(1)";
2580	def Wi=ring(man);
2581	setring Wi;
2582	kill W;
2583	def W=Wi;
2584	setring W;
2585	list man=ringlist(W);
2586	}
2587	man[2][size(man[2])+1]="s";;
2588	man[3][3]=man[3][2];
2589	man[3][2]=list("dp",intvec(1));
2590	matrix N=UpOneMatrix(size(man[2]));
2591	man[5]=N;
2592	matrix M[1][1];
2593	man[6]=transpose(concat(transpose(concat(man[6],M)),M));
2594	def Ws=ring(man);
2595	setring Ws;
2596	int j,k,l,c;
2597	list L=fetch(R,L);
2598	list Cech;
2599	ideal J=var(1+n);
2600	for (i=2; i<=n; i++)
2601	{
2602	J=J,var(i+n);
2603	}
2604	Cech[1]=list(J);
2605	list Theta, remminroots;
2606	Theta[1]=list(list(list(),1,1));
2607	list rem,findminintroot,diffmaps;
2608	int minroot,st,sk;
2609	intvec k1;
2610	poly fred,forfetch;
2611	matrix subm;
2612	int rmr;
2613	if (iterative==0)
2614	{/computation of the modules of the MV complex/
2615	for (i=1; i<=r; i++)
2616	{
2617	findminintroot=list();
2618	Cech[i+1]=list();
2619	Theta[i+1]=list();
2620	k1=1;
2621	for (j=1; j<=i; j++)
2622	{
2623	k1[size(k1)+1]=size(Theta[j+1]);
2624	for (k=1; k<=k1[j]; k++)
2625	{
2626	Theta[j+1][size(Theta[j+1])+1]=list(Theta[j][k][1]+list(i));
2627	Theta[j+1][size(Theta[j+1])][2]=Theta[j][k][2]*L[i];
2628	/*We compute the s-parametric annihilator J(s) and the b-function
2629	of the polynomial L[i] and Cech[i][k] to localize the module
2630	D_n/(D(1),...,D(n))[L[i]^(-1)]\otimes D_n^c/im(Cech[i][k]),
2631	where c=ncols(Cech[i][k]) and the im(Cech[i][k]) is generated by
2632	the rows of the matrix.
2633	If we plug the minimal integer root r(or a smaller integer
2634	value)in J(s), then D_n^ncols(J(s))/im(J(r)) is isomorphic to
2635	the above localization*/
2636	rem=SannfsIBM(L[i],Cech[j][k]);
2637	Cech[j+1][size(Cech[j+1])+1]=rem[1];
2638	findminintroot[size(findminintroot)+1]=rem[2];
2639	}
2640	}
2641	/* we compute the minimal root of all b-functions of L[i] computed above,
2642	because we want to plug in the same root r in all s-parametric
2643	annihilators we computed for L[i] ->this will ensure we can compute
2644	the maps of the MV complex*/
2645	minroot=minIntRoot(findminintroot);
2646	for (j=1; j<=i; j++)
2647	{
2648	for (k=1; k<=k1[j]; k++)
2649	{
2650	sk=size(Cech[j+1])+1-k;
2651	Cech[j+1][size(Cech[j+1])+1-k]=subst(Cech[j+1][sk],s,minroot);
2652	}
2653	}
2654	remminroots[i]=minroot;
2655	}
2656	Cech=delete(Cech,1);
2657	Theta=delete(Theta,1);
2658	list zw;
2659	poly reme;
2660	/computation of the maps of the MV complex/
2661	for (i=1; i<r; i++)
2662	{
2663	diffmaps[i]=matrix(0,size(Cech[i]),size(Cech[i+1]));
2664	for (j=1; j<=size(Cech[i]); j++)
2665	{
2666	for (k=1; k<=size(Cech[i+1]); k++)
2667	{
2668	zw=LMSubset(Theta[i][j][1],Theta[i+1][k][1]);
2669	if (zw[2]!=0)
2670	{
2671	rmr=-remminroots[zw[1]];
2672	reme=zw[2]*(Theta[i+1][k][2]/Theta[i][j][2])^(rmr);
2673	zw[2]=zw[2]*(Theta[i+1][k][2]/Theta[i][j][2])^(rmr);
2674	diffmaps[i][j,k]=zw[2];
2675	}
2676	}
2677	}
2678	}
2679	diffmaps[r]=matrix(0,1,1);
2680	}
2681	list generators;
2682	if (iterative==1)
2683	{
2684	for (i=1; i<=r;i++)
2685	{
2686	generators[i]=list();////////////////////////////////////////////////////////////////////
2687	Cech[i+1]=list();
2688	Theta[i+1]=list();
2689	k1=1;
2690	for (c=1; c<=size(L[i]); c++)
2691	{
2692	findminintroot=list();
2693	for (j=1; j<=i; j++)
2694	{
2695	if (c==1)
2696	{
2697	k1[size(k1)+1]=size(Theta[j+1]);
2698	}
2699	for (k=1; k<=k1[j]; k++)
2700	{
2701	/*We compute the s-parametric annihilator J(s) und the b-
2702	function of the polynomial L[i][c] and Cech[i][k] to
2703	localize the module D_n/(D(1),...,D(n))[L[i][c]^(-1)]\otimes
2704	D_n^c/im(Cech[i][k]), where c=ncols(Cech[i][k]).
2705	If we plug the minimal integer root r(or a smaller integer
2706	value)in J(s), then D_n^ncols(J(s))/im(J(r)) is isomorphic
2707	to the above localization*/
2708	if (c==1)
2709	{
2710	rmr=size(Theta[j+1])+1;
2711	Theta[j+1][rmr]=list(Theta[j][k][1]+list(i));
2712	Theta[j+1][size(Theta[j+1])][2]=Theta[j][k][2]*L[i][c];
2713	rem=SannfsIBM(L[i][c],Cech[j][k]);
2714	Cech[j+1][size(Cech[j+1])+1]=rem[1];
2715	findminintroot[size(findminintroot)+1]=rem[2];
2716	}
2717	else
2718	{
2719	st=size(Theta[j+1])-k1[j]+k;
2720	Theta[j+1][st][2]=Theta[j+1][st][2]*L[i][c];
2721	rem=SannfsIBM(L[i][c],Cech[j+1][size(Cech[j+1])-k1[j]+k]);
2722	Cech[j+1][size(Cech[j+1])-k1[j]+k]=rem[1];
2723	findminintroot[size(findminintroot)+1]=rem[2];
2724	}
2725	}
2726	}
2727	/* we compute the minimal root of all b-functions of L[i][c]
2728	computed above,because we want to plug in the same root r in all
2729	s-parametric annihilators we computed for L[i] ->this will
2730	ensure we can compute the maps of the MV complex*/
2731	minroot=minIntRoot(findminintroot);
2732	for (j=1; j<=i; j++)
2733	{
2734	for (k=1; k<=k1[j]; k++)
2735	{
2736	st=size(Cech[j+1])+1-k;
2737	Cech[j+1][st]=subst(Cech[j+1][st],s,minroot);
2738	}
2739	}
2740	if (c==1)
2741	{
2742	remminroots[i]=list();
2743	}
2744	remminroots[i][c]=minroot;
2745	}
2746	}
2747	Cech=delete(Cech,1);
2748	Theta=delete(Theta,1);
2749	list zw;
2750	poly reme;
2751	/maps of the MV Complex/
2752	for (i=1; i<r; i++)
2753	{
2754	diffmaps[i]=matrix(0,size(Cech[i]),size(Cech[i+1]));
2755	for (j=1; j<=size(Cech[i]); j++)
2756	{
2757	for (k=1; k<=size(Cech[i+1]); k++)
2758	{
2759	zw=LMSubset(Theta[i][j][1],Theta[i+1][k][1]);
2760	if (zw[2]!=0)
2761	{
2762	reme=1;
2763	for (c=1; c<=size(L[zw[1]]);c++)
2764	{
2765	reme=reme*L[zw[1]][c]^(-remminroots[zw[1]][c]);
2766	}
2767	diffmaps[i][j,k]=zw[2]*reme;
2768	}
2769	}
2770	}
2771	}
2772	diffmaps[r]=matrix(0,1,1);
2773	for (i=1; i<=r; i++)
2774	{
2775	for (j=1; j<=size(Theta[i]); j++)
2776	{
2777	generators[i][j]=1;
2778	for (c=1; c<=size(Theta[i][j][1]); c++)
2779	{
2780	for (k=1; k<=size(L[Theta[i][j][1][c]]); k++)
2781	{
2782	generators[i][j]=generators[i][j]L[Theta[i][j][1][c]][k]^((-1)remminroots[Theta[i][j][1][c]][k]);
2783	}
2784	}
2785	}
2786	}
2787	}
2788	setring W;
2789	/map the modules and maps to the Weyl algebra/
2790	list diffmaps=imap(Ws,diffmaps);
2791	list Cechmodules=imap(Ws,Cech);
2792	if (iterative==1)
2793	{
2794	list Theta=imap(Ws,Theta);
2795	list generators=imap(Ws,generators);
2796	}
2797	list Cech;
2798	matrix sup;
2799	for (i=1; i<=r; i++)
2800	{
2801	sup=transpose(matrix(Cechmodules[i][1]));
2802	Cech[2*i-1]=sup;
2803	for (j=2; j<=size(Cechmodules[i]); j++)
2804	{
2805	sup=transpose(matrix(Cechmodules[i][j]));
2806	Cech[2i-1]=dsum(Cech[2i-1],sup);
2807	}
2808	sup=matrix(diffmaps[i]);
2809	Cech[2*i]=sup;
2810	}
2811	list MV=Cech;
2812	if (iterative==1)
2813	{
2814	export Theta;
2815	export generators;
2816	}
2817	export MV;
2818
2819	return (W);
2820	}
2821
2822	example
2823	{ "EXAMPLE:";
2824	ring r = 0,(x,y,z),dp;
2825	list L=xy,xz;
2826	def C=MVComplex(L);
2827	setring C;
2828	MV;
2829	}
2830
2831	////////////////////////////////////////////////////////////////////////////////////
2832
2833	static proc SannfsIBM(poly F,ideal myJ)
2834	"USAGE: SannfsIBM(f,J), F poly, J ideal
2835	ASSUME: basering is D_n[s], where D_n is the Weyl algebra and s and extra
2836	commutative variable@*
2837	f is a polynomial in the variables x(1),...,x(n) with rational coefficients
2838	@*
2839	J is holonomic and f-saturated
2840	RETURN AlList of the form (K,g), where K is an ideal and g a univariant polynomial
2841	in the variable s. K is the s-parametric annihilator of F and J and g is
2842	the b-function of F and J.
2843	"
2844	{
2845	/*modified version of the procedure SannfsBM from the library dmod.lib: SannfsBM
2846	computes the s-parametric annihilator for J=(x_1,...,x_n)*/
2847	/* We use Algorithm 3.1.12 in[R] to compute the s-parametric
2848	annihilator. Then we use the s-parametric annihilator to compute the b-function
2849	via Algorithm 4.7 in [W1].*/
2850	/* We assume that the basering the the nth Weyl algebra D_n. We create the ring
2851	D_n[s,t], where ts=st-t*/
2852	def save = basering;
2853	int N = nvars(basering)-1;
2854	int Nnew = N+2;
2855	int i,j;
2856	string s;
2857	list RL = ringlist(basering);
2858	list L, Lord;
2859	list tmp;
2860	intvec iv;
2861	L[1] = RL[1];
2862	L[4] = RL[4];
2863	list Name = RL[2];
2864	Name=delete(Name,size(Name));
2865	list RName;
2866	RName[1] = "t";
2867	RName[2] = "s";
2868	list DName;
2869	for(i=1;i<=N div 2;i++)
2870	{
2871	DName[i] = var(N div 2+i);
2872	Name=delete(Name,N div 2+1);
2873	}
2874	tmp[1] = "t";
2875	tmp[2] = "s";
2876	list NName = tmp +Name+DName;
2877	L[2] = NName;
2878	kill NName;
2879	tmp[1] = "lp";
2880	iv = 1,1;
2881	tmp[2] = iv;
2882	Lord[1] = tmp;
2883	tmp[1] = "dp";
2884	s = "iv=";
2885	for(i=1;i<=Nnew;i++)
2886	{
2887	s = s+"1,";
2888	}
2889	s[size(s)]= ";";
2890	execute(s);
2891	kill s;
2892	tmp[2] = iv;
2893	Lord[2] = tmp;
2894	tmp[1] = "C";
2895	iv = 0;
2896	tmp[2] = iv;
2897	Lord[3] = tmp;
2898	tmp = 0;
2899	L[3] = Lord;
2900	def @R@ = ring(L);
2901	setring @R@;
2902	matrix @D[Nnew][Nnew];
2903	@D[1,2]=t;
2904	for(i=1; i<=N div 2; i++)
2905	{
2906	@D[2+i, N div 2+2+i]=1;
2907	}
2908	def @R = nc_algebra(1,@D);
2909	setring @R;
2910	kill @R@;
2911	/we start with the computation of the s-parametric annihilator/
2912	poly F = imap(save,F);
2913	ideal myJ=imap(save,myJ);
2914	for (i=1; i<=N div 2; i++)
2915	{
2916	myJ=subst(myJ,D(i),D(i)+diff(F,x(i))*t);
2917	}
2918	ideal I = t*F+s;
2919	I=I,myJ;//the s-parametric annihilator in D_n[s,t]
2920	/we compute the intersection of I and D_n[s]/
2921	ideal J = slimgb(I);
2922	ideal K = nselect(J,1);
2923	K = slimgb(K);//the s-parametric annihilator
2924	/we use K to compute the b-function/
2925	ideal B=K,F;
2926	B=slimgb(B);
2927	vector p=pIntersect(s,B);
2928	poly f=vec2poly(p,2);
2929	setring save;
2930	poly f=imap(@R,f);
2931	ideal K=imap(@R,K);
2932	return (list(K,f));
2933	}
2934
2935	////////////////////////////////////////////////////////////////////////////////////
2936	//COMPUTATION OF A QUASI-ISOMORPHIC V_D-STRICT FREE COMPLEX
2937	////////////////////////////////////////////////////////////////////////////////////
2938
2939	static proc quasiisomorphicVdComplex(list L,list #)
2940	"USAGE: quasiisomorphicVdComplex(L[,df]); L a list of the form (M_1,f_1,...,M_s,f_s),
2941	where the M_i and f_i are matrices
2942	ASSUME: Basering is the Weyl algebra D_n @*
2943	(M_1,f_1,...,M_s,f_s) represents a complex 0->D_n^(r_1)/im(M_1)->
2944	D_n^(r_2)/im(M_2)->...->D_n^(r_s)->0 with differentials f_i, where im(M_i)
2945	is generated by the rows of M_i. In particular it hold:@*
2946	- The M_i are m_i x r_i-matrices and the f_iare r_i x r_(i+1)-matrices @*
2947	-the image of M_1f_i is contained in the image of M_(i+1) @
2948	d is an integer between 1 and n. If no value for d is given, it is assumed
2949	to be n @*
2950	df is an optional int, if df equals 1 a \tilde(V_d)-strict complex
2951	will be computed (instead of a V_d-strict one) (for a definition see [W3])
2952	RETURN: list of the form (L_1,L_2), were L_1 and L_2 are lists @*
2953	L_1 is of the form (i_(-n-1),g_(-n-1),m_(-n-1),...,i_s,g_s,m_s) such that:@*
2954	-the i_j are integers, the g_j are i_j x i_(j+1)-matrices, the m_j intvecs
2955	of size i_j@*
2956	-D_n^(i_(-n-1))[m_(-n-1)]->...->D_n^(i_s)[m_s]->0 is a V_d-strict complex
2957	with differentials m_i that is quasi-isomorphic to the complex given by L@*
2958	L_2 is of the form (H_1,n_1,...,H_s,n_s), where the H_i are matrices and
2959	the n_i are shift vectors such that:@*
2960	-coker(H_i) is the ith cohomology group of the complex given by L_1@*
2961	-the n_i are the shift vectors of the coker(H_i)
2962	THEORY: We follow Proposition 3.2 and Corollary 3.3 in [W3]
2963	"
2964	{
2965	int tilde;
2966	if (size(#)!=0)
2967	{
2968	tilde=#[1];
2969	}
2970	def B=basering;
2971	int n=nvars(B) div 2 + 1;//+1 müsste stimmen! bitte kontrollieren!
2972	int d=nvars(B) div 2;
2973	int r=size(L) div 2;
2974	int lonc=n+r;
2975	int Kiold=0;
2976	matrix kerold;
2977	// matrix kernew=out[r][2][2];
2978	matrix kernew=diag(1,ncols(L[size(L)-1]));
2979	module mL;
2980	int i;
2981	int k;
2982	matrix testm;
2983	int Kinew=nrows(kernew);
2984	int Jiold=0;
2985	int Jinew=0;
2986	matrix Niold;
2987	matrix Ninew;
2988	list newcomplex;
2989	int Aiold=Kinew;
2990	matrix savediv;
2991	newcomplex[3*lonc-2]=Kinew;
2992	newcomplex[3*lonc-1]=intvec(0:Kinew);
2993	newcomplex[3*lonc]=matrix(0,Kinew,1);
2994	list quasiiso;
2995	quasiiso[lonc]=diag(1,Kinew);
2996	matrix invimage;
2997	matrix keralpha;
2998	intvec v;
2999	int j;
3000	matrix sc;
3001	matrix fnc;
3002	int indk;
3003	int indj;
3004	int Aiold;
3005	list saveres;
3006	matrix Liplus;
3007	for (i=r-1; i>=0; i--)
3008	{
3009	indk=0;
3010	indj=0;
3011	Kiold=Kinew;
3012	kerold=kernew;
3013	if (i!=0)
3014	{
3015	// kernew=divdr(L[2i],L[2i+1],1);
3016	kernew=divdr(L[2i],L[2i+1]);
3017	mL=slimgb(transpose(L[2*i-1]));
3018	for (k=1; k<=nrows(kernew); k++)
3019	{
3020	testm=reduce(transpose(submat(kernew,k,intvec(1..ncols(kernew)))),mL);
3021	if (testm==matrix(0,nrows(testm),ncols(testm)))
3022	{
3023	kernew=transpose(deletecol(transpose(kernew),k));
3024	k=k-1;
3025	}
3026	}
3027	Kinew=nrows(kernew);
3028	if (kernew==matrix(0,nrows(kernew),ncols(kernew)))
3029	{
3030	Kinew=0;
3031	indk=1;
3032	}
3033	}
3034	else
3035	{
3036	Kinew=0;
3037	indk=1;
3038	}
3039	Jiold=Jinew;
3040	Niold=Ninew;
3041	keralpha=transpose(syz(transpose(newcomplex[3*(i+n)+3])));
3042	if (i!=0)
3043	{
3044	invimage=divdr(quasiiso[n+i+1],transpose(concat(transpose(L[2i]),transpose(L[2i+1]))));
3045	Ninew=vdStrictIntersect(keralpha,invimage,newcomplex[3*(n+i+1)-1],tilde);//////////////
3046	}
3047	else
3048	{
3049	invimage=divdr(quasiiso[n+i+1],L[2*i+1]);
3050	saveres=vdStrictIntersectPlus(keralpha,invimage,newcomplex[3*(n+i+1)-1],tilde);////////////////////////
3051
3052	///////////////////BIS HIERHIN VERALLGEMEINERT////////////////////////////////////////////////////////////////////
3053
3054
3055	Ninew=saveres[1];
3056	}
3057	Jinew=nrows(Ninew);
3058	if (Ninew==matrix(0,nrows(Ninew),ncols(Ninew)))
3059	{
3060	Jinew=0;
3061	indk=1;
3062	}
3063	newcomplex[3*(n+i)-2]=Kinew+Jinew;
3064	v=0;
3065	if (indk==0)
3066	{
3067	v=(0:Kinew);
3068	if (indj==0)
3069	{
3070	fnc=transpose(concat(transpose(matrix(0,Kinew,Kiold+Jiold)),transpose(Ninew)));
3071	}
3072	else
3073	{
3074	fnc=matrix(0,Kinew,Kiold+Jiold);
3075	}
3076	}
3077	else
3078	{
3079	if (indj==0)
3080	{
3081	fnc=Ninew;
3082	}
3083	else
3084	{
3085	fnc=matrix(0,1,Kiold+Jiold);
3086	newcomplex[3*(n+i)-2]=1;
3087	}
3088	}
3089	Aiold=Jinew+Kinew;
3090	if (Aiold==0)
3091	{
3092	Aiold=1;
3093	}
3094	newcomplex[3*(n+i)]=fnc;
3095	for (j=1; j<=Jinew; j++)
3096	{
3097	if (tilde==0)
3098	{
3099	v[Kinew+j]=VdDeg(submat(Ninew,j,(1..ncols(Ninew))),nvars(B) div 2,newcomplex[3*(n+i)+2]);
3100	}
3101	else
3102	{
3103	v[Kinew+j]=VdDegTilde(submat(Ninew,j,(1..ncols(Ninew))),nvars(B) div 2,newcomplex[3*(n+i)+2]);
3104	}
3105	}
3106	newcomplex[3*(n+i)-1]=v;
3107	if (i==0)
3108	{
3109	quasiiso[n+i]=matrix(0,Jinew,1);
3110	}
3111	else
3112	{
3113	if (indj==0)
3114	{
3115	sc=submat(fnc,intvec(Kinew+1..nrows(fnc)),intvec(1..ncols(fnc)))*quasiiso[n+i+1];
3116	Liplus=transpose(concat(transpose(L[2i]),transpose(L[2i+1])));
3117	sc=matrixLift(Liplus,sc);//stimmt das jetzt
3118	sc=submat(sc,intvec(1..nrows(sc)),intvec(1..nrows(L[2*i])));
3119	if (indk==0)
3120	{
3121	//pi=kernew
3122	quasiiso[n+i]=transpose(concat(transpose(kernew),transpose(sc)));
3123	}
3124	else
3125	{
3126	quasiiso[n+i]=sc;
3127	}
3128	}
3129	else
3130	{
3131	if (indk==0)
3132	{
3133	quasiiso[n+i]=kernew;
3134	}
3135	else
3136	{
3137	quasiiso[n+i]=matrix(0,1,ncols(kernew));
3138	}
3139	}
3140	}
3141	}
3142	for (i=1; i<=n-1; i++)
3143	{
3144	quasiiso[n-i]=list();
3145	if (size(saveres[2][i])!=0)
3146	{
3147	newcomplex[3*(n-i)]=saveres[2][i];
3148	newcomplex[3*(n-i)-2]=nrows(saveres[2][i]);
3149	v=0;
3150	for (j=1; j<=newcomplex[3*(n-i)-2]; j++)
3151	{
3152	if (tilde==0)
3153	{
3154	v[j]=VdDeg(submat(saveres[2][i],j,(1..ncols(saveres[2][i]))),nvars(B) div 2, newcomplex[3*(n-i)+2]);
3155	}
3156	else
3157	{
3158	v[j]=VdDegTilde(submat(saveres[2][i],j,(1..ncols(saveres[2][i]))),nvars(B) div 2, newcomplex[3*(n-i)+2]);
3159	}
3160	}
3161	newcomplex[3*(n-i)-1]=v;
3162	}
3163	else
3164	{
3165	newcomplex[3*(n-i)]=matrix(0,1,1);
3166	if (newcomplex[3*(n-i)+1]!=0)
3167	{
3168	newcomplex[3(n-i)]=matrix(0,1,newcomplex[3(n-i)+1]);
3169	}
3170	newcomplex[3*(n-i)-2]=int(0);
3171	newcomplex[3*(n-i)-1]=intvec(0);
3172	}
3173	}
3174	list result;
3175	result[1]=newcomplex;
3176	result[2]=list();
3177	list forsep;
3178	for (i=1; i<=size(L) div 2+1; i++)
3179	{
3180	forsep[2i]=newcomplex[3(n+i-1)];
3181	forsep[2i-1]=matrix(0,1,nrows(forsep[2i]));
3182	}
3183	forsep=shortExactPieces(forsep);
3184	list listofHis;
3185	matrix forVd;
3186	for (i=1; i<=size(L) div 2; i++)
3187	{
3188	v=0;
3189	listofHis[i]=list(forsep[i+1][1][5]);
3190	forVd=forsep[i+1][2][2];
3191	for (j=1; j<=nrows(forVd); j++)
3192	{
3193	if (tilde==0)
3194	{
3195	v[j]=VdDeg(submat(forVd,j,intvec(1..ncols(forVd))),nvars(B) div 2, newcomplex[3*(n+i)-1]);
3196	}
3197	else
3198	{
3199	v[j]=VdDegTilde(submat(forVd,j,intvec(1..ncols(forVd))),nvars(B) div 2, newcomplex[3*(n+i)-1]);
3200	}
3201	}
3202	listofHis[i][2]=v;
3203	}
3204	result[2]=listofHis;
3205	result[3]=quasiiso;
3206	return(result);
3207	}
3208
3209	////////////////////////////////////////////////////////////////////////////////////
3210
3211	static proc vdStrictIntersect(matrix M, matrix N, intvec v, int tilde)
3212	{
3213	def B=basering;
3214	option(returnSB);// alternative:erst intersect und dann SB-Berechung mit slimgb
3215	if (tilde==0)
3216	{
3217	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2,v);
3218	}
3219	else
3220	{
3221	def HomWeyl=makeHomogenizedWeylTilde(nvars(B) div 2,v);
3222	}
3223	setring HomWeyl;
3224	matrix M=fetch(B,M);
3225	matrix N=fetch(B,N);
3226	M=nHomogenize(M);
3227	N=nHomogenize(N);
3228	matrix vdintersection=transpose(intersect(transpose(M),transpose(N)));
3229	vdintersection=subst(vdintersection,h,1);
3230	setring B;
3231	matrix vdintersection=fetch(HomWeyl,vdintersection);
3232	option(noreturnSB);
3233	return(vdintersection);
3234	}
3235
3236	////////////////////////////////////////////////////////////////////////////////////
3237
3238	static proc vdStrictIntersectPlus(matrix M, matrix N, intvec v, int tilde)
3239	{
3240	def B=basering;
3241	int n=nvars(B) div 2;
3242	matrix vdint=transpose(intersect(transpose(M),transpose(N)));
3243	if (tilde==0)
3244	{
3245	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2,v);
3246	}
3247	else
3248	{
3249	def HomWeyl=makeHomogenizedWeylTilde(nvars(B) div 2,v);
3250	}
3251	setring HomWeyl;
3252	matrix vdint=fetch(B,vdint);
3253	matrix N=fetch(B,N);
3254	vdint=nHomogenize(vdint);
3255	intvec i1;
3256	intvec i2;
3257	int i;
3258	int nr;
3259	int nc;
3260	def ringofSyz=Sres(transpose(vdint),n);////////////////////////////////////////////////////////////////
3261	setring ringofSyz;
3262	matrix vdint=transpose(matrix(RES[2]));
3263	vdint=subst(vdint,h,1);
3264	int logens=ncols(vdint)+1;
3265	int omitemptylist;
3266	matrix zerom;
3267	list rofA;
3268	for (i=3; i<=n+3; i++)////////////////////////////////////////////////////////////////////////////n und si müssen noch definiert werden
3269	{
3270	if (size(RES)>=i)
3271	{
3272	zerom=matrix(0,nrows(matrix(RES[i])),ncols(matrix(RES[i])));
3273	if (RES[i]!=zerom)
3274	{
3275	rofA[i-2]=(matrix(RES[i]));
3276	if (i==3)
3277	{
3278	if (nrows(rofA[i-2])-logens+1!=nrows(vdint))
3279	{
3280	//build the resolution
3281	nr=nrows(vdint)+logens-1;
3282	nc=ncols(rofA[i-2]);
3283	rofA[i-2]=matrix(rofA[i-2],nr,nc);
3284	}
3285
3286	}
3287	if (i!=3)
3288	{
3289	if (nrows(rofA[i-2])-logens+1!=nrows(rofA[i-3]))
3290	{
3291	nr=nrows(rofA[i-3])+logens-1;
3292	nc=ncols(rofA[i-2]);
3293	rofA[i-2]=matrix(rofA[i-2],nr,nc);
3294	}
3295	}
3296	i1=intvec(logens..nrows(rofA[i-2]));
3297	i2=intvec(1..ncols(rofA[i-2]));
3298	rofA[i-2]=transpose(submat(rofA[i-2],i1,i2));
3299	logens=logens+ncols(rofA[i-2]);
3300	rofA[i-2]=subst(rofA[i-2],h,1);
3301	}
3302	else
3303	{
3304	rofA[i-2]=list();
3305	}
3306	}
3307	else
3308	{
3309	rofA[i-2]=list();
3310	}
3311	}
3312	if(size(rofA[1])==0)
3313	{
3314	omitemptylist=1;
3315	}
3316	setring B;
3317	vdint=fetch(ringofSyz,vdint);
3318	if (omitemptylist!=1)
3319	{
3320	list rofA=fetch(ringofSyz,rofA);
3321	}
3322	kill HomWeyl;
3323	kill ringofSyz;
3324	return(list(vdint,rofA));
3325	}
3326
3327	////////////////////////////////////////////////////////////////////////////////////
3328
3329	static proc toVdStrictFreeComplex(list L,string Syzstring,list #)
3330	"USAGE: toVdStrictFreeComplex(L, Syzstring [,d]); L a list of the form
3331	(M_1,f_1,...,M_s,f_s), where the M_i and f_i are matrices, Syzstring a
3332	string, d an optional integer
3333	ASSUME: Basering is the Weyl algebra D_n @*
3334	(M_1,f_1,...,M_s,f_s) represents a complex 0->D_n^(r_1)/im(M_1)->
3335	D_n^(r_2)/im(M_2)->...->D_n^(r_s)->0 with differentials f_i, where im(M_i)
3336	is generated by the rows of M_i. In particular it hold:@*
3337	- The M_i are m_i x r_i-matrices and the f_iare r_i x r_(i+1)-matrices @*
3338	-the image of M_1f_i is contained in the image of M_(i+1) @
3339	d is an optional integer which indices in the case size(L)=2, whether a
3340	V_d-strict or \tilde(V_d)-strict will be computed@*
3341	Syzstring is either: @*
3342	-'Sres' (computes the resolutions and Groebner bases in the homogenized
3343	Weyl algebra using Schreyer's method)@*
3344	or @*
3345	-'Vdres' (computes the resolutions via V_d-homogenization and without
3346	Schreyer's method)@*
3347	RETURN: list of the form (L_1,L_2), were L_1 and L_2 are lists @*
3348	L_1 is of the form (i_(-n-1),g_(-n-1),m_(-n-1),...,i_s,g_s,m_s) such that:@*
3349	-the i_j are integers, the g_j are i_j x i_(j+1)-matrices, the m_j intvecs
3350	of size i_j@*
3351	-D_n^(i_(-n-1))[m_(-n-1)]->...->D_n^(i_s)[m_s]->0 is a V_d-strict complex
3352	with differentials m_i that is quasi-isomorphic to the complex given by L@*
3353	L_2 is of the form (H_1,n_1,...,H_s,n_s), where the H_i are matrices and
3354	the n_i are shift vectors such that:@*
3355	-coker(H_i) is the ith cohomology group of the complex given by L_1@*
3356	-the n_i are the shift vectors of the coker(H_i)
3357	THEORY: We follow Algorithm 3.8 in [W2]
3358	"
3359	{
3360	def B=basering;
3361	int n=nvars(B) div 2+2;
3362	int d=nvars(B) div 2;
3363	intvec v;
3364	list out, outall;
3365	int i,j,k,indi,nc,nr;
3366	matrix mem;
3367	intvec i1,i2;
3368	int tilde;
3369	if (size(#)!=0)
3370	{
3371	for (i=1; i<=size(#); i++)
3372	{
3373	if (typeof(#[i])=="int")
3374	{
3375	tilde=#[i];
3376	}
3377	}
3378	}
3379	/* If size(L)=2, our complex consists for only one non-trivial module.
3380	Therefore, we just have to compute a V_d-strict resolution of this module.*/
3381	if (size(L)==2)
3382	{
3383	v=(0:ncols(L[1]));
3384	out[3*n-1]=v;
3385	out[3*n-2]=ncols(L[1]);
3386	out[3*n]=L[2];
3387	if (Syzstring=="Vdres")
3388	{
3389	/*if Syzstring="Vdres", we compute a V_d-strict Groebner basis of L[1]
3390	using F-homogenization (Prop. 3.9 in [OT]); then we compute the syzygies
3391	and make them V_d-strict using Prop 3.9[OT] and so on*/
3392	out[3*n-3]=VdStrictGB(L[1],d,v);
3393	for (i=n-1; i>=1; i--)
3394	{
3395	out[3i-2]=nrows(out[3i]);
3396	v=0;
3397	for (j=1; j<=out[3*i-2]; j++)
3398	{
3399	mem=submat(out[3i],j,intvec(1..ncols(out[3i])));
3400	v[j]=VdDeg(mem,d, out[3*i+2]);//next shift vector
3401	}
3402	out[3*i-1]=v;
3403	if (i!=1)
3404	{
3405	/next step in the resolution/
3406	out[3i-3]=transpose(syz(transpose(out[3i])));
3407	if (out[3i-3]!=matrix(0,nrows(out[3i-3]),ncols(out[3*i-3])))
3408	{
3409	/makes the resolution V_d-strict/
3410	out[3i-3]=VdStrictGB(out[3i-3],d,out[3*i-1]);
3411	}
3412	else
3413	{
3414	/resolution is already computed/
3415	out[3i-3]=matrix(0,1,ncols(out[3i-3]));
3416	out[3*i-4]=intvec(0);
3417	out[3*i-5]=int(0);
3418	for (j=i-2; j>=1; j--)
3419	{
3420	out[3*j]=matrix(0,1,1);
3421	out[3*j-1]=intvec(0);
3422	out[3*j-2]=int(0);
3423	}
3424	break;
3425	}
3426	}
3427	}
3428	}
3429	else
3430	{
3431	/*in the case Syzstring!="Vdres" we compute the resolution in the
3432	homogenized Weyl algebra using Thm 9.10 in[OT]*/
3433	if (tilde==0)
3434	{
3435	def HomWeyl=makeHomogenizedWeyl(d);
3436	}
3437	else
3438	{
3439	def HomWeyl=makeHomogenizedWeylTilde(d);
3440	}
3441	setring HomWeyl;
3442	list L=fetch(B,L);
3443	L[1]=nHomogenize(L[1]);
3444	list out=fetch(B,out);
3445	out[3*n-3]=L[1];
3446	/*computes a ring with a list RES; RES is a V_d-strict resolution of
3447	L[1]*/
3448	def ringofSyz=Sres(transpose(L[1]),d);
3449	setring ringofSyz;
3450	int logens=2;
3451	matrix mem;
3452	list out=fetch(HomWeyl,out);
3453	out[3*n-3]=transpose(matrix(RES[2]));
3454	out[3n-3]=subst(out[3n-3],h,1);
3455	for (i=n-1; i>=1; i--)
3456	{
3457	out[3i-2]=nrows(out[3i]);
3458	v=0;
3459	for (j=1; j<=out[3*i-2]; j++)
3460	{
3461	mem=submat(out[3i],j,intvec(1..ncols(out[3i])));
3462	if (tilde==0)
3463	{
3464	v[j]=VdDeg(mem,d, out[3*i+2]);
3465	}
3466	else
3467	{
3468	v[j]=VdDegTilde(mem,d, out[3*i+2]);
3469	}
3470	}
3471	out[3*i-1]=v;//shift vector such that the resolution RES is V_d-strict
3472	if (i!=1)
3473	{
3474	indi=0;
3475	if (size(RES)>=n-i+2)
3476	{
3477	nr=nrows(matrix(RES[n-i+2]));
3478	mem=matrix(0,nr,ncols(matrix(RES[n-i+2])));
3479	if (matrix(RES[n-i+2])!=mem)
3480	{
3481	indi=1;
3482	out[3*i-3]=(matrix(RES[n-i+2]));
3483	if (nrows(out[3i-3])-logens+1!=nrows(out[3i]))
3484	{
3485	mem=out[3*i-3];
3486	out[3*i-3]=matrix(mem,nrows(mem)+logens-1,ncols(mem));
3487	}
3488	mem=out[3*i-3];
3489	i1=intvec(logens..nrows(mem));
3490	mem=submat(mem,i1,intvec(1..ncols(mem)));
3491	out[3*i-3]=transpose(mem);
3492	out[3i-3]=subst(out[3i-3],h,1);
3493	logens=logens+ncols(out[3*i-3]);
3494	}
3495	}
3496	if(indi==0)
3497	{
3498	out[3i-3]=matrix(0,1,nrows(out[3i]));
3499	out[3*i-4]=intvec(0);
3500	out[3*i-5]=int(0);
3501	for (j=i-2; j>=1; j--)
3502	{
3503	out[3*j]=matrix(0,1,1);
3504	out[3*j-1]=intvec(0);
3505	out[3*j-2]=int(0);
3506	}
3507	break;
3508	}
3509	}
3510	}
3511	setring B;
3512	out=fetch(ringofSyz,out);//contains the V_d-strict resolution
3513	kill ringofSyz;
3514	}
3515	outall[1]=out;
3516	outall[2]=list(list(out[3n-3],out[3n-1]));
3517	return(outall);
3518	}
3519	/*case size(L)>2: We compute a quasi-isomorphic free complex following Alg 3.8 in
3520	[W2]*/
3521	/* We denote the complex given by L as (C^i,d^i).
3522	We start by computing in the proc shortExaxtPieces representations for the
3523	short exact sequences B^i->Z^i->H^i and Z^i->C^i->B^(i+1), where the B^i, Z^i
3524	and H^i are coboundaries, cocycles and cohomology groups, respectively.*/
3525	out=shortExactPieces(L);
3526	list rem;
3527	/* shortExactpiecesToVdStrict makes the sequences B^i->Z^i->H^i and
3528	Z^i->C^i->B^(i+1) V_d-strict*/
3529	rem=shortExactPiecesToVdStrict(out,d,Syzstring);
3530	/*VdStrictDoubleComplexes computes V_d-strict resolutions over the seqeunces from
3531	proc shortExactPiecesToVdstrict*/
3532	out=VdStrictDoubleComplexes(rem[1],d,Syzstring);
3533	for (i=1;i<=size(out); i++)
3534	{
3535	rem[2][i][1]=out[i][1][5][1];
3536	rem[2][i][2]=out[i][1][8][1];
3537	}
3538	/* AssemblingDoubleComplexes puts the resolution of the C^i (from the sequences
3539	Z^i->C^i->B^(i+1)) together to obtain a Cartan-Eilenberg resolution of
3540	(C^i,d^i)*/
3541	out=assemblingDoubleComplexes(out);
3542	/*the proc totalComplex takes the total complex of the double complex from the
3543	proc assemblingDoubleComplexes*/
3544	out=totalComplex(out);
3545	outall[1]=out;
3546	outall[2]=rem[2];//contains the cohomology groups and their shift vectors
3547	return (outall);
3548	}
3549
3550	////////////////////////////////////////////////////////////////////////////////////
3551
3552
3553	static proc sublist(list L,int m,int n)
3554	{
3555	list out;
3556	int i; int j;
3557	int count;
3558	for (i=m; i<=n; i++)
3559	{
3560	out[size(out)+1]=list();
3561	for (j=1; j<=size(L[i]); j++)
3562	{
3563	count=count+1;
3564	out[size(out)][j]=list(L[i][j],count);
3565	}
3566	}
3567	list o=list(out,count);
3568	return(o);
3569	}
3570
3571	////////////////////////////////////////////////////////////////////////////////////
3572
3573	static proc LMSubset(list L,list M, list #)
3574	{
3575	int i;
3576	int j=1;
3577	if (size(#)==0)
3578	{
3579	list position=(M[size(M)],(-1)^(size(L)));
3580	}
3581	else
3582	{
3583	list position=(M[size(M)],1);
3584	}
3585	for (i=1; i<=size(L); i++)
3586	{
3587	if (L[i]!=M[j])
3588	{
3589	if (L[i]!=M[i+1] or j!=i)
3590	{
3591	return (L[i],0);
3592	}
3593	else
3594	{
3595	if (size(#)==0)
3596	{
3597	position=(M[i],(-1)^(i-1));
3598	}
3599	else
3600	{
3601	position=(M[i],(-1)^(size(L)+1-i));
3602	}
3603	j=j+1;
3604	}
3605	}
3606	j=j+1;
3607
3608	}
3609	return (position);
3610	}
3611
3612	////////////////////////////////////////////////////////////////////////////////////
3613
3614	static proc shortExactPieces(list L)
3615	{
3616	/we follow Section 3.3 in [W2]/
3617	/* we assume that L=(M_1,f_1,...,M_s,f_s) defines the complex C=(C^i,d^i)
3618	as in the procedure toVdstrictcomplex*/
3619	matrix Bnew= divdr(L[2],L[3]);
3620	matrix Bold=Bnew;
3621	matrix Z=divdr(Bnew,L[1]);
3622	list bzh,zcb;
3623	bzh=list(list(),list(),Z,unitmat(ncols(Z)),Z);
3624	zcb=(Z, Bnew, L[1], unitmat(ncols(L[1])), Bnew);
3625	list sep;
3626	/* the list sep will be of size s such that
3627	-sep[i]=(sep[i][1],sep[i][2]) is a list of two lists
3628	-sep[i][1]=(B^i,f^(BZi),Z^i,f_^(ZHi),H^i) such that coker(B^i)->coker(Z^i)
3629	->coker(H^i) represents the short exact seqeuence B^i(C)->Z^i(C)->H^i(C)
3630	-sep[i][2]=(Z^i,f^(ZCi),C^i,f^(CBi),B^(i+1)) such that coker(Z^i)->coker(C^i)->
3631	coker(B^(i+1)) represents the short exact seqeuence Z^i(C)->C^i->B^(i+1)(C)*/
3632	sep[1]=list(bzh,zcb);
3633	int i;
3634	list out;
3635	for (i=3; i<=size(L)-2; i=i+2)
3636	{
3637	/the proc bzhzcb computes representations for the short exact seqeunces /
3638	out=bzhzcb(Bold, L[i-1] , L[i], L[i+1], L[i+2]);
3639	sep[size(sep)+1]=out[1];
3640	Bold=out[2];
3641	}
3642	bzh=(divdr(L[size(L)-2], L[size(L)-1]),L[size(L)-2], L[size(L)-1]);
3643	bzh[4]=unitmat(ncols(L[size(L)-1]));
3644	bzh[5]=transpose(concat(transpose(L[size(L)-2]),transpose(L[size(L)-1])));
3645	zcb=(L[size(L)-1], unitmat(ncols(L[size(L)-1])), L[size(L)-1],list(),list());
3646	sep[size(sep)+1]=list(bzh,zcb);
3647	return(sep);
3648	}
3649
3650	////////////////////////////////////////////////////////////////////////////////////
3651
3652	static proc bzhzcb (matrix Bold,matrix f0,matrix C1,matrix f1,matrix C2)
3653	{
3654	matrix Bnew=divdr(f1,C2);
3655	matrix Z= divdr(Bnew,C1);
3656	matrix lift1= matrixLift(Bnew,f0);
3657	matrix H=transpose(concat(transpose(lift1),transpose(Z)));
3658	list bzh=(Bold, lift1, Z, unitmat(ncols(Z)),H);
3659	list zcb=(Z, Bnew, C1, unitmat(ncols(C1)),Bnew);
3660	list out=(list(bzh, zcb), Bnew);
3661	return(out);
3662	}
3663
3664	////////////////////////////////////////////////////////////////////////////////////
3665
3666	static proc shortExactPiecesToVdStrict(list C,int d,list #)
3667	{/* We transform the short exact pieces from procedure shortExactPieces to V_d-
3668	strict short exact sequences. For this, we use Algorithm 3.11 and Lemma 4.2 in
3669	[W2].*/
3670	/* If we compute our Groebner bases in the homogenized Weyl algebra, we already
3671	compute some resolutions it omit additional Groebner basis computations later
3672	on.*/
3673	int s =size(C);int i; int j;
3674	string Syzstring="Sres";
3675	intvec v=0:ncols(C[s][1][5]);
3676	if (size(#)!=0)
3677	{
3678	for (i=1; i<=size(#); i++)
3679	{
3680	if (typeof(#[i])=="string")
3681	{
3682	Syzstring=#[i];
3683	}
3684	if (typeof(#[i])=="intvec")
3685	{
3686	v=#[i];
3687	}
3688	}
3689	}
3690	list out;
3691	list forout;
3692	if (Syzstring=="Vdres")
3693	{
3694	out[s]=list(toVdStrictSequence(C[s][1],d,v, Syzstring,s));
3695	}
3696	else
3697	{
3698	forout=toVdStrictSequence(C[s][1],d,v, Syzstring,s);
3699	list resolutionofA=forout[9];
3700	list resolutionofC=forout[10];
3701	forout=delete(forout,10);
3702	forout=delete(forout,9);
3703	out[s]=list(forout);
3704	for (i=1; i<=size(resolutionofC); i++)
3705	{
3706	out[s][1][5][i+1]=resolutionofC[i];//save the resolutions
3707	out[s][1][1][i+1]=resolutionofA[i];
3708	}
3709	}
3710	out[s][2]=list(list(out[s][1][3][1]));
3711	out[s][2][2]=list(unitmat(ncols(out[s][1][3][1])));
3712	out[s][2][3]=list(out[s][1][3][1]);
3713	out[s][2][4]=list(list());
3714	out[s][2][5]=list(list());
3715	out[s][2][6]=list(out[s][1][7][1]);
3716	out[s][2][7]=list(out[s][2][6][1]);
3717	out[s][2][8]=list(list());
3718	list resolutionofD;
3719	list resolutionofF;
3720	for (i=s-1; i>=2; i--)
3721	{
3722	C[i][2][5]=out[i+1][1][1][1];
3723	forout=toVdStrictSequences(C[i],d,out[i+1][1][6][1],Syzstring,s);
3724	if (Syzstring=="Sres")
3725	{
3726	resolutionofD=forout[3];//save the resolutions
3727	resolutionofF=forout[4];
3728	forout=delete(forout,4);
3729	forout=delete(forout,3);
3730	}
3731	out[i]=forout;
3732	if(Syzstring=="Sres")
3733	{
3734	for (j=2; j<=size(out[i+1][1][1]); j++)
3735	{
3736	out[i][2][5][j]=out[i+1][1][1][j];
3737	}
3738	for (j=1; j<=size(resolutionofD);j++)
3739	{
3740	out[i][1][1][j+1]=resolutionofD[j];
3741	out[i][1][5][j+1]=resolutionofF[j];
3742	}
3743	}
3744	}
3745	out[1]=list(list());//initalize our list
3746	C[1][2][5]=out[2][1][1][1];
3747	/Compute the last V_d-strict seqeunce/
3748	if (Syzstring=="Vdres")
3749	{
3750	out[1][2]=toVdStrictSequence(C[1][2],d,out[2][1][6][1],Syzstring,s,"J_Agiv");
3751	}
3752	else
3753	{
3754	forout=toVdStrictSequence(C[1][2],d,out[2][1][6][1],Syzstring,s,"J_Agiv");
3755	out[1][2]=delete(forout,9);
3756	list resolutionofA2=forout[9];
3757	for (i=1; i<=size(out[2][1][1]); i++)
3758	{
3759	/put the modules for the resolutions in the right spot/
3760	out[1][2][5][i]=out[2][1][1][i];
3761	}
3762	for (i=1; i<=size(resolutionofA2); i++)
3763	{
3764	out[1][2][1][i+1]=resolutionofA2[i];
3765	}
3766	}
3767	out[1][1][3]=list(out[1][2][1][1]);
3768	out[1][1][5]=list(out[1][2][1][1]);
3769	out[1][1][4]=list(unitmat(ncols(out[1][1][3][1])));
3770	out[1][1][7]=list(out[1][2][6][1]);
3771	out[1][1][8]=list(out[1][2][6][1]);
3772	out[1][1][1]=list(list());
3773	out[1][1][2]=list(list());
3774	out[1][1][6]=list(list());
3775	if (Syzstring=="Sres")
3776	{
3777	for (i=1; i<=size(out[1][2][1]); i++)
3778	{
3779	out[1][1][3][i]=out[1][2][1][i];
3780	out[1][1][5][i]=out[1][2][1][i];
3781	}
3782	}
3783	list Hi;
3784	for (i=1; i<=size(out); i++)
3785	{
3786	Hi[i]=list(out[i][1][5][1],out[i][1][8][1]);
3787	}
3788	list outall;
3789	outall[1]=out;
3790	outall[2]=Hi;
3791	return(outall);
3792	}
3793
3794	////////////////////////////////////////////////////////////////////////////////////
3795
3796	static proc toVdStrictSequence(list C,int n,intvec v,string Syzstring,int si,list #)
3797	{
3798	/this is the Algorithm 3.11 in [W2]/
3799	int omitemptylist;
3800	int lengthofres=si+n-1;
3801	int i,j,logens;
3802	def B=basering;
3803	matrix bi=slimgb(transpose(C[5]));
3804	/* Computation of a V_d-strict Groebner basis of C[5]:
3805	-if Syzstring=="Vdres" this is done using the method of weighted homogenization
3806	(Prop. 3.9 [OT])
3807	-else we use the homogenized Weyl algebra for Groebner basis computations
3808	(Prop 9.9 [OT]),
3809	in this case we already compute someresolutions (Thm. 9.10 [OT]) to omit
3810	extra Groebner basis computations later on*/
3811	int nr,nc;
3812	intvec i1,i2;
3813	if (Syzstring=="Vdres")
3814	{
3815	if(size(#)==0)
3816	{
3817	matrix J_C=VdStrictGB(C[5],n,list(v));
3818	}
3819	else
3820	{
3821	matrix J_C=C[5];//C[5] is already a V_d-strict Groebner basis
3822	}
3823	}
3824	else
3825	{
3826	if (size(#)==0)
3827	{
3828	matrix MC=C[5];
3829	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2, v);
3830	setring HomWeyl;
3831	matrix J_C=fetch(B,MC);
3832	J_C=nHomogenize(J_C);
3833	/*computation of V_d-strict resolution of C[5]->needed for proc
3834	VdstrictDoubleComplexes*/
3835	def ringofSyz=Sres(transpose(J_C),lengthofres);
3836	setring ringofSyz;
3837	matrix J_C=transpose(matrix(RES[2]));
3838	J_C=subst(J_C,h,1);
3839	logens=ncols(J_C)+1;
3840	matrix zerom;
3841	list rofC;//will contain resolution of C
3842	for (i=3; i<=n+si+1; i++)
3843	{
3844	if (size(RES)>=i)
3845	{
3846	zerom=matrix(0,nrows(matrix(RES[i])),ncols(matrix(RES[i])));
3847	if (RES[i]!=zerom)
3848	{
3849	rofC[i-2]=(matrix(RES[i]));
3850
3851	if (i==3)
3852	{
3853	if (nrows(rofC[i-2])-logens+1!=nrows(J_C))
3854	{
3855	//build the resolution
3856	nr=nrows(J_C)+logens-1;
3857	nc=ncols(rofC[i-2]);
3858	rofC[i-2]=matrix(rofC[i-2],nr,nc);
3859	}
3860
3861	}
3862	if (i!=3)
3863	{
3864	if (nrows(rofC[i-2])-logens+1!=nrows(rofC[i-3]))
3865	{
3866	nr=nrows(rofC[i-3])+logens-1;
3867	nc=ncols(rofC[i-2]);
3868	rofC[i-2]=matrix(rofC[i-2],nr,nc);
3869	}
3870	}
3871	i1=intvec(logens..nrows(rofC[i-2]));
3872	i2=intvec(1..ncols(rofC[i-2]));
3873	rofC[i-2]=transpose(submat(rofC[i-2],i1,i2));
3874	logens=logens+ncols(rofC[i-2]);
3875	rofC[i-2]=subst(rofC[i-2],h,1);
3876	}
3877	else
3878	{
3879	rofC[i-2]=list();
3880	}
3881	}
3882	else
3883	{
3884	rofC[i-2]=list();
3885	}
3886	}
3887	if(size(rofC[1])==0)
3888	{
3889	omitemptylist=1;
3890	}
3891	setring B;
3892	matrix J_C=fetch(ringofSyz,J_C);
3893	if (omitemptylist!=1)
3894	{
3895	list rofC=fetch(ringofSyz,rofC);
3896	}
3897	omitemptylist=0;
3898	kill HomWeyl;
3899	kill ringofSyz;
3900	}
3901	else
3902	{
3903	matrix J_C=C[5];//C[5] is already a V_d-strict Groebner basis
3904	}
3905	}
3906	/* we compute a V_d-strict Groebner basis for C[3]*/
3907	matrix J_A=C[1];
3908	matrix f_CB=C[4];
3909	matrix f_ACB=transpose(concat(transpose(C[2]),transpose(f_CB)));
3910	matrix J_AC=divdr(f_ACB,C[3]);
3911	matrix P=matrixLift(J_AC * prodr(ncols(C[1]),ncols(C[5])) ,J_C);
3912	list storePi;
3913	matrix Pi[1][ncols(J_AC)];
3914	for (i=1; i<=nrows(J_C); i++)
3915	{
3916	for (j=1; j<=nrows(J_AC);j++)
3917	{
3918	Pi=Pi+P[i,j]*submat(J_AC,j,intvec(1..ncols(J_AC)));
3919	}
3920	storePi[i]=Pi;
3921	Pi=0;
3922	}
3923	/we compute the shift vector for C[1]/
3924	intvec m_a;
3925	list findMin;
3926	int comMin;
3927	for (i=1; i<=ncols(J_A); i++)
3928	{
3929	for (j=1; j<=size(storePi);j++)
3930	{
3931	if (storePi[j][1,i]!=0)
3932	{
3933	comMin=VdDeg(storePi[j]*prodr(ncols(J_A),ncols(C[5])),n,v);
3934	comMin=comMin-VdDeg(storePi[j][1,i],n,intvec(0));
3935	findMin[size(findMin)+1]=comMin;
3936	}
3937	}
3938	if (size(findMin)!=0)
3939	{
3940	m_a[i]=Min(findMin);
3941	findMin=list();
3942	}
3943	else
3944	{
3945	m_a[i]=0;
3946	}
3947	}
3948	matrix zero[ncols(J_A)][ncols(J_C)];
3949	matrix g_AB=concat(unitmat(ncols(J_A)),zero);
3950	matrix g_BC= transpose(concat(transpose(zero),transpose(unitmat(ncols(J_C)))));
3951	intvec m_b=m_a,v;
3952	/* computation of a V_d-strict Groebner basis of C[1] (and resolution if
3953	Syzstring=='Vdres') */
3954	if (Syzstring=="Vdres")
3955	{
3956	J_A=VdStrictGB(J_A,n,m_a);
3957	}
3958	else
3959	{
3960	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2, m_a);
3961	setring HomWeyl;
3962	matrix J_A=fetch(B,J_A);
3963	J_A=nHomogenize(J_A);
3964	def ringofSyz=Sres(transpose(J_A),lengthofres);
3965	setring ringofSyz;
3966	matrix J_A=transpose(matrix(RES[2]));
3967	matrix zerom;
3968	J_A=subst(J_A,h,1);
3969	logens=ncols(J_A)+1;
3970	list rofA;
3971	for (i=3; i<=n+si+1; i++)
3972	{
3973	if (size(RES)>=i)
3974	{
3975	zerom=matrix(0,nrows(matrix(RES[i])),ncols(matrix(RES[i])));
3976	if (RES[i]!=zerom)
3977	{
3978	rofA[i-2]=matrix(RES[i]);// resolution for C[1]
3979	if (i==3)
3980	{
3981	if (nrows(rofA[i-2])-logens+1!=nrows(J_A))
3982	{
3983	nr=nrows(J_A)+logens-1;
3984	nc=ncols(rofA[i-2]);
3985	rofA[i-2]=matrix(rofA[i-2],nr,nc);
3986	}
3987	}
3988	if (i!=3)
3989	{
3990	if (nrows(rofA[i-2])-logens+1!=nrows(rofA[i-3]))
3991	{
3992	nr=nrows(rofA[i-3])+logens-1;
3993	nc=ncols(rofA[i-2]);
3994	rofA[i-2]=matrix(rofA[i-2],nr,nc);
3995	}
3996	}
3997	i1=intvec(logens..nrows(rofA[i-2]));
3998	i2=intvec(1..ncols(rofA[i-2]));
3999	rofA[i-2]=transpose(submat(rofA[i-2],i1,i2));
4000	logens=logens+ncols(rofA[i-2]);
4001	rofA[i-2]=subst(rofA[i-2],h,1);
4002	}
4003	else
4004	{
4005	rofA[i-2]=list();
4006	}
4007	}
4008	else
4009	{
4010	rofA[i-2]=list();
4011	}
4012	}
4013	if(size(rofA[1])==0)
4014	{
4015	omitemptylist=1;
4016	}
4017	setring B;
4018	J_A=fetch(ringofSyz,J_A);
4019	if (omitemptylist!=1)
4020	{
4021	list rofA=fetch(ringofSyz,rofA);
4022	}
4023	omitemptylist=0;
4024	kill HomWeyl;
4025	kill ringofSyz;
4026	}
4027	J_AC=transpose(storePi[1]);
4028	for (i=2; i<= size(storePi); i++)
4029	{
4030	J_AC=concat(J_AC, transpose(storePi[i]));
4031	}
4032	J_AC=transpose(concat(transpose(matrix(J_A,nrows(J_A),nrows(J_AC))),J_AC));
4033	list Vdstrict=(list(J_A),list(g_AB),list(J_AC),list(g_BC),list(J_C),list(m_a));
4034	Vdstrict[7]=list(m_b);
4035	Vdstrict[8]=list(v);
4036	if(Syzstring=="Sres")
4037	{
4038	Vdstrict[9]=rofA;
4039	if(size(#)==0)
4040	{
4041	Vdstrict[10]=rofC;
4042	}
4043	}
4044	return (Vdstrict);
4045	}
4046
4047	////////////////////////////////////////////////////////////////////////////////////
4048
4049	static proc toVdStrictSequences (list L,int d,intvec v,string Syzstring,int sizeL)
4050	{
4051	/* this is Argorithm 3.11 combined with Lemma 4.2 in [W2] for two short exact
4052	pieces.
4053	We asume that we are given two sequences of the form coker(L[i][1])->
4054	coker(L[i][3])->coker(L[i][5]) with differentials L[i][2] and L[i][4] such
4055	that L[1][3]=L[2][1].We are going to transform them to V_d-strict sequences
4056	J_D->J_A->J_F and J_A->J_B->J_C*/
4057	int omitemptylist;
4058	int lengthofres=sizeL+d-1;
4059	int logens;
4060	def B=basering;
4061	matrix J_F=L[1][5];
4062	matrix J_D=L[1][1];
4063	matrix f_FA=L[1][4];
4064	/*We find new presentations coker(J_DF) and coker(J_DFC) for L[1][4]=L[2][1]
4065	and L[2][4],resp. such that ncols(L[i][1])+ncols(L[i][5])=ncols(L[i][3]) */
4066	matrix f_DFA=transpose(concat(transpose(L[1][2]),transpose(f_FA)));
4067	matrix J_DF=divdr(f_DFA,L[1][3]);//coker(J_DF) is isomorphic to coker(L[2][1]);
4068	matrix J_C=L[2][5];
4069	matrix f_CB=L[2][4];
4070	matrix f_DFCB=transpose(concat(transpose(f_DFA*L[2][2]),transpose(f_CB)));
4071	matrix J_DFC=divdr(f_DFCB,L[2][3]);//coker(J_DFC) are coker(L[2][3)]) isomorphic
4072	/* find a shift vector on the range of J_F such that the first sequence is
4073	exact*/
4074	matrix P=matrixLift(J_DFC*prodr(ncols(J_DF),ncols(L[2][5])),J_C);
4075	list storePi;
4076	matrix Pi[1][ncols(J_DFC)];
4077	int i; int j;
4078	for (i=1; i<=nrows(J_C); i++)
4079	{
4080	for (j=1; j<=nrows(J_DFC);j++)
4081	{
4082	Pi=Pi+P[i,j]*submat(J_DFC,j,intvec(1..ncols(J_DFC)));
4083	}
4084	storePi[i]=Pi;
4085	Pi=0;
4086	}
4087	intvec m_a;
4088	list findMin;
4089	list noMin;
4090	int comMin;
4091	int nr,nc;
4092	intvec i1,i2;
4093	for (i=1; i<=ncols(J_DF); i++)
4094	{
4095	for (j=1; j<=size(storePi);j++)
4096	{
4097	if (storePi[j][1,i]!=0)
4098	{
4099	comMin=VdDeg(storePi[j]*prodr(ncols(J_DF),ncols(J_C)),d,v);
4100	comMin=comMin-VdDeg(storePi[j][1,i],d,intvec(0));
4101	findMin[size(findMin)+1]=comMin;
4102	}
4103	}
4104	if (size(findMin)!=0)
4105	{
4106	m_a[i]=Min(findMin);// shift vector for L[2][1]
4107	findMin=list();
4108	noMin[i]=0;
4109	}
4110	else
4111	{
4112	noMin[i]=1;
4113	}
4114	}
4115	if (size(m_a) < ncols(J_DF))
4116	{
4117	m_a[ncols(J_DF)]=0;
4118	}
4119	intvec m_f=m_a[ncols(J_D)+1..size(m_a)];
4120	/* Computation of a V_d-strict Groebner basis of J_F=L[1][5]:
4121	if Syzstring=="Vdres" this is done using the method of weighted homogenization
4122	(Prop. 3.9 [OT])
4123	else we use the homogenized Weyl algerba for Groebner basis computations
4124	(Prop 9.9 [OT]), in this case we already compute resolutions
4125	(Thm. 9.10 in [OT]) to omit extra Groebner basis computations later on*/
4126	if (Syzstring=="Vdres")
4127	{
4128	J_F=VdStrictGB(J_F,d,m_f);
4129	}
4130	else
4131	{
4132	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2, m_f);
4133	setring HomWeyl;
4134	matrix J_F=fetch(B,J_F);
4135	J_F=nHomogenize(J_F);
4136	def ringofSyz=Sres(transpose(J_F),lengthofres);
4137	setring ringofSyz;
4138	matrix J_F=transpose(matrix(RES[2]));
4139	J_F=subst(J_F,h,1);
4140	logens=ncols(J_F)+1;
4141	list rofF;
4142	for (i=3; i<=d+sizeL+1; i++)
4143	{
4144	if (size(RES)>=i)
4145	{
4146	if (RES[i]!=matrix(0,nrows(matrix(RES[i])),ncols(matrix(RES[i]))))
4147	{
4148	rofF[i-2]=(matrix(RES[i]));// resolution for J_F
4149	if (i==3)
4150	{
4151	if (nrows(rofF[i-2])-logens+1!=nrows(J_F))
4152	{
4153	nr=nrows(J_F)+logens-1;
4154	nc=ncols(rofF[i-2]);
4155	rofF[i-2]=matrix(rofF[i-2],nr,nc);
4156	}
4157	}
4158	if (i!=3)
4159	{
4160	if (nrows(rofF[i-2])-logens+1!=nrows(rofF[i-3]))
4161	{
4162	nr=nrows(rofF[i-3])+logens-1;
4163	rofF[i-2]=matrix(rofF[i-2],nr,ncols(rofF[i-2]));
4164	}
4165	}
4166	i1=intvec(logens..nrows(rofF[i-2]));
4167	i2=intvec(1..ncols(rofF[i-2]));
4168	rofF[i-2]=transpose(submat(rofF[i-2],i1,i2));
4169	logens=logens+ncols(rofF[i-2]);
4170	rofF[i-2]=subst(rofF[i-2],h,1);
4171	}
4172	else
4173	{
4174	rofF[i-2]=list();
4175	}
4176	}
4177	else
4178	{
4179	rofF[i-2]=list();
4180	}
4181	}
4182	if(size(rofF[1])==0)
4183	{
4184	omitemptylist=1;
4185	}
4186	setring B;
4187	J_F=fetch(ringofSyz,J_F);
4188	if (omitemptylist!=1)
4189	{
4190	list rofF=fetch(ringofSyz,rofF);
4191	}
4192	omitemptylist=0;
4193	kill HomWeyl;
4194	kill ringofSyz;
4195	}
4196	/find shift vectors on the range of J_D/
4197	P=matrixLift(J_DF * prodr(ncols(L[1][1]),ncols(L[1][5])) ,J_F);
4198	list storePinew;
4199	matrix Pidf[1][ncols(J_DF)];
4200	for (i=1; i<=nrows(J_F); i++)
4201	{
4202	for (j=1; j<=nrows(J_DF);j++)
4203	{
4204	Pidf=Pidf+P[i,j]*submat(J_DF,j,intvec(1..ncols(J_DF)));
4205	}
4206	storePinew[i]=Pidf;
4207	Pidf=0;
4208	}
4209	intvec m_d;
4210	for (i=1; i<=ncols(J_D); i++)
4211	{
4212	for (j=1; j<=size(storePinew);j++)
4213	{
4214	if (storePinew[j][1,i]!=0)
4215	{
4216	comMin=VdDeg(storePinew[j]*prodr(ncols(J_D),ncols(L[1][5])),d,m_f);
4217	comMin=comMin-VdDeg(storePinew[j][1,i],d,intvec(0));
4218	findMin[size(findMin)+1]=comMin;
4219	}
4220	}
4221	if (size(findMin)!=0)
4222	{
4223	if (noMin[i]==0)
4224	{
4225	m_d[i]=Min(insert(findMin,m_a[i]));
4226	m_a[i]=m_d[i];
4227	}
4228	else
4229	{
4230	m_d[i]=Min(findMin);
4231	m_a[i]=m_d[i];
4232	}
4233	}
4234	else
4235	{
4236	m_d[i]=m_a[i];
4237	}
4238	findMin=list();
4239	}
4240	/* compute a V_d-strict Groebner basis (and resolution of J_D if
4241	Syzstring!='Vdres') for J_D*/
4242	if (Syzstring=="Vdres")
4243	{
4244	J_D=VdStrictGB(J_D,d,m_d);
4245	}
4246	else
4247	{
4248	def HomWeyl=makeHomogenizedWeyl(nvars(B) div 2, m_d);
4249	setring HomWeyl;
4250	matrix J_D=fetch(B,J_D);
4251	J_D=nHomogenize(J_D);
4252	def ringofSyz=Sres(transpose(J_D),lengthofres);
4253	setring ringofSyz;
4254	matrix J_D=transpose(matrix(RES[2]));
4255	J_D=subst(J_D,h,1);
4256	logens=ncols(J_D)+1;
4257	list rofD;
4258	for (i=3; i<=d+sizeL+1; i++)
4259	{
4260	if (size(RES)>=i)
4261	{
4262	if (RES[i]!=matrix(0,nrows(matrix(RES[i])),ncols(matrix(RES[i]))))
4263	{
4264	rofD[i-2]=(matrix(RES[i]));// resolution for J_D
4265	if (i==3)
4266	{
4267	if (nrows(rofD[i-2])-logens+1!=nrows(J_D))
4268	{
4269	nr=nrows(J_D)+logens-1;
4270	rofD[i-2]=matrix(rofD[i-2],nr,ncols(rofD[i-2]));
4271	}
4272	}
4273	if (i!=3)
4274	{
4275	if (nrows(rofD[i-2])-logens+1!=nrows(rofD[i-3]))
4276	{
4277	nr=nrows(rofD[i-3])+logens-1;
4278	rofD[i-2]=matrix(rofD[i-2],nr,ncols(rofD[i-2]));
4279	}
4280	}
4281	i1=intvec(logens..nrows(rofD[i-2]));
4282	i2=intvec(1..ncols(rofD[i-2]));
4283	rofD[i-2]=transpose(submat(rofD[i-2],i1,i2));
4284	logens=logens+ncols(rofD[i-2]);
4285	rofD[i-2]=subst(rofD[i-2],h,1);
4286	}
4287	else
4288	{
4289	rofD[i-2]=list();
4290	}
4291	}
4292	else
4293	{
4294	rofD[i-2]=list();
4295	}
4296	}
4297	if(size(rofD[1])==0)
4298	{
4299	omitemptylist=1;
4300	}
4301	setring B;
4302	J_D=fetch(ringofSyz,J_D);
4303	if (omitemptylist!=1)
4304	{
4305	list rofD=fetch(ringofSyz,rofD);
4306	}
4307	omitemptylist=0;
4308	kill HomWeyl;
4309	kill ringofSyz;
4310	}
4311	/* compute new matrices for J_A and J_B such that their rows form a V_d-strict
4312	Groebner basis and nrows(J_A)=nrows(J_D)+nrows(J_F) and
4313	nrows(J_B)=nrows(J_A)+nrows(J_C)*/
4314	J_DF=transpose(storePinew[1]);
4315	for (i=2; i<=nrows(J_F); i++)
4316	{
4317	J_DF=concat(J_DF,transpose(storePinew[i]));
4318	}
4319	J_DF=transpose(concat(transpose(matrix(J_D,nrows(J_D),nrows(J_DF))),J_DF));
4320	J_DFC=transpose(storePi[1]);
4321	for (i=2; i<=nrows(J_C); i++)
4322	{
4323	J_DFC=concat(J_DFC,transpose(storePi[i]));
4324	}
4325	J_DFC=transpose(concat(transpose(matrix(J_DF,nrows(J_DF),nrows(J_DFC))),J_DFC));
4326	intvec m_b=m_a,v;
4327	matrix zero[ncols(J_D)][ncols(J_F)];
4328	matrix g_DA=concat(unitmat(ncols(J_D)),zero);
4329	matrix g_AF=transpose(concat(transpose(zero),unitmat(ncols(J_F))));
4330	matrix zero1[ncols(J_DF)][ncols(J_C)];
4331	matrix g_AB=concat(unitmat(ncols(J_DF)),zero1);
4332	matrix g_BC=transpose(concat(transpose(zero1),unitmat(ncols(J_C))));
4333	list out;
4334	out[1]=list(list(J_D),list(g_DA),list(J_DF),list(g_AF),list(J_F));
4335	out[1]=out[1]+list(list(m_d),list(m_a),list(m_f));
4336	out[2]=list(list(J_DF),list(g_AB),list(J_DFC),list(g_BC),list(J_C));
4337	out[2]=out[2]+list(list(m_a),list(m_b),list(v));
4338	if (Syzstring=="Sres")
4339	{
4340	out[3]=rofD;
4341	out[4]=rofF;
4342	}
4343	return(out);
4344	}
4345
4346	////////////////////////////////////////////////////////////////////////////////////
4347
4348	static proc VdStrictDoubleComplexes(list L,int d,string Syzstring)
4349	{
4350	/* We compute V_d-strict resolutions over the V_d-strict short exact pieces from
4351	the procedure shortExactPiecesToVdStrict.
4352	We use Algorithms 3.14 and 3.15 in [W2]*/
4353	int i,k,c,j,l,totaldeg,comparedegs,SBcom,verk;
4354	intvec fordegs;
4355	intvec n_b,i1,i2;
4356	matrix rem,forML,subm,zerom,unitm,subm2;
4357	matrix J_B;
4358	list store;
4359	int t=size(L)+d;
4360	int vd1,vd2,nr,nc;
4361	def B=basering;
4362	int n=nvars(B) div 2;
4363	intvec v;
4364	list forhW;
4365	if (Syzstring=="Sres")
4366	{
4367	/*we already computed some of the resolutions in the procedure
4368	shortExactPiecesToVdStrict*/
4369	matrix Pold,Pnew,Picombined; intvec containsndeg; matrix Pinew;
4370	for (k=1; k<=(size(L)+d-1); k++)
4371	{
4372	L[1][1][1][k+1]=list();
4373	L[1][1][2][k+1]=list();
4374	L[1][1][6][k+1]=list();
4375	}
4376	L[1][1][6][size(L)+d+1]=list();
4377	matrix mem;
4378	for (i=2; i<=d+size(L)+1; i++)
4379	{;
4380	v=0;
4381	if(size(L[1][1][3][i-1])!=0)
4382	{
4383	if(i!=d+size(L)+1)
4384	{
4385	/horizontal differential/
4386	L[1][1][4][i-1]=unitmat(nrows(L[1][1][3][i-1]));
4387	}
4388	for (j=1; j<=nrows(L[1][1][3][i-1]); j++)
4389	{
4390	mem=submat(L[1][1][3][i-1],j,intvec(1..ncols(L[1][1][3][i-1])));
4391	v[j]=VdDeg(mem,d,L[1][1][7][i-1]);
4392	}
4393	L[1][1][7][i]=v;//new shift vector
4394	L[1][1][8][i]=v;
4395	L[1][2][6][i]=v;
4396	}
4397	else
4398	{
4399	if (i!=d+size(L)+1)
4400	{
4401	L[1][1][4][i-1]=list();
4402	}
4403	L[1][1][7][i]=list();
4404	L[1][1][8][i]=list();
4405	L[1][2][6][i]=list();
4406	}
4407	}
4408	if (size(L[1][1][3][d+size(L)])!=0)
4409	{
4410	/horizontal differential/
4411	L[1][1][4][d+size(L)]=unitmat(nrows(L[1][1][3][d+size(L)]));
4412	}
4413	else
4414	{
4415	L[1][1][4][d+size(L)]=list();
4416	}
4417	for (k=1; k<size(L); k++)
4418	{
4419	/* We build a V_d-strict resolution for coker(L[k][2][1][1])->
4420	coker(L[k][2][3][1])->coker(L[k][2][5][1]) using the resolution
4421	obtained for coker(L[k][1][3][1]).
4422	L[k][2][i][j] will be the jth module in the resolution of L[k][2][i][1]
4423	for i=1,3,5.
4424	L[k][2][i+5][j] will be the jth shift vector in the resolution of
4425	L[k][2][i][1](this holds also for the case Syzstring=="Vdres")*/
4426	for (i=2; i<=d+size(L); i++)
4427	{
4428	v=0;
4429	if (size(L[k][2][5][i-1])!=0)
4430	{
4431	for (j=1; j<=nrows(L[k][2][5][i-1]); j++)
4432	{
4433	i1=intvec(1..ncols(L[k][2][5][i-1]));
4434	mem=submat(L[k][2][5][i-1],j,i1);
4435	v[j]=VdDeg(mem,d,L[k][2][8][i-1]);
4436	}
4437	/next shift vector in th resolution of coker(L[k][2][5][1])/
4438	L[k][2][8][i]=v;
4439	}
4440	else
4441	{
4442	L[k][2][8][i]=list();
4443	}
4444	/* we build step by step a resolution for coker(L[k][2][5][1]) using
4445	the resolutions of coker(L[k][2][1][1]) and coker(L[k][2][5][1])*/
4446	if (size(L[k][2][5][i])!=0)
4447	{
4448	if (size(L[k][2][1][i])!=0 or size(L[k][2][1][i-1])!=0)
4449	{
4450	L[k][2][3][i]=transpose(syz(transpose(L[k][2][3][i-1])));
4451	nr= nrows(L[k][2][1][i-1]);
4452	nc=ncols(L[k][2][5][i]);
4453	Pold=matrixLift(L[k][2][3][i]*prodr(nr,nc), L[k][2][5][i]);
4454	matrix Pi[1][ncols(L[k][2][3][i])];
4455	for (l=1; l<=nrows(L[k][2][5][i]); l++)
4456	{
4457	for (j=1; j<=nrows(L[k][2][3][i]); j++)
4458	{
4459	i2=intvec(1..ncols(L[k][2][3][i]));
4460	Pi=Pi+Pold[l,j]*submat(L[k][2][3][i],j,i2);
4461	}
4462	if (l==1)
4463	{
4464	Picombined=transpose(Pi);
4465	}
4466	else
4467	{
4468	Picombined=concat(Picombined,transpose(Pi));
4469	}
4470	Pi=0;
4471	}
4472	kill Pi;
4473	Picombined=transpose(Picombined);
4474	if (size(L[k][2][1][i])!=0)
4475	{
4476	if (i==2)
4477	{
4478	containsndeg=(0:ncols(L[k][2][1][1]));
4479	}
4480	containsndeg=nDeg(L[k][2][1][i-1],containsndeg);
4481	forhW=list(L[k][2][6][i],containsndeg);
4482	def HomWeyl=makeHomogenizedWeyl(n,forhW);
4483	setring HomWeyl;
4484	list L=fetch(B,L);
4485	matrix M=L[k][2][1][i];
4486	module Mmod;
4487	list forM=nHomogenize(M,containsndeg,1);
4488	M=forM[1];
4489	totaldeg=forM[2];
4490	kill forM;
4491	matrix Maorig=fetch(B,Picombined);
4492	matrix Ma=submat(Maorig,(1..nrows(Maorig)),(1..ncols(M)));
4493	matrix mem,subm,zerom;
4494	matrix Pinew;
4495	M=transpose(M);
4496	SBcom=0;
4497	for (l=1; l<=nrows(Ma); l++)
4498	{
4499	zerom=matrix(0,1,(ncols(Maorig)-ncols(Ma)));
4500	i1=(ncols(Ma)+1..ncols(Maorig));
4501	if (submat(Maorig,l,i1)==zerom)
4502	{
4503	for (cc=1; cc<=ncols(Ma); cc++)
4504	{
4505	Maorig[l,cc]=0;
4506	}
4507	}
4508	i2=(ncols(Ma)+1..ncols(Maorig));
4509	i1=(1..ncols(Ma));
4510	if (VdDeg(submat(Maorig,l,i1),d,L[k][2][6][i])>
4511	VdDeg(submat(Maorig,l,i2),d,L[k][2][8][i]) and
4512	submat(Maorig,l,i1)!=matrix(0,1,ncols(Ma)))
4513	{
4514	/*V_d-Grad is to big--> we make it smaller using
4515	Vdnormal form computations*/
4516	if (SBcom==0)
4517	{
4518	Mmod=slimgb(M);
4519	M=Mmod;
4520	SBcom=1;
4521	}
4522	//print("Reduzierung des V_d-Grades(Stelle1)");
4523	i2=(ncols(Ma)+1..ncols(Maorig));
4524	vd1=VdDeg(submat(Maorig,l,i2),d,L[k][2][8][i]);
4525	mem=submat(Ma,l,(1..ncols(Ma)));
4526	mem=nHomogenize(mem,containsndeg);
4527	mem=h^totaldeg*mem;
4528	mem=transpose(mem);
4529	mem=reduce(mem,Mod);//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
4530	matrix jt=transpose(subst(mem,h,1));
4531	setring B;
4532	matrix jt=fetch(HomWeyl,jt);
4533	matrix need=fetch(HomWeyl,Maorig);
4534	need=submat(need,l,(1..ncols(need)));
4535	i1=L[k][2][6][i];
4536	i2=L[k][2][8][i];
4537	jt=VdNormalForm(need,L[k][2][1][i],d,i1,i2);
4538	setring HomWeyl;
4539	mem=fetch(B,jt);
4540	mem=transpose(mem);
4541	if (l==1)
4542	{
4543	Pinew=mem;
4544	}
4545	else
4546	{
4547	Pinew=concat(Pinew,mem);
4548	}
4549	vd2=VdDeg(transpose(mem),d,L[k][2][6][i]);
4550	if (vd2>vd1 and mem!=matrix(0,nrows(mem),ncols(mem)))
4551	{//should not happen!!
4552	//print("Reduzierung fehlgeschlagen!!(Stelle1)");
4553	}
4554	}
4555	else
4556	{
4557	if (l==1)
4558	{
4559	Pinew=transpose(submat(Ma,l,(1..ncols(Ma))));
4560	}
4561	else
4562	{
4563	subm=transpose(submat(Ma,l,(1..ncols(Ma))));
4564	Pinew=concat(Pinew,subm);
4565	}
4566	}
4567	}
4568	Pinew=subst(Pinew,h,1);
4569	Pinew=transpose(Pinew);
4570	setring B;
4571	Pinew=fetch(HomWeyl,Pinew);
4572	kill HomWeyl;
4573	L[k][2][3][i]=concat(Pinew,L[k][2][5][i]);
4574	subm=transpose(L[k][2][3][i]);
4575	subm=concat(transpose(L[k][2][1][i]),subm);
4576	L[k][2][3][i]=transpose(subm);
4577	}
4578	else
4579	{
4580	L[k][2][3][i]=Picombined;
4581	}
4582	L[k+1][1][1][i]=L[k][2][5][i];
4583	nr=nrows(L[k][2][1][i-1]);
4584	nc=ncols(L[k][2][5][i]);
4585	L[k][2][2][i]=concat(unitmat(nr),matrix(0,nr,nc));
4586	L[k][2][4][i]=prodr(nrows(L[k][2][1][i-1]),nc);
4587	v=L[k][2][6][i],L[k][2][8][i];
4588	L[k][2][7][i]=v;
4589	L[k+1][1][6][i]=L[k][2][8][i];
4590	}
4591	else
4592	{
4593	L[k][2][3][i]=L[k][2][5][i];
4594	L[k][2][2][i]=list();
4595	L[k][2][7][i]=L[k][2][8][i];
4596	L[k][2][4][i]=unitmat(nrows(L[k][2][5][i-1]));
4597	L[k+1][1][6][i]=L[k][2][8][i];
4598	L[k+1][1][1][i]=L[k][2][5][i];
4599	}
4600	}
4601	else
4602	{
4603	if (size(L[k][2][1][i])!=0)
4604	{
4605	if (size(L[k][2][5][i-1])!=0)
4606	{
4607	nr=nrows(L[k][2][5][i-1]);
4608	L[k][2][3][i]=concat(L[k][2][1][i],matrix(0,1,nr));
4609	v=L[k][2][6][i],L[k][2][8][i];
4610	L[k][2][7][i]=v;
4611	nc=nrows(L[k][2][1][i-1]);
4612	L[k][2][2][i]=concat(unitmat(nc),matrix(0,nc,nr));
4613	L[k][2][4][i]=prodr(nrows(L[k][2][1][i-1]),nr);
4614	}
4615	else
4616	{
4617	L[k][2][3][i]=L[k][2][1][i];
4618	L[k][2][7][i]=L[k][2][6][i];
4619	L[k][2][2][i]=unitmat(nrows(L[k][2][1][i-1]));
4620	L[k][2][4][i]=list();
4621	}
4622	L[k+1][1][1][i]=L[k][2][5][i];
4623	L[k+1][1][6][i]=L[k][2][8][i];
4624	}
4625	else
4626	{
4627	L[k][2][3][i]=list();
4628	if (size(L[k][2][6][i])!=0)
4629	{
4630	if (size(L[k][2][8][i])!=0)
4631	{
4632	v=L[k][2][6][i],L[k][2][8][i];
4633	L[k][2][7][i]=v;
4634	nr=nrows(L[k][2][1][i-1]);
4635	nc=nrows(L[k][2][5][i-1]);
4636	L[k][2][2][i]=concat(unitmat(nc),matrix(0,nr,nc));
4637	L[k][2][4][i]=prodr(nr,nrows(L[k][2][5][i-1]));
4638	}
4639	else
4640	{
4641	L[k][2][7][i]=L[k][2][6][i];
4642	L[k][2][2][i]=unitmat(nrows(L[k][2][1][i-1]));
4643	L[k][2][4][i]=list();
4644	}
4645	}
4646	else
4647	{
4648	if (size(L[k][2][8][i])!=0)
4649	{
4650	L[k][2][7][i]=L[k][2][8][i];
4651	L[k][2][2][i]=list();
4652	L[k][2][4][i]=unitmat(nrows(L[k][2][5][i-1]));
4653	}
4654	else
4655	{
4656	L[k][2][7][i]=list();
4657	L[k][2][2][i]=list();
4658	L[k][2][4][i]=list();
4659	}
4660	}
4661	L[k+1][1][1][i]=L[k][2][5][i];
4662	L[k+1][1][6][i]=L[k][2][8][i];
4663	}
4664	}
4665	}
4666	i=d+size(L)+1;
4667	v=0;
4668	if (size(L[k][2][5][i-1])!=0)
4669	{
4670	for (j=1; j<=nrows(L[k][2][5][i-1]); j++)
4671	{
4672	mem=submat(L[k][2][5][i-1],j,intvec(1..ncols(L[k][2][5][i-1])));
4673	v[j]=VdDeg(mem,d,L[k][2][8][i-1]);
4674	}
4675	L[k][2][8][i]=v;
4676	if (size(L[k][2][6][i])!=0)
4677	{
4678	v=L[k][2][6][i],L[k][2][8][i];
4679	L[k][2][7][i]=v;
4680	}
4681	else
4682	{
4683	L[k][2][7][i]=L[k][2][8][i];
4684	}
4685	}
4686	else
4687	{
4688	L[k][2][8][i]=list();
4689	L[k][2][7][i]=L[k][2][6][i];
4690	}
4691	L[k+1][1][6][i]=L[k][2][8][i];
4692	/* now we build V_d-strict resolutions for the sequences
4693	coker(L[k+1][1][1][1])->coker(L[k+1][1][3][1])->coker(L[k+1][1][5][i])
4694	using the resolutions for coker(L[k][2][5][1]) we just obtained
4695	(works exactly the same as above)*/
4696	for (i=2; i<=d+size(L); i++)
4697	{
4698	v=0;
4699	if (size(L[k+1][1][5][i-1])!=0)
4700	{
4701	for (j=1; j<=nrows(L[k+1][1][5][i-1]); j++)
4702	{
4703	i1=intvec(1..ncols(L[k+1][1][5][i-1]));
4704	mem=submat(L[k+1][1][5][i-1],j,i1);
4705	v[j]=VdDeg(mem,d,L[k+1][1][8][i-1]);
4706	}
4707	L[k+1][1][8][i]=v;
4708	}
4709	else
4710	{
4711	L[k+1][1][8][i]=list();
4712	}
4713	if (size(L[k+1][1][5][i])!=0)
4714	{
4715	if (size(L[k+1][1][1][i])!=0 or size(L[k+1][1][1][i-1])!=0)
4716	{
4717	L[k+1][1][3][i]=transpose(syz(transpose(L[k+1][1][3][i-1])));
4718	nr=nrows(L[k+1][1][1][i-1]);
4719	nc=ncols(L[k+1][1][5][i]);
4720	Pold=matrixLift(L[k+1][1][3][i]*prodr(nr,nc),L[k+1][1][5][i]);
4721	matrix Pi[1][ncols(L[k+1][1][3][i])];
4722	for (l=1; l<=nrows(L[k+1][1][5][i]); l++)
4723	{
4724	for (j=1; j<=nrows(L[k+1][1][3][i]); j++)
4725	{
4726	i2=intvec(1..ncols(L[k+1][1][3][i]));
4727	Pi=Pi+Pold[l,j]*submat(L[k+1][1][3][i],j,i2);
4728	}
4729	if (l==1)
4730	{
4731	Picombined=transpose(Pi);
4732	}
4733	else
4734	{
4735	Picombined=concat(Picombined,transpose(Pi));
4736	}
4737	Pi=0;
4738	}
4739	kill Pi;
4740	Picombined=transpose(Picombined);
4741	if(size(L[k+1][1][1][i])!=0)
4742	{
4743	if (i==2)
4744	{
4745	containsndeg=(0:ncols(L[k+1][1][1][i-1]));
4746	}
4747	containsndeg=nDeg(L[k+1][1][1][i-1],containsndeg);
4748	forhW=list(L[k+1][1][6][i], containsndeg);
4749	def HomWeyl=makeHomogenizedWeyl(n,forhW);
4750	setring HomWeyl;
4751	list L=fetch(B,L);
4752	matrix M=L[k+1][1][1][i];
4753	module Mmod;
4754	list forM=nHomogenize(M,containsndeg,1);
4755	M=forM[1];
4756	totaldeg=forM[2];
4757	kill forM;
4758	matrix Maorig=fetch(B,Picombined);
4759	matrix Ma=submat(Maorig,(1..nrows(Maorig)),(1..ncols(M)));
4760	Ma=nHomogenize(Ma,containsndeg);
4761	matrix mem,subm,zerom,subm2;
4762	matrix Pinew;
4763	M=transpose(M);
4764	SBcom=0;
4765	for (l=1; l<=nrows(Ma); l++)
4766	{
4767	i2=(ncols(Ma)+1..ncols(Maorig));
4768	nc=ncols(Maorig)-ncols(Ma);
4769	if (submat(Maorig,l,i2)==matrix(0,1,nc))
4770	{
4771	for (cc=1; cc<=ncols(Ma); cc++)
4772	{
4773	Maorig[l,cc]=0;
4774	}
4775	}
4776	i1=(1..ncols(Ma));
4777	i2=L[k+1][1][8][i];
4778	subm=submat(Maorig,l,i1);
4779	subm2=submat(Maorig,l,(ncols(Ma)+1..ncols(Maorig)));
4780	if (VdDeg(subm,d,L[k+1][1][6][i])>VdDeg(subm2,d,i2)
4781	and subm!=matrix(0,1,ncols(Ma)))
4782	{
4783	//print("Reduzierung des Vd-Grades (Stelle2)");
4784	if (SBcom==0)
4785	{
4786	Mmod=slimgb(M);
4787	M=Mmod;
4788	SBcom=1;
4789	}
4790	vd1=VdDeg(subm2,d,L[k+1][1][8][i]);
4791	mem=submat(Ma,l,(1..ncols(Ma)));
4792	mem=nHomogenize(mem,containsndeg);
4793	mem=h^totaldeg*mem;
4794	mem=transpose(mem);
4795	mem=reduce(mem,Mmod);
4796	if (l==1)
4797	{
4798	Pinew=mem;
4799	}
4800	else
4801	{
4802	Pinew=concat(Pinew,mem);
4803	}
4804	vd2=VdDeg(transpose(mem),d,L[k+1][1][6][i]);
4805	if (vd2>vd1 and mem!=matrix(0,nrows(mem),ncols(mem)))
4806	{//should not happen
4807	//print("Reduzierung fehlgeschlagen!!!!(Stelle2)");
4808	}
4809	}
4810	else
4811	{
4812	if (l==1)
4813	{
4814	Pinew=transpose(submat(Ma,l,(1..ncols(Ma))));
4815	}
4816	else
4817	{
4818	subm=transpose(submat(Ma,l,(1..ncols(Ma))));
4819	Pinew=concat(Pinew,subm);
4820	}
4821	}
4822	}
4823	Pinew=subst(Pinew,h,1);
4824	Pinew=transpose(Pinew);
4825	setring B;
4826	Pinew=fetch(HomWeyl,Pinew);
4827	kill HomWeyl;
4828	L[k+1][1][3][i]=concat(Pinew,L[k+1][1][5][i]);
4829	subm=transpose(L[k+1][1][1][i]);
4830	subm2=transpose(L[k+1][1][3][i]);
4831	L[k+1][1][3][i]=transpose(concat(subm,subm2));
4832	}
4833	else
4834	{
4835	L[k+1][1][3][i]=Picombined;
4836	}
4837	L[k+1][2][1][i]=L[k+1][1][3][i];
4838	nr=nrows(L[k+1][1][1][i-1]);
4839	nc=ncols(L[k+1][1][5][i]);
4840	L[k+1][1][2][i]=concat(unitmat(nr),matrix(0,nr,nc));
4841	L[k+1][1][4][i]=prodr(nr,nc);
4842	v=L[k+1][1][6][i],L[k+1][1][8][i];
4843	L[k+1][1][7][i]=v;
4844	L[k+1][2][6][i]=L[k+1][1][7][i];
4845	}
4846	else
4847	{
4848	L[k+1][1][3][i]=L[k+1][1][5][i];
4849	L[k+1][1][2][i]=list();
4850	L[k+1][1][4][i]=unitmat(nrows(L[k+1][1][5][i-1]));
4851	L[k+1][1][7][i]=L[k+1][1][8][i];
4852	L[k+1][2][6][i]=L[k+1][1][7][i];
4853	L[k+1][2][1][i]=L[k+1][1][3][i];
4854	}
4855	}
4856	else
4857	{
4858	if (size(L[k+1][1][1][i])!=0)
4859	{
4860	if (size(L[k+1][1][5][i-1])!=0)
4861	{
4862	zerom=matrix(0,1,nrows(L[k+1][1][5][i-1]));
4863	L[k+1][1][3][i]=concat(L[k+1][1][1][i],zerom);
4864	v=L[k+1][1][6][i],L[k+1][1][8][i];
4865	L[k+1][1][7][i]=v;
4866	nr=nrows(L[k+1][1][1][i-1]);
4867	nc=nrows(L[k+1][1][5][i-1]);
4868	L[k+1][1][2][i]=concat(unitmat(nr),matrix(0,nr,nc));
4869	L[k+1][1][4][i]=prodr(nr,nc);
4870	}
4871	else
4872	{
4873	L[k+1][1][3][i]=L[k+1][1][1][i];
4874	L[k+1][1][7][i]=L[k+1][1][6][i];
4875	L[k+1][1][2][i]=unitmat(nrows(L[k+1][1][1][i-1]));
4876	L[k+1][1][4][i]=list();
4877	}
4878	L[k+1][2][1][i]=L[k+1][1][3][i];
4879	L[k+1][2][6][i]=L[k+1][1][7][i];
4880	}
4881	else
4882	{
4883	L[k+1][1][3][i]=list();
4884	if (size(L[k+1][1][6][i])!=0)
4885	{
4886	if (size(L[k+1][1][8][i])!=0)
4887	{
4888	v=L[k+1][1][6][i],L[k+1][1][8][i];
4889	L[k+1][1][7][i]=v;
4890	nr=nrows(L[k+1][1][1][i-1]);
4891	nc=nrows(L[k+1][1][5][i-1]);
4892	L[k+1][1][2][i]=concat(unitmat(nr),matrix(0,nr,nc));
4893	L[k+1][1][4][i]=prodr(nr,nrows(L[k+1][1][5][i-1]));
4894	}
4895	else
4896	{
4897	L[k+1][1][7][i]=L[k+1][1][6][i];
4898	L[k+1][1][2][i]=unitmat(nrows(L[k+1][1][1][i-1]));
4899	L[k+1][1][4][i]=list();
4900	}
4901	}
4902	else
4903	{
4904	if (size(L[k+1][1][8][i])!=0)
4905	{
4906	L[k+1][1][7][i]=L[k+1][1][8][i];
4907	L[k+1][1][2][i]=list();
4908	L[k+1][1][4][i]=unitmat(nrows(L[k+1][1][5][i-1]));
4909	}
4910	else
4911	{
4912	L[k+1][1][7][i]=list();
4913	L[k+1][1][2][i]=list();
4914	L[k+1][1][4][i]=list();
4915	}
4916	}
4917
4918	L[k+1][2][1][i]=L[k+1][1][3][i];
4919	L[k+1][2][6][i]=L[k+1][1][7][i];
4920	}
4921	}
4922	}
4923	i=size(L)+d+1;
4924	v=0;
4925	if (size(L[k+1][1][5][i-1])!=0)
4926	{
4927	for (j=1; j<=nrows(L[k+1][1][5][i-1]); j++)
4928	{
4929	i1=intvec(1..ncols(L[k+1][1][5][i-1]));
4930	mem=submat(L[k+1][1][5][i-1],j,i1);
4931	v[j]=VdDeg(mem,d,L[k+1][1][8][i-1]);
4932	}
4933	L[k+1][1][8][i]=v;
4934	if (size(L[k+1][1][6][i])!=0)
4935	{
4936	v=L[k+1][1][6][i],L[k+1][1][8][i];
4937	L[k+1][1][7][i]=v;
4938	}
4939	else
4940	{
4941	L[k+1][1][7][i]=L[k+1][1][8][i];
4942	}
4943	}
4944	else
4945	{
4946	L[k+1][1][8][i]=list();
4947	L[k+1][1][7][i]=L[k+1][1][8][i];
4948	}
4949	L[k+1][2][6][i]=L[k+1][1][7][i];
4950	}
4951	for (k=1; k<=(size(L)+d); k++)
4952	{
4953	L[size(L)][2][5][k]=list();
4954	L[size(L)][2][4][k]=list();
4955	L[size(L)][2][8][k]=list();
4956	L[size(L)][2][3][k]=L[size(L)][2][1][k];
4957	L[size(L)][2][7][k]=L[size(L)][2][6][k];
4958	}
4959	L[size(L)][2][7][size(L)+d+1]=L[size(L)][2][6][size(L)+d+1];
4960	L[size(L)][2][8][size(L)+d+1]=list();
4961	/* building the resolution of the last short exact piece*/
4962	for (i=2; i<=d+size(L); i++)
4963	{
4964	v=0;
4965	if(size(L[size(L)][2][1][i-1])!=0)
4966	{
4967	L[size(L)][2][2][i]=unitmat(nrows(L[size(L)][2][1][i-1]));
4968	}
4969	else
4970	{
4971	L[size(L)][2][2][i-1]=list();
4972	}
4973	}
4974	return(L);
4975	}
4976	/case Syzstring=="Vdres"/
4977	list forVd;
4978	for (k=1; k<=(size(L)+d); k++)//?????
4979	{
4980	/* we compute a V_d-strict resolution for the first short exact piece*/
4981	L[1][1][1][k+1]=list();
4982	L[1][1][2][k+1]=list();
4983	L[1][1][6][k+1]=list();
4984	if (size(L[1][1][3][k])!=0)
4985	{
4986	for (i=1; i<=nrows(L[1][1][3][k]); i++)
4987	{
4988	rem=submat(L[1][1][3][k],i,(1..ncols(L[1][1][3][k])));
4989	n_b[i]=VdDeg(rem,d,L[1][1][7][k]);
4990	}
4991	J_B=transpose(syz(transpose(L[1][1][3][k])));
4992	L[1][1][7][k+1]=n_b;
4993	L[1][1][8][k+1]=n_b;
4994	L[1][1][4][k+1]=unitmat(nrows(L[1][1][3][k]));
4995	if (J_B!=matrix(0,nrows(J_B),ncols(J_B)))
4996	{
4997	J_B=VdStrictGB(J_B,d,n_b);
4998	L[1][1][3][k+1]=J_B;
4999	L[1][1][5][k+1]=J_B;
5000	}
5001	else
5002	{
5003	L[1][1][3][k+1]=list();
5004	L[1][1][5][k+1]=list();
5005	}
5006	n_b=0;
5007	}
5008	else
5009	{
5010	L[1][1][3][k+1]=list();
5011	L[1][1][5][k+1]=list();
5012	L[1][1][7][k+1]=list();
5013	L[1][1][8][k+1]=list();
5014	L[1][1][4][k+1]=list();
5015	}
5016	/* we compute step by step V_d-strict resolutions over
5017	coker(L[i][2][1][1])->coker(L[i][2][3][1])->coker(L[i][2][1][5])
5018	and coker(L[i+1][1][1][1])->coker(L[i+1][1][3][1])->coker(L[i+1][1][1][5])
5019	using the already computed resolutions for coker(L[i][2][1][1])=
5020	coker(L[i][1][3][1]) and coker(L[i+1][1][1][1])=coker(L[i][2][5][1])*/
5021	for (i=1; i<size(L); i++)
5022	{
5023	forVd[1]=L[i][2][1][k];
5024	forVd[2]=L[i][2][2][k];
5025	forVd[3]=L[i][2][3][k];
5026	forVd[4]=L[i][2][4][k];
5027	forVd[5]=L[i][2][5][k];
5028	forVd[6]=L[i][2][6][k];
5029	forVd[7]=L[i][2][7][k];
5030	forVd[8]=L[i][2][8][k];
5031	store=toVdStrict2x3Complex(forVd,d,L[i][1][3][k+1],L[i][1][7][k+1]);
5032	for (j=1; j<=8; j++)
5033	{
5034	L[i][2][j][k+1]=store[j];
5035	}
5036	forVd[1]=L[i+1][1][1][k];
5037	forVd[2]=L[i+1][1][2][k];
5038	forVd[3]=L[i+1][1][3][k];
5039	forVd[4]=L[i+1][1][4][k];
5040	forVd[5]=L[i+1][1][5][k];
5041	forVd[6]=L[i+1][1][6][k];
5042	forVd[7]=L[i+1][1][7][k];
5043	forVd[8]=L[i+1][1][8][k];
5044	store=toVdStrict2x3Complex(forVd,d,L[i][2][5][k+1],L[i][2][8][k+1]);
5045	for (j=1; j<=8; j++)
5046	{
5047	L[i+1][1][j][k+1]=store[j];
5048	}
5049	}
5050	if (size(L[size(L)][1][7][k+1])!=0)
5051	{
5052	L[size(L)][2][4][k+1]=list();
5053	L[size(L)][2][5][k+1]=list();
5054	L[size(L)][2][6][k+1]=L[size(L)][1][7][k+1];
5055	L[size(L)][2][7][k+1]=L[size(L)][1][7][k+1];
5056	L[size(L)][2][8][k+1]=list();
5057	L[size(L)][2][2][k+1]=unitmat(size(L[size(L)][1][7][k+1]));
5058	if (size(L[size(L)][1][3][k+1])!=0)
5059	{
5060	L[size(L)][2][1][k+1]=L[size(L)][1][3][k+1];
5061	L[size(L)][2][3][k+1]=L[size(L)][1][3][k+1];
5062	}
5063	else
5064	{
5065	L[size(L)][2][1][k+1]=list();
5066	L[size(L)][2][3][k+1]=list();
5067	}
5068	}
5069	else
5070	{
5071	for (j=1; j<=8; j++)
5072	{
5073	L[size(L)][2][j][k+1]=list();
5074	}
5075	}
5076	}
5077	k=t;
5078	intvec n_c;
5079	intvec vn_b;
5080	list N_b;
5081	int n;
5082	/computation of the shift vectors/
5083	for (i=1; i<=size(L); i++)
5084	{
5085	for (n=1; n<=2; n++)
5086	{
5087	if (i==1 and n==1)
5088	{
5089	L[i][n][6][k+1]=list();
5090	}
5091	else
5092	{
5093	if (n==1)
5094	{
5095	L[i][1][6][k+1]=L[i-1][2][8][k+1];
5096	}
5097	else
5098	{
5099	L[i][2][6][k+1]=L[i][1][7][k+1];
5100	}
5101	}
5102	N_b[1]=L[i][n][6][k+1];
5103	if (size(L[i][n][5][k])!=0)
5104	{
5105	for (j=1; j<=nrows(L[i][n][5][k]); j++)
5106	{
5107	rem=submat(L[i][n][5][k],j,(1..ncols(L[i][n][5][k])));
5108	n_c[j]=VdDeg(rem,d,L[i][n][8][k]);
5109	}
5110	L[i][n][8][k+1]=n_c;
5111	}
5112	else
5113	{
5114	L[i][n][8][k+1]=list();
5115	}
5116	N_b[2]=L[i][n][8][k+1];
5117	n_c=0;
5118	if (size(N_b[1])!=0)
5119	{
5120	vn_b=N_b[1];
5121	if (size(N_b[2])!=0)
5122	{
5123	vn_b=vn_b,N_b[2];
5124	}
5125	L[i][n][7][k+1]=vn_b;
5126	}
5127	else
5128	{
5129	if (size(N_b[2])!=0)
5130	{
5131	L[i][n][7][k+1]=N_b[2];
5132	}
5133	else
5134	{
5135	L[i][n][7][k+1]=list();
5136	}
5137	}
5138	}
5139	}
5140	return(L);
5141	}
5142
5143	////////////////////////////////////////////////////////////////////////////////////
5144
5145	static proc toVdStrict2x3Complex(list L,int d,list #)
5146	{
5147	/* We build a one-step free resolution over a V_d-strict short exact piece
5148	(Algorithm 3.14 in [W2]).
5149	This procedure is called from the procedure VdStrictDoubleComplexes
5150	if Syzstring=='Vdres'*/
5151	matrix rem;
5152	int i,j,cc;
5153	int nr;
5154	list J_A=list(list());
5155	list J_B=list(list());
5156	list J_C=list(list());
5157	list g_AB=list(list());
5158	list g_BC=list(list());
5159	list n_a=list(list());
5160	list n_b=list(list());
5161	list n_c=list(list());
5162	intvec n_b1;
5163	matrix fromnf;
5164	intvec i1,i2;
5165	/* compute a one step V_d-strict resolution for L[5]*/
5166	if (size(L[5])!=0)
5167	{
5168	intvec n_c1;
5169	for (i=1; i<=nrows(L[5]); i++)
5170	{
5171	rem=submat(L[5],i,intvec(1..ncols(L[5])));
5172	n_c1[i]=VdDeg(rem,d, L[8]);//new shift vector
5173	}
5174	n_c[1]=n_c1;
5175	J_C[1]=transpose(syz(transpose(L[5])));
5176	if (J_C[1]!=matrix(0,nrows(J_C[1]),ncols(J_C[1])))
5177	{
5178	J_C[1]=VdStrictGB(J_C[1],d,n_c1);
5179	if (size(#[2])!=0)// new shift vector for the resolution of L[1]
5180	{
5181	n_a[1]=#[2];
5182	n_b1=n_a[1],n_c[1];
5183	n_b[1]=n_b1;
5184	matrix zero[nrows(L[1])][nrows(L[5])];
5185	g_AB=concat(unitmat(nrows(L[1])),matrix(0,nrows(L[1]),nrows(L[5])));
5186	if (size(#[1])!=0)
5187	{
5188	J_A=#[1];// one step V_d-strict resolution for L[1]
5189	/* use resolutions of L[1] and L[5] to build a resolution for
5190	L[3]*/
5191	J_B[1]=transpose(matrix(syz(transpose(L[3]))));
5192	matrix P=matrixLift(J_B[1]*prodr(nrows(L[1]),nrows(L[5])),J_C[1]);
5193	matrix Pi[1][ncols(J_B[1])];
5194	matrix Picombined;
5195	for (i=1; i<=nrows(J_C[1]); i++)
5196	{
5197	for (j=1; j<=nrows(J_B[1]);j++)
5198	{
5199	Pi=Pi+P[i,j]*submat(J_B[1],j,intvec(1..ncols(J_B[1])));
5200	}
5201	if (i==1)
5202	{
5203	Picombined=transpose(Pi);
5204	}
5205	else
5206	{
5207	Picombined=concat(Picombined,transpose(Pi));
5208	}
5209	Pi=0;
5210	}
5211	Picombined=transpose(Picombined);
5212	fromnf=VdNormalForm(Picombined,J_A[1],d,n_a[1],n_c[1]);
5213	i1=intvec(1..nrows(Picombined));
5214	i2=intvec((ncols(J_A[1])+1)..ncols(Picombined));
5215	Picombined=concat(fromnf,submat(Picombined,i1,i2));
5216	J_B[1]=transpose(matrix(J_A[1],nrows(J_A[1]),ncols(J_B[1])));
5217	J_B[1]=transpose(concat(J_B[1],transpose(Picombined)));
5218	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
5219	}
5220	else//L[1] is already a resolution
5221	{
5222	//compute a resolution for L[3]
5223	J_B=transpose(matrix(syz(transpose(L[3]))));
5224	matrix P=matrixLift(J_B[1]*prodr(nrows(L[1]),nrows(L[5])),J_C[1]);
5225	matrix Pi[1][ncols(J_B[1])];
5226	matrix Picombined;
5227	for (i=1; i<=nrows(J_C[1]); i++)
5228	{
5229	for (j=1; j<=nrows(J_B[1]);j++)
5230	{
5231	Pi=Pi+P[i,j]*submat(J_B[1],j,intvec(1..ncols(J_B[1])));
5232	}
5233	if (i==1)
5234	{
5235	Picombined=transpose(Pi);
5236	}
5237	else
5238	{
5239	Picombined=concat(Picombined,transpose(Pi));
5240	}
5241	Pi=0;
5242	}
5243	Picombined=transpose(Picombined);
5244	J_B[1]=Picombined;
5245	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
5246	}
5247	}
5248	else
5249	{
5250	n_b=n_c[1];
5251	J_B[1]=J_C[1];
5252	g_BC=unitmat(ncols(J_C[1]));
5253	}
5254	}
5255	else
5256	{
5257	J_C=list(list());// L[5] is already a resolution
5258	if (size(#[2])!=0)
5259	{
5260	matrix zero[nrows(L[1])][nrows(L[5])];
5261	g_BC=transpose(concat(transpose(zero),unitmat(nrows(L[5]))));
5262	n_a[1]=#[2];
5263	n_b1=n_a[1],n_c[1];
5264	n_b[1]=n_b1;
5265	g_AB=concat(unitmat(nrows(L[1])),matrix(0,nrows(L[1]),nrows(L[5])));
5266	if (size(#[1])!=0)
5267	{
5268	J_A=#[1];
5269	/resolution of L[3]/
5270	nr=nrows(J_A[1]);
5271	J_B=concat(J_A[1],matrix(0,nr,nrows(L[3])-nrows(L[1])));
5272	}
5273	}
5274	else
5275	{
5276	n_b=n_c[1];
5277	g_BC=unitmat(ncols(L[5]));
5278	}
5279	}
5280	}
5281	else// L[5]=list();
5282	{
5283	if (size(#[2])!=0)
5284	{
5285	n_a[1]=#[2];
5286	n_b=n_a[1];
5287	g_AB=unitmat(size(n_b[1]));
5288	if (size(#[1])!=0)
5289	{
5290	J_A=#[1];
5291	J_B[1]=J_A[1];// resolution of L[3] equals that of L[1]
5292	}
5293	}
5294	}
5295	list out=(J_A[1],g_AB[1],J_B[1],g_BC[1],J_C[1],n_a[1],n_b[1],n_c[1]);
5296	return (out);
5297	}
5298
5299	////////////////////////////////////////////////////////////////////////////////////
5300
5301	static proc assemblingDoubleComplexes(list L)
5302	{
5303	/* The input is the output of VdStrictDoubleComplexes, we assemble the
5304	resolutions of the L[i][2][3][1] to obtain a V_d-strict free Cartan-Eilenberg
5305	resolution with modules P^i_j (1<=i<=size(L), j>=0) for the seqeunce
5306	coker(L[1][2][3][1])->...->coker(L[size(L)][2][3][1])*/
5307	list out;
5308	int i,j,k,l,oldj,newj,nr,nc;
5309	for (i=1; i<=size(L); i++)
5310	{
5311	out[i]=list(list());
5312	out[i][1][1]=ncols(L[i][2][3][1]);//rank of module P^i_0
5313	if (size(L[i][2][5][1])!=0)
5314	{
5315	/horizontal differential P^i_0->P^(i+1)_0/
5316	nc=ncols(L[i][2][5][1]);
5317	out[i][1][4]=prodr(ncols(L[i][2][3][1])-ncols(L[i][2][5][1]),nc);
5318	}
5319	else
5320	{
5321	/horizontal differential P^i_0->0/
5322	out[i][1][4]=matrix(0,ncols(L[i][2][3][1]),1);
5323	}
5324	oldj=newj;
5325	for (j=1; j<=size(L[i][2][3]);j++)
5326	{
5327	out[i][j][2]=L[i][2][7][j];//shift vector of P^i_{j-1}
5328	if (size(L[i][2][3][j])==0)
5329	{
5330	newj =j;
5331	break;
5332	}
5333	out[i][j+1]=list();
5334	out[i][j+1][1]=nrows(L[i][2][3][j]);//rank of the module P^i_j
5335	out[i][j+1][3]=L[i][2][3][j];//vertical differential P^i_j->P^(i+1)_j
5336	if (size(L[i][2][5][j])!=0)
5337	{
5338	//horizonal differential P^i_j->P^(i-1)_j
5339	nr=nrows(L[i][2][3][j])-nrows(L[i][2][5][j]);
5340	out[i][j+1][4]=(-1)^j*prodr(nr,nrows(L[i][2][5][j]));
5341	}
5342	else
5343	{
5344	/horizontal differential P^i_j->P^(i-1)_j/
5345	out[i][j+1][4]=matrix(0,nrows(L[i][2][3][j]),1);
5346	}
5347	if(j==size(L[i][2][3]))
5348	{
5349	out[i][j+1][2]=L[i][2][7][j+1];//shift vector of P^i_j
5350	newj=j+1;
5351	}
5352	}
5353	if (i>1)
5354	{
5355
5356	for (k=1; k<=Min(list(oldj,newj)); k++)
5357	{
5358	/horizonal differential P^(i-1)_(k-1)->P^i_(k-1)/
5359	nr=nrows(out[i-1][k][4]);
5360	out[i-1][k][4]=matrix(out[i-1][k][4],nr,out[i][k][1]);
5361	}
5362	for (k=newj+1; k<=oldj; k++)
5363	{
5364	/no differential needed/
5365	out[i-1][k]=delete(out[i-1][k],4);
5366	}
5367	}
5368	}
5369	return (out);
5370	}
5371
5372	////////////////////////////////////////////////////////////////////////////////////
5373
5374	static proc totalComplex(list L);
5375	{
5376	/* Input is the output of assemblingDoubleComplexes.
5377	We obtain a complex C^1[m^1]->...->C^(r)[m^r] with differentials d^i and
5378	shift vectors m^i (where C^r is placed in degree size(L)-1).
5379	This complex is dercribed in the list out as follows:
5380	rank(C^i)=out[3i-2]; m_i=out[3i-1] and d^i=out[3i]/
5381	list out;intvec rem1;intvec v; list remsize; int emp;
5382	int i; int j; int c; int d; matrix M; int k; int l;
5383	int n=nvars(basering) div 2;
5384	list K;
5385	for (i=1; i<=n+1; i++)
5386	{
5387	K[i]=list();
5388	}
5389	L=K+L;
5390	for (i=1; i<=size(L); i++)
5391	{
5392	emp=0;
5393	if (size(L[i])!=0)
5394	{
5395	out[3*i-2]=L[i][1][1];
5396	v=L[i][1][1];
5397	rem1=L[i][1][2];
5398	emp=1;
5399	}
5400	else
5401	{
5402	out[3*i-2]=0;
5403	v=0;
5404	}
5405	for (j=i+1; j<=size(L); j++)
5406	{
5407	if (size(L[j])>=j-i+1)
5408	{
5409	out[3i-2]=out[3i-2]+L[j][j-i+1][1];
5410	if (emp==0)
5411	{
5412	rem1=L[j][j-i+1][2];
5413	emp=1;
5414	}
5415	else
5416	{
5417	rem1=rem1,L[j][j-i+1][2];
5418	}
5419	v[size(v)+1]=L[j][j-i+1][1];
5420	}
5421	else
5422	{
5423	v[size(v)+1]=0;
5424	}
5425	}
5426	out[3*i-1]=rem1;
5427	v[size(v)+1]=0;
5428	remsize[i]=v;
5429	}
5430	int o1;
5431	int o2;
5432	for (i=1; i<=size(L)-1; i++)
5433	{
5434	o1=1;
5435	o2=1;
5436	if (size(out[3*i-2])!=0)
5437	{
5438	o1=out[3*i-2];
5439	}
5440	if (size(out[3*i+1])!=0)
5441	{
5442	o2=out[3*i+1];
5443	}
5444	M=matrix(0,o1,o2);
5445	if (size(L[i])!=0)
5446	{
5447	if (size(L[i][1][4])!=0)
5448	{
5449	M=matrix(L[i][1][4],o1,o2);
5450	}
5451	}
5452	c=remsize[i][1];
5453	for (j=i+1; j<=size(L); j++)
5454	{
5455	if (remsize[i][j-i+1]!=0)
5456	{
5457	for (k=c+1; k<=c+remsize[i][j-i+1]; k++)
5458	{
5459	for (l=d+1; l<=d+remsize[i+1][j-i];l++)
5460	{
5461	M[k,l]=L[j][j-i+1][3][(k-c),(l-d)];
5462	}
5463	}
5464	d=d+remsize[i+1][j-i];
5465	if (remsize[i+1][j-i+1]!=0)
5466	{
5467	for (k=c+1; k<=c+remsize[i][j-i+1]; k++)
5468	{
5469	for (l=d+1; l<=d+remsize[i+1][j-i+1];l++)
5470	{
5471	M[k,l]=L[j][j-i+1][4][k-c,l-d];
5472	}
5473	}
5474	c=c+remsize[i][j-i+1];
5475	}
5476	}
5477	else
5478	{
5479	d=d+remsize[i+1][j-i];
5480	}
5481	}
5482	out[3*i]=M;
5483	d=0; c=0;
5484	}
5485	out[3size(L)]=matrix(0,out[3size(L)-2],1);
5486	return (out);
5487
5488	}
5489
5490	////////////////////////////////////////////////////////////////////////////////////
5491	//COMPUTATION OF THE BLOBAL B-FUNCTION
5492	////////////////////////////////////////////////////////////////////////////////////
5493
5494	static proc globalBFun(list L,list #)
5495	{
5496	/*We assume that the basering is the nth Weyl algebra and that L=(L[1],...,L[s]),
5497	where L[i]=(L[i][1],L[i][2]) and L[i][1] is a m_i x n_i-matrix and L[i][2] an
5498	intvec of size n_i.
5499	We compute bounds for the minimal and maximal integer roots of the b-functions
5500	of coker(L[i][1])[L[i][2]], where L[i][2] is the shift vector (cf. Def.
5501	6.1.1 in [R]) by combining Algorithm 6.1.6 in [R] and the method of principal
5502	intersection (cf. Remark 6.1.7 in [R] 2012).
5503	This works ONLY IF ALL B-FUNCTIONS ARE NON-ZERO, but this is the case since this
5504	proc is only called from the procedure deRhamCohomology and the input comes
5505	originally from the procedure toVdstrictFreeComplex*/
5506	if (size(#)==0)//# may contain the Syzstring
5507	{
5508	string Syzstring="Sres";
5509	}
5510	else
5511	{
5512	string Syzstring=#[1];
5513	}
5514	int i,j;
5515	def W=basering;
5516	int n=nvars(W) div 2;
5517	list G0;
5518	ideal I;
5519	for (j=1; j<=size(L); j++)
5520	{
5521	G0[j]=list();
5522	for (i=1; i<=ncols(L[j][1]); i++)
5523	{
5524	G0[j][i]=I;
5525	}
5526	}
5527	list out;
5528	ideal I; poly f;
5529	intvec i1;
5530	for (j=1; j<=size(L); j++)
5531	{
5532	/*if the shift vector L[j][2] is non-zero we have to compute a V_d-strict
5533	Groebner basis of L[j][1] with respect to the zero shift; otherwise L[i][1]
5534	is already a V_d-strict Groebner basis, because it was obtained by the
5535	procedure toVdStrictFreeComplex*/
5536	if (L[j][2]!=intvec(0:size(L[j][2])) or Syzstring=="noCE")
5537	{
5538	if (Syzstring=="Vdres")
5539	{
5540	L[j][1]=VdStrictGB(L[j][1],n);
5541	}
5542	else
5543	{
5544	def HomWeyl=makeHomogenizedWeyl(n);
5545	setring HomWeyl;
5546	list L=fetch(W,L);
5547	L[j][1]=nHomogenize(L[j][1]);
5548	L[j][1]=transpose(matrix(slimgb(transpose(L[j][1]))));
5549	L[j][1]=subst(L[j][1],h,1);
5550	setring W;
5551	L=fetch(HomWeyl,L);
5552	kill HomWeyl;
5553	}
5554	}
5555	for (i=1; i<=ncols(L[j][1]); i++)
5556	{
5557	G0[j][i]=I;
5558	}
5559	for (i=1; i<=nrows(L[j][1]); i++)
5560	{
5561	/*computes the terms of maximal V_d-degree of the biggest non-zero
5562	component of submat(L[j][1],i,(1..ncols(L[j][1])))*/
5563	i1=(1..ncols(L[j][1]));
5564	out=VdDeg(submat(L[j][1],i,i1),n,intvec(0:size(L[j][2])),1);
5565	// f=L[j][1][i,out[2]];
5566	G0[j][out[2]]=G0[j][out[2]],out[1];
5567	G0[j][out[2]]=compress(G0[j][out[2]]);
5568	}
5569	}
5570	list save;
5571	int l;
5572	list weights;
5573	/*bFctIdealModified computes the intersection of G0[j][i] and
5574	x(1)D(1)+...+x(n)D(n) using the method of principal intersection*/
5575	for (j=1; j<=size(G0); j++)
5576	{
5577	for (i=1; i<=size(G0[j]); i++)
5578	{
5579	G0[j][i]=bFctIdealModified(G0[j][i]);
5580	}
5581	for (i=1; i<=size(G0[j]); i++)
5582	{
5583	weights=list();
5584	if (size(G0[j][i])!=0)
5585	{
5586	for (l=i; l<=size(G0[j]); l++)
5587	{
5588	weights[size(weights)+1]=L[j][2][l];
5589	}
5590	G0[j][i]=list(G0[j][i][1]+Min(weights),G0[j][i][2]+Max(weights));
5591	}
5592	}
5593	}
5594	list allmin;
5595	list allmax;
5596	for (j=1; j<=size(G0); j++)
5597	{
5598	for (i=1; i<=size(G0[j]); i++)
5599	{
5600	if (size(G0[j][i])!=0)
5601	{
5602	allmin[size(allmin)+1]=G0[j][i][1];
5603	allmax[size(allmax)+1]=G0[j][i][2];
5604	}
5605	}
5606	}
5607	list minmax=list(Min(allmin),Max(allmax));
5608	return(minmax);
5609	}
5610
5611	////////////////////////////////////////////////////////////////////////////////////
5612
5613	static proc exactGlobalBFun(list L,list #)
5614	{
5615	/*We assume that the basering is the nth Weyl algebra and that L=(L[1],...,L[s]),
5616	where L[i]=(L[i][1],L[i][2]) and L[i][1] is a m_i x n_i-matrix and L[i][2] an
5617	intvec of size n_i.
5618	We compute bounds for the minimal and maximal integer roots of the b-functions
5619	of coker(L[i][1])[L[i][2]], where L[i][2] is the shift vector (cf. Def.
5620	6.1.1 in [R]) by combining Algorithm 6.1.6 in [R] and the method of principal
5621	intersection (cf. Remark 6.1.7 in [R] 2012).
5622	This works ONLY IF ALL B-FUNCTIONS ARE NON-ZERO, but this is the case since this
5623	proc is only called from the procedure deRhamCohomology and the input comes
5624	originally from the procedure toVdstrictFreeComplex*/
5625	if (size(#)==0)//# may contain the Syzstring
5626	{
5627	string Syzstring="Sres";
5628	}
5629	else
5630	{
5631	string Syzstring=#[1];
5632	}
5633	int i,j,k;
5634	def W=basering;
5635	int n=nvars(W) div 2;
5636	list G0;
5637	ideal I;
5638	for (j=1; j<=size(L); j++)
5639	{
5640	G0[j]=list();
5641	for (i=1; i<=ncols(L[j][1]); i++)
5642	{
5643	G0[j][i]=I;
5644	}
5645	}
5646	list out;
5647	matrix M;
5648	ideal I; poly f;
5649	intvec i1;
5650	for (j=1; j<=size(L); j++)
5651	{
5652	M=L[j][1];
5653	/*if the shift vector L[j][2] is non-zero we have to compute a V_d-strict
5654	Groebner basis of L[j][1] with respect to the zero shift; otherwise L[i][1]
5655	is already a V_d-strict Groebner basis, because it was obtained by the
5656	procedure toVdStrictFreeComplex*/
5657	for (k=1; k<=ncols(L[j][1]); k++)
5658	{
5659	L[j][1]=permcol(M,1,k);
5660	if (Syzstring=="Vdres")
5661	{
5662	L[j][1]=VdStrictGB(L[j][1],n);
5663	}
5664	else
5665	{
5666	def HomWeyl=makeHomogenizedWeyl(n);
5667	setring HomWeyl;
5668	list L=fetch(W,L);
5669	L[j][1]=nHomogenize(L[j][1]);
5670	L[j][1]=transpose(matrix(slimgb(transpose(L[j][1]))));
5671	L[j][1]=subst(L[j][1],h,1);
5672	setring W;
5673	L=fetch(HomWeyl,L);
5674	kill HomWeyl;
5675	}
5676	for (i=1; i<=nrows(L[j][1]); i++)
5677	{
5678	/*computes the terms of maximal V_d-degree of the biggest non-zero
5679	component of submat(L[j][1],i,(1..ncols(L[j][1])))*/
5680	i1=(1..ncols(L[j][1]));
5681	out=VdDeg(submat(L[j][1],i,i1),n,intvec(0:size(L[j][2])),1);
5682	if (out[2]==1)
5683	{
5684	G0[j][k]=G0[j][k],out[1];
5685	G0[j][k]=compress(G0[j][k]);
5686	}
5687	}
5688	}
5689	}
5690	list save;
5691	int l;
5692	list weights;
5693	/*bFctIdealModified computes the intersection of G0[j][i] and
5694	x(1)D(1)+...+x(n)D(n) using the method of principal intersection*/
5695	for (j=1; j<=size(G0); j++)
5696	{
5697	for (i=1; i<=size(G0[j]); i++)
5698	{
5699	G0[j][i]=bFctIdealModified(G0[j][i]);
5700	}
5701	for (i=1; i<=size(G0[j]); i++)
5702	{
5703	if (size(G0[j][i])!=0)
5704	{
5705	G0[j][i]=list(G0[j][i][1]+L[j][2][i],G0[j][i][2]+L[j][2][i]);
5706	}
5707	}
5708	}
5709	list allmin;
5710	list allmax;
5711	for (j=1; j<=size(G0); j++)
5712	{
5713	for (i=1; i<=size(G0[j]); i++)
5714	{
5715	if (size(G0[j][i])!=0)
5716	{
5717	allmin[size(allmin)+1]=G0[j][i][1];
5718	allmax[size(allmax)+1]=G0[j][i][2];
5719	}
5720	}
5721	}
5722	list minmax=list(Min(allmin),Max(allmax));
5723	return(minmax);
5724	}
5725
5726	////////////////////////////////////////////////////////////////////////////////////
5727
5728	////////////////////////////////////////////////////////////////////////////////////
5729
5730	static proc exactGlobalBFunIntegration(list L,list #)
5731	{
5732	/*We assume that the basering is the nth Weyl algebra and that L=(L[1],...,L[s]),
5733	where L[i]=(L[i][1],L[i][2]) and L[i][1] is a m_i x n_i-matrix and L[i][2] an
5734	intvec of size n_i.
5735	We compute bounds for the minimal and maximal integer roots of the b-functions
5736	of coker(L[i][1])[L[i][2]], where L[i][2] is the shift vector (cf. Def.
5737	6.1.1 in [R]) by combining Algorithm 6.1.6 in [R] and the method of principal
5738	intersection (cf. Remark 6.1.7 in [R] 2012).
5739	This works ONLY IF ALL B-FUNCTIONS ARE NON-ZERO, but this is the case since this
5740	proc is only called from the procedure deRhamCohomology and the input comes
5741	originally from the procedure toVdstrictFreeComplex*/
5742	string Syzstring="Sres";
5743	int i,j,k;
5744	def W=basering;
5745	int n=nvars(W) div 2;
5746	// def C=makeConverseWeyl(n);
5747	// setring C;
5748	// ideal Jn=x(1);
5749	// for (i=2; i<=nvars(basering) div 2; i++)
5750	// {
5751	// Jn=Jn,var(nvars(basering) div 2 + i);
5752	// }
5753	// for (i=1; i<=nvars(basering) div 2; i++)
5754	// {
5755	// Jn=Jn,var(i);
5756	// }
5757	// map transtc=W,Jn;
5758	// list L=transtc(L);
5759	list G0;
5760	ideal I;
5761	for (j=1; j<=size(L); j++)
5762	{
5763	G0[j]=list();
5764	for (i=1; i<=ncols(L[j][1]); i++)
5765	{
5766	G0[j][i]=I;
5767	}
5768	}
5769	list out;
5770	matrix M;
5771	ideal I;
5772	poly f;
5773	intvec i1;
5774	for (j=1; j<=size(L); j++)
5775	{
5776	M=L[j][1];
5777	/*if the shift vector L[j][2] is non-zero we have to compute a V_d-strict
5778	Groebner basis of L[j][1] with respect to the zero shift; otherwise L[i][1]
5779	is already a V_d-strict Groebner basis, because it was obtained by the
5780	procedure toVdStrictFreeComplex*/
5781	for (k=1; k<=ncols(L[j][1]); k++)
5782	{
5783	L[j][1]=permcol(M,1,k);
5784	def HomWeyl=makeHomogenizedWeylTilde(n);
5785	setring HomWeyl;
5786	list L=fetch(W,L);
5787	L[j][1]=nHomogenize(L[j][1]);
5788	L[j][1]=transpose(matrix(slimgb(transpose(L[j][1]))));
5789	L[j][1]=subst(L[j][1],h,1);
5790	setring W;
5791	L=fetch(HomWeyl,L);
5792	kill HomWeyl;
5793	for (i=1; i<=nrows(L[j][1]); i++)
5794	{
5795	/*computes the terms of maximal V_d-degree of the biggest non-zero
5796	component of submat(L[j][1],i,(1..ncols(L[j][1])))*/
5797	i1=(1..ncols(L[j][1]));
5798	out=VdDegTilde(submat(L[j][1],i,i1),n,intvec(0:size(L[j][2])),1);//hier könnte es evtl noch einen Fehler geben!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5799	f=L[j][1][i,out[2]];
5800	if (out[2]==1)
5801	{
5802	G0[j][k]=G0[j][k],out[1];
5803	G0[j][k]=compress(G0[j][k]);
5804	}
5805	}
5806	}
5807	}
5808	list save;
5809	int l;
5810	list weights;
5811	/*bFctIdealModified computes the intersection of G0[j][i] and
5812	x(1)D(1)+...+x(n)D(n) using the method of principal intersection*/
5813	for (j=1; j<=size(G0); j++)
5814	{
5815	for (i=1; i<=size(G0[j]); i++)
5816	{
5817	G0[j][i]=bFctIdealModified(G0[j][i],1);
5818	}
5819	for (i=1; i<=size(G0[j]); i++)
5820	{
5821	if (size(G0[j][i])!=0)
5822	{
5823	G0[j][i]=list(G0[j][i][1]+L[j][2][i],G0[j][i][2]+L[j][2][i]);
5824	}
5825	}
5826	}
5827	list allmin;
5828	list allmax;
5829	for (j=1; j<=size(G0); j++)
5830	{
5831	for (i=1; i<=size(G0[j]); i++)
5832	{
5833	if (size(G0[j][i])!=0)
5834	{
5835	allmin[size(allmin)+1]=G0[j][i][1];
5836	allmax[size(allmax)+1]=G0[j][i][2];
5837	}
5838	}
5839	}
5840	list minmax=list(Min(allmin),Max(allmax));
5841	return(minmax);
5842	}
5843
5844	////////////////////////////////////////////////////////////////////////////////////
5845
5846	static proc bFctIdealModified (ideal I, list #)
5847	{/modified version of the procedure bfunIdeal from bfun.lib/
5848	int tilde;
5849	if (size(#)!=0)
5850	{
5851	tilde=#[1];
5852	}
5853	def B= basering;
5854	int n = nvars(B) div 2;
5855	intvec w=(1:n);
5856	// if (tilde==0)
5857	// {
5858	I= initialIdealW(I,-w,w);
5859	// }
5860	// else
5861	// {
5862	// I= initialIdealW(I,w,-w);
5863	// }
5864	poly s; int i;
5865	if (tilde==0)
5866	{
5867	for (i=1; i<=n; i++)
5868	{
5869	s=s+x(i)*D(i);
5870	}
5871	}
5872	else
5873	{
5874	for (i=1; i<=n; i++)
5875	{
5876	s=s-D(i)*x(i);
5877	}
5878	}
5879	/pIntersect computes the intersection on s and I/
5880	vector b = pIntersect(s,I);
5881	list RL = ringlist(B); RL = RL[1..4];
5882	RL[2] = list(safeVarName("s"));
5883	RL[3] = list(list("dp",intvec(1)),list("C",intvec(0)));
5884	def @S = ring(RL); setring @S;
5885	vector b = imap(B,b);
5886	poly bs = vec2poly(b);
5887	ring r=0,s,dp;
5888	poly bs=imap(@S,bs);
5889	/find minimal and maximal integer root/
5890	ideal allfac=factorize(bs,1);
5891	list allfacs;
5892	for (i=1; i<=ncols(allfac); i++)
5893	{
5894	allfacs[i]=allfac[i];
5895	}
5896	number testzero;
5897	list zeros;
5898	for (i=1; i<=size(allfacs); i++)
5899	{
5900	if (deg(allfacs[i])==1)
5901	{
5902	testzero=number(subst(allfacs[i],s,0))/leadcoef(allfacs[i]);
5903	if (testzero-int(testzero)==0)
5904	{
5905	zeros[size(zeros)+1]=int(-1)*int(testzero);
5906	}
5907	}
5908	}
5909	if (size(zeros)!=0)
5910	{
5911	list minmax=(Min(zeros),Max(zeros));
5912	}
5913	else
5914	{
5915	list minmax=list();
5916	}
5917	setring B;
5918	return(minmax);
5919	}
5920
5921	////////////////////////////////////////////////////////////////////////////////////
5922
5923	static proc safeVarName (string s)
5924	{/* from the library "bfun.lib"*/
5925	string S = "," + charstr(basering) + "," + varstr(basering) + ",";
5926	s = "," + s + ",";
5927	while (find(S,s) <> 0)
5928	{
5929	s[1] = "@";
5930	s = "," + s;
5931	}
5932	s = s[2..size(s)-1];
5933	return(s)
5934	}
5935
5936	////////////////////////////////////////////////////////////////////////////////////
5937
5938	static proc globalBFunOT(list L,list #)
5939	{
5940	/*this proc is currently not used since globalBFun computes the same output and is
5941	faster, however globalBFun works only for non-zero b-functions!*/
5942	/*We assume that the basering is the nth Weyl algebra and that L=(L[1],...,L[s]),
5943	where L[i]=(L[i][1],L[i][2]) and L[i][1] is a m_i x n_i-matrix and L[i][2] an
5944	intvec of size n_i.
5945	We compute bounds for the minimal and maximal integer roots of the b-functions
5946	of coker(L[i][1])[L[i][2]], where L[i][2] is the shift vector (cf. Def.
5947	6.1.1 in [R]) using Algorithm 6.1.6 in [R].*/
5948	if (size(#)==0)
5949	{
5950	string Syzstring="Sres";
5951	}
5952	else
5953	{
5954	string Syzstring=#[1];
5955	}
5956	int i; int j;
5957	def W=basering;
5958	int n=nvars(W) div 2;
5959	list G0;
5960	ideal I;
5961	intvec i1;
5962	for (j=1; j<=size(L); j++)
5963	{
5964	G0[j]=list();
5965	for (i=1; i<=ncols(L[j][1]); i++)
5966	{
5967	G0[j][i]=I;
5968	}
5969	}
5970	list out;
5971	for (j=1; j<=size(L); j++)
5972	{
5973	if (L[j][2]!=intvec(0:size(L[j][2])))
5974	{
5975	if (Syzstring=="Vdres")
5976	{
5977	L[j][1]=VdStrictGB(L[j][1],n);
5978	}
5979	else
5980	{
5981	def HomWeyl=makeHomogenizedWeyl(n);
5982	setring HomWeyl;
5983	list L=fetch(W,L);
5984	L[j][1]=nHomogenize(L[j][1]);
5985	L[j][1]=transpose(matrix(slimgb(transpose(L[j][1]))));
5986	L[j][1]=subst(L[j][1],h,1);
5987	setring W;
5988	L=fetch(HomWeyl,L);
5989	kill HomWeyl;
5990	}
5991	}
5992	for (i=1; i<=nrows(L[j][1]); i++)
5993	{
5994	i1=(1..ncols(L[j][1]));
5995	out=VdDeg(submat(L[j][1],i,i1),n,intvec(0:size(L[j][2])),1);
5996	G0[j][out[2]][size(G0[j][out[2]])+1]=(out[1]);
5997	}
5998	}
5999	list Data=ringlist(W);
6000	for (i=1; i<=n; i++)
6001	{
6002	Data[2][2*n+i]=Data[2][i];
6003	Data[2][3*n+i]=Data[2][n+i];
6004	Data[2][i]="v("+string(i)+")";
6005	Data[2][n+i]="w("+string(i)+")";
6006	}
6007	Data[3][1][1]="M";
6008	intvec mord=(0:16*n^2);
6009	mord[1..2n]=(1:2n);
6010	mord[6n+1..8n]=(1:2*n);
6011	for (i=0; i<=2*n-2; i++)
6012	{
6013	mord[(3+i)4n-i]=-1;
6014	mord[(2n+2+i)4n-2n-i]=-1;
6015	}
6016	Data[3][1][2]=mord;
6017	matrix Ones=UpOneMatrix(4*n);
6018	Data[5]=Ones;
6019	matrix con[2n][2n];
6020	Data[6]=transpose(concat(con,transpose(concat(con,Data[6]))));
6021	def Wuv=ring(Data);
6022	setring Wuv;
6023	list G0=imap(W,G0); list G3; poly lterm;intvec lexp;
6024	list G1,G2,LL;
6025	intvec e,f;
6026	int kapp,k,l;
6027	poly h;
6028	ideal I;
6029	for (l=1; l<=size(G0); l++)
6030	{
6031	G1[l]=list(); G2[l]=list(); G3[l]=list();
6032	for (i=1; i<=size(G0[l]); i++)
6033	{
6034	for (j=1; j<=ncols(G0[l][i]);j++)
6035	{
6036	G0[l][i][j]=mHom(G0[l][i][j]);
6037	}
6038	for (j=1; j<=nvars(Wuv) div 4; j++)
6039	{
6040	G0[l][i][size(G0[l][i])+1]=1-v(j)*w(j);
6041	}
6042	G1[l][i]=slimgb(G0[l][i]);
6043	G2[l][i]=I;
6044	G3[l][i]=list();
6045	for (j=1; j<=ncols(G1[l][i]); j++)
6046	{
6047	e=leadexp(G1[l][i][j]);
6048	f=e[1..2*n];
6049	if (f==intvec(0:(2*n)))
6050	{
6051	for (k=1; k<=n; k++)
6052	{
6053	kapp=-e[2n+k]+e[3n+k];
6054	if (kapp>0)
6055	{
6056	G1[l][i][j]=(x(k)^kapp)*G1[l][i][j];
6057	}
6058	if (kapp<0)
6059	{
6060	G1[l][i][j]=(D(k)^(-kapp))*G1[l][i][j];
6061	}
6062	}
6063	G2[l][i][size(G2[l][i])+1]=G1[l][i][j];
6064	G3[l][i][size(G3[l][i])+1]=list();
6065	while (G1[l][i][j]!=0)
6066	{
6067	lterm=lead(G1[l][i][j]);
6068	G1[l][i][j]=G1[l][i][j]-lterm;
6069	lexp=leadexp(lterm);
6070	lexp=lexp[2n+1..3n];
6071	LL=list(lexp,leadcoef(lterm));
6072	G3[l][i][size(G3[l][i])][size(G3[l][i][size(G3[l][i])])+1]=LL;
6073	}
6074	}
6075	}
6076	}
6077	}
6078	ring r=0,(s(1..n)),dp;
6079	ideal I;
6080	map G3forr=Wuv,I;
6081	list G3=G3forr(G3);
6082	poly fs,gs;
6083	int a;
6084	list G4;
6085	for (l=1; l<=size(G3); l++)
6086	{
6087	G4[l]=list();
6088	for (i=1; i<=size(G3[l]);i++)
6089	{
6090	G4[l][i]=I;
6091
6092	for (j=1; j<=size(G3[l][i]); j++)
6093	{
6094	fs=0;
6095	for (k=1; k<=size(G3[l][i][j]); k++)
6096	{
6097	gs=1;
6098	for (a=1; a<=n; a++)
6099	{
6100	if (G3[l][i][j][k][1][a]!=0)
6101	{
6102	gs=gs*permuteVar(list(G3[l][i][j][k][1][a]),a);
6103	}
6104	}
6105	gs=gs*G3[l][i][j][k][2];
6106	fs=fs+gs;
6107	}
6108	G4[l][i]=G4[l][i],fs;
6109	}
6110	}
6111	}
6112	if (n==1)
6113	{
6114	ring rnew=0,t,dp;
6115	}
6116	else
6117	{
6118	ring rnew=0,(t,s(2..n)),dp;
6119	}
6120	ideal Iformap;
6121	Iformap[1]=t;
6122	poly forel=1;
6123	for (i=2; i<=n; i++)
6124	{
6125	Iformap[1]=Iformap[1]-s(i);
6126	Iformap[i]=s(i);
6127	forel=forel*s(i);
6128	}
6129	map rtornew=r,Iformap;
6130	list G4=rtornew(G4);
6131	list getintvecs=fetch(W,L);
6132	ideal J;
6133	option(redSB);
6134	for (l=1; l<=size(G4); l++)
6135	{
6136	J=1;
6137	for (i=1; i<=size(G4[l]); i++)
6138	{
6139	G4[l][i]=eliminate(G4[l][i],forel);
6140	J=intersect(J,G4[l][i]);
6141	}
6142	G4[l]=poly(std(J)[1]);
6143	}
6144	list minmax;
6145	list mini=list();
6146	list maxi=list();
6147	list L=fetch(W,L);
6148	for (i=1; i<=size(G4); i++)
6149	{
6150	minmax[i]=minIntRoot(G4[i],1);
6151	if (size(minmax[i])!=0)
6152	{
6153	mini=insert(mini,minmax[i][1]+Min(L[i][2]));
6154	maxi=insert(maxi,minmax[i][2]+Max(L[i][2]));
6155	}
6156	}
6157	mini=Min(mini);
6158	maxi=Max(maxi);
6159	minmax=list(mini[1],maxi[1]);
6160	option(none);
6161	return(minmax);
6162	}
6163
6164	////////////////////////////////////////////////////////////////////////////////////
6165	//COMPUTATION OF THE COHOMOLOGY
6166	////////////////////////////////////////////////////////////////////////////////////
6167
6168	static proc findCohomology(list L,int le)
6169	{
6170	/computes the cohomology of the complex (D^i,d^i) given by D^i=C^L[2i-1] and
6171	d^i=L[2i]/
6172	def R=basering;
6173	ring r=0,(x),dp;
6174	list L=imap(R,L);
6175	list out;
6176	int i, ker, im;
6177	matrix S;
6178	option(returnSB);
6179	option(redSB);
6180	for (i=2; i<=size(L); i=i+2)
6181	{
6182	if (L[i-1]==0)
6183	{
6184	out[i div 2]=0;
6185	im=0;
6186	}
6187	else
6188	{
6189	S=matrix(syz(transpose(L[i])));
6190	if (S!=matrix(0,nrows(S),ncols(S)))
6191	{
6192	ker=ncols(S);
6193	out[i div 2]=ker-im;
6194	im=L[i-1]-ker;
6195	}
6196	else
6197	{
6198	out[i div 2]=0;////achtung geändert??????????????????????????????????????????????????!!!!!!!!!!!!!!!!!!!!!!!!!war mal out[i-1]
6199	im=L[i-1];
6200	}
6201	}
6202	}
6203	option(none);
6204	while (size(out)>le)
6205	{
6206	out=delete(out,1);
6207	}
6208	setring R;
6209	return(out);
6210	}
6211
6212	////////////////////////////////////////////////////////////////////////////////////
6213
6214
6215	static proc findCohomologyDiffForms(list L,int le)
6216	{
6217	/computes the cohomology of the complex (D^i,d^i) given by D^i=C^L[2i-1] and
6218	d^i=L[2i]/
6219	def R=basering;
6220	list outdiffforms=list(var(1));
6221	ring r=0,(x),dp;
6222	list L=imap(R,L);
6223	list out;
6224	list outdiffforms;
6225	int i, ker, im, j;
6226	matrix S;
6227	matrix concreteimage=matrix(0);
6228	module concreteimagemod=concreteimage;
6229	option(returnSB);
6230	option(redSB);
6231	matrix redS;
6232	for (i=2; i<=size(L); i=i+2)
6233	{
6234	if (L[i-1]==0)
6235	{
6236	out[i div 2]=0;
6237	im=0;
6238	concreteimage=matrix(0);
6239	concreteimagemod=concreteimage;
6240	outdiffforms[i div 2]=list();
6241	}
6242	else
6243	{
6244	S=matrix(transpose(syz(transpose(L[i]))));
6245	if (S!=matrix(0,nrows(S),ncols(S)))
6246	{
6247	ker=nrows(S);
6248	out[i div 2]=ker-im;
6249	if(out[i div 2]==0)
6250	{
6251	outdiffforms[i div 2]=list();
6252	}
6253	else
6254	{
6255	outdiffforms[i div 2]=list();
6256	if (concreteimage==matrix(0))
6257	{
6258	for (j=1; j<=nrows(S); j++)
6259	{
6260	outdiffforms[ i div 2][j]=submat(S,j,intvec(1..ncols(S)));
6261	}
6262	}
6263	else
6264	{
6265	redS=transpose(std(reduce(transpose(S),concreteimagemod)));
6266	for (j=1; j<=nrows(redS); j++)
6267	{
6268	if (submat(redS,j, intvec(1..ncols(redS)))!=matrix(0,1,ncols(redS)))
6269	{
6270	outdiffforms[i div 2][size(outdiffforms[i div 2])+1]=submat(redS,j, intvec(1..ncols(redS)));
6271	}
6272	}
6273	}
6274	}
6275	im=L[i-1]-ker;
6276	concreteimagemod=std(transpose(L[i]));
6277	concreteimage=concreteimagemod;
6278	concreteimage=transpose(concreteimage);
6279
6280
6281	//concreteimage=transpose(std(transpose(L[i])));//Achtung:hier wieder das Problem mit no Standard basis!!!!!!!!!!!!!
6282	}
6283	else
6284	{
6285	out[i div 2]=0;
6286	outdiffforms[i div 2]=0;
6287	im=L[i-1];
6288	concreteimagemod=std(transpose(L[i]));
6289	concreteimage=concreteimagemod;
6290	concreteimage=transpose(concreteimage);
6291	//concreteimage=transpose(std(transpose(L[i])));
6292	}
6293	}
6294	}
6295	option(none);
6296	while (size(out)>le)
6297	{
6298	out=delete(out,1);
6299	outdiffforms=delete(outdiffforms,1);
6300	}
6301	setring R;
6302	outdiffforms=imap(r,outdiffforms);
6303	list outall=list(out,outdiffforms);
6304	option(noredSB);
6305	option(noreturnSB);
6306	return(outall);
6307	}
6308
6309
6310
6311	////////////////////////////////////////////////////////////////////////////////////
6312	//AUXILIARY PROCEDURES
6313	////////////////////////////////////////////////////////////////////////////////////
6314
6315	static proc findPreimage(matrix m, matrix n)
6316	{
6317	def W=basering;//input wird in spaltenform angenommen, output in zeilenform
6318	list rl=ringlist(W);
6319	list rlnew=rl;
6320	rlnew[3][1]=rl[3][2];
6321	rlnew[3][2]=rl[3][1];
6322	def Wnew=ring(rlnew);
6323	setring Wnew;
6324	matrix m=imap(W,m);
6325	matrix n=imap(W,n);
6326	def Opp=opposite(Wnew);
6327	setring Opp;
6328	matrix m=oppose(Wnew,m);
6329	matrix n=oppose(Wnew,n);
6330	option(redSB);
6331	//matrix m=imap(W,m);
6332	// matrix n=imap(W,n);
6333	int i;
6334	matrix preim;
6335	if (n!=matrix(0,nrows(n),ncols(n)))
6336	{
6337	matrix con=concat(m,n);
6338	matrix s=syz(con);
6339	for (i=1; i<=ncols(s); i++)
6340	{
6341	if (s[nrows(s),i]==1)
6342	{
6343	preim=(-1)*submat(s,1..ncols(m),i);
6344	break;
6345	}
6346	}
6347	}
6348	else
6349	{
6350	matrix s=syz(m);
6351	preim=submat(s,1..ncols(m),1);
6352	}
6353	option(noredSB);
6354	setring Wnew;
6355	matrix preim=oppose(Opp,preim);
6356	setring W;
6357	matrix preim=imap(Wnew,preim);
6358	return(transpose(preim));
6359	}
6360
6361	////////////////////////////////////////////////////////////////////////////////////
6362
6363	static proc divdr(matrix m,matrix n, list #)
6364	{
6365	if (n!=matrix(0,nrows(n),ncols(n)))
6366	{
6367	m=transpose(m);
6368	n=transpose(n);
6369	matrix con=concat(m,n);
6370	matrix s=syz(con);
6371	s=submat(s,1..ncols(m),1..ncols(s));
6372	s=transpose(compress(s));
6373	}
6374	else
6375	{
6376	matrix s=transpose(syz(transpose(m)));
6377	}
6378	int i;
6379	matrix g;
6380	matrix sm;
6381	if (size(#)!=0)
6382	{
6383	for (i=1; i<=nrows(s); i++)
6384	{
6385	g=deletecol(transpose(s),i);
6386	sm=transpose(submat(s,i,intvec(1..ncols(s))));
6387	sm=reduce(sm,slimgb(g));
6388	if (sm==matrix(0,nrows(sm),ncols(sm)))
6389	{
6390	s=g;
6391	s=transpose(s);
6392	i=i-1;
6393	}
6394	}
6395	}
6396	return(s);
6397	}
6398	////////////////////////////////////////////////////////////////////////////////////
6399
6400	static proc matrixLift(matrix M,matrix N)
6401	{
6402	intvec v=option(get);
6403	option(none);
6404	matrix l=transpose(lift(transpose(M),transpose(N)));
6405	option(set,v);
6406	return(l);
6407	}
6408
6409	////////////////////////////////////////////////////////////////////////////////////
6410
6411	static proc VdStrictGB (matrix M,int d,list #)
6412	"USAGE:VdStrictGB(M,d[,v]); M a matrix, d an integer, v an optional intvec
6413	ASSUME:-basering is the nth Weyl algebra D_n @*
6414	-1<=d<=n @*
6415	-v (if given) is the shift vector on the range of M (in particular,
6416	size(v)=ncols(M)); otherwise v is assumed to be the zero shift vector
6417	RETURN:matrix N; the rows of N form a V_d-strict Groebner basis with respect to v
6418	for the module generated by the rows of M
6419	"
6420	{
6421	if (M==matrix(0,nrows(M),ncols(M)))
6422	{
6423	return (matrix(0,1,ncols(M)));
6424	}
6425	intvec op=option(get);
6426	def W =basering;
6427	int ncM=ncols(M);
6428	list Data=ringlist(W);
6429	Data[2]=list("nhv")+Data[2];
6430	Data[3][3]=Data[3][1];
6431	Data[3][1]=list("dp",intvec(1));
6432	matrix re[size(Data[2])][size(Data[2])]=UpOneMatrix(size(Data[2]));
6433	Data[5]=re;
6434	int k,l;
6435	Data[6]=transpose(concat(matrix(0,1,1),transpose(concat(matrix(0,1,1),Data[6]))));
6436	def Whom=ring(Data);// D_n[nhv] with the new commuative variable nhv
6437	setring Whom;
6438	matrix Mnew=imap(W,M);
6439	intvec v;
6440	if (size(#)!=0)
6441	{
6442	v=#[1];
6443	}
6444	if (size(v) < ncM)
6445	{
6446	v=v,0:(ncM-size(v));
6447	}
6448	Mnew=homogenize(Mnew, d, v);//homogenization of M with respect to the new variable
6449	Mnew=transpose(Mnew);
6450	Mnew=slimgb(Mnew);// computes a Groebner basis of the homogenzition of M
6451	Mnew=subst(Mnew,nhv,1);// substitution of 1 gives V_d-strict Groebner basis of M
6452	Mnew=compress(Mnew);
6453	Mnew=transpose(Mnew);
6454	setring W;
6455	M=imap(Whom,Mnew);
6456	option(set,op);
6457	return(M);
6458	}
6459
6460	////////////////////////////////////////////////////////////////////////////////////
6461
6462	static proc VdNormalForm(matrix F,matrix M,int d,intvec v,list #)
6463	"USAGE:VdNormalForm(F,M,d,v[,w]); F and M matrices, d int, v intvec, w an optional
6464	intvec
6465	ASSUME:-basering is the nth Weyl algebra D_n @*
6466	-F a n_1 x n_2-matrix and M a m_1 x m_2-matrix with m_2<=n_2 @*
6467	-d is an integer between 1 and n @*
6468	-v is a shift vector for D_n^(m_2) and hence size(v)=m_2 @*
6469	-w is a shift vector for D_n^(m_1-m_2) and hence size(v)=m_1-m_2 @*
6470	RETURN:a n_1 x n_2-matrix N such that:@*
6471	-If no optional intvec w is given:(N[i,1],..,N[i,m_2]) is a V_d-strict normal
6472	form of (F[i,1],...,F[i,m_2]) with respect to a V_d-strict Groebner basis of
6473	the rows of M and the shift vector v
6474	-If w is given:(N[i,1],..,N[i,m_2]) is chosen such that
6475	Vddeg((N[i,1],...,N[i,m_2])[v])<=Vddeg((F[i,m_2+1],...,F[i,m_1])[v]);
6476	-N[i,j]=F[i,j] for j>m_2
6477	"
6478	{
6479	int SBcom;
6480	def W =basering;
6481	int c=ncols(M);
6482	matrix keepF=F;
6483	if (size(#)!=0)
6484	{
6485	intvec w=#[1];
6486	}
6487	F=submat(F,intvec(1..nrows(F)),intvec(1..c));
6488	list Data=ringlist(W);
6489	Data[2]=list("nhv")+Data[2];
6490	Data[3][3]=Data[3][1];
6491	Data[3][1]=list("dp",intvec(1));
6492	matrix re[size(Data[2])][size(Data[2])]=UpOneMatrix(size(Data[2]));
6493	Data[5]=re;
6494	int k,l,nr,nc;
6495	matrix rep[size(Data[2])][size(Data[2])];
6496	for (l=size(Data[2])-1;l>=1; l--)
6497	{
6498	for (k=l-1; k>=1;k--)
6499	{
6500	rep[k+1,l+1]=Data[6][k,l];
6501	}
6502	}
6503	Data[6]=rep;
6504	def Whom=ring(Data);//new ring D_n[nvh] this new commuative variable nhv
6505	setring Whom;
6506	matrix Mnew=imap(W,M);
6507	list forMnew=homogenize(Mnew,d,v,1);//commputes homogenization of M;
6508	Mnew=forMnew[1];
6509	int rightexp=forMnew[2];
6510	matrix Fnew=imap(W,F);
6511	matrix keepF=imap(W,keepF);
6512	matrix Fb;
6513	int cc;
6514	intvec i1,i2;
6515	matrix zeromat,subm1,subm2,zeromat2;
6516	for (l=1; l<=nrows(Fnew); l++)
6517	{
6518	if (size(#)!=0)
6519	{
6520	subm2=submat(keepF,l,((ncols(Fnew)+1)..ncols(keepF)));
6521	zeromat2=matrix(0,1,ncols(subm2));
6522	if (submat(keepF,l,((ncols(Fnew)+1)..ncols(keepF)))==zeromat2)
6523	{
6524	for (cc=1; cc<=ncols(Fnew); c++)
6525	{
6526	Fnew[l,cc]=0;
6527	}
6528	}
6529	i1=intvec(1..ncols(Fnew));
6530	subm1=submat(Fnew,l,i1);
6531	subm2=submat(keepF,l,(ncols(Fnew)+1)..ncols(keepF));
6532	zeromat=matrix(0,1,ncols(Fnew));
6533	if (VdDegnhv(subm1,d,v)>VdDegnhv(subm2,d,w)
6534	and submat(Fnew,l,intvec(1..ncols(Fnew)))!=zeromat)
6535	{
6536	//print("Reduzierung des V_d-Grades nötig");
6537	/*We need to reduce the V_d-degree. First we homogenize the
6538	lth row of Fnew*/
6539	Fb=homogenize(subm1,d,v)*(nhv^rightexp);
6540	if (SBcom==0)
6541	{
6542	/computes a V_d-strict standard basis/
6543	Mnew=slimgb(transpose(Mnew));//
6544	SBcom=1;
6545	}
6546	/computes a V_d-strict normal form for FB/
6547	Fb=transpose(reduce(transpose(Fb),Mnew));
6548	if (VdDegnhv(Fb,d,v)> VdDegnhv(subm2,d,w)
6549	and Fb!=matrix(0,nrows(Fb),ncols(Fb)))//should not happen
6550	{
6551	//print("Reduzierung fehlgeschlagen!!!!!!!!!!!!!!!!");
6552	}
6553	}
6554	else
6555	{
6556	/*condition on V_ddeg already satisfied -> no normal form
6557	computation is needed*/
6558	Fb=submat(Fnew,l,intvec(1..ncols(Fnew)));
6559	}
6560	}
6561	else
6562	{
6563	Fb=homogenize(submat(Fnew,l,intvec(1..ncols(Fnew))),d,v);
6564	if (SBcom==0)
6565	{
6566	Mnew=slimgb(transpose(Mnew));// computes a V_d-strict Groebner basis
6567	SBcom=1;
6568	}
6569	Fb=transpose(reduce(transpose(Fb),Mnew));//normal form
6570	}
6571	for (k=1; k<=ncols(Fnew);k++)
6572	{
6573	Fnew[l,k]=Fb[1,k];
6574	}
6575	}
6576	Fnew=subst(Fnew,nhv,1);//obtain normal form in D_n
6577	setring W;
6578	F=imap(Whom,Fnew);
6579	return(F);
6580	}
6581
6582	////////////////////////////////////////////////////////////////////////////////////
6583
6584	static proc homogenize (matrix M,int d,intvec v,list #)
6585	{
6586	/* we compute the F[v]-homogenization of each row of M (cf. Def. 3.4 in [OT])*/
6587	if (M==matrix(0,nrows(M),ncols(M)))
6588	{
6589	return(M);
6590	}
6591	int i,l,s, kmin, nhvexp;
6592	poly f;
6593	intvec vnm;
6594	list findmin,maxnhv,rempoly,remk,rem1,rem2;
6595	int n=(nvars(basering)-1) div 2;
6596	for (int k=1; k<=nrows(M); k++)
6597	{
6598	for (l=1; l<=ncols (M); l++)
6599	{
6600	f=M[k,l];
6601	s=size(f);
6602	for (i=1; i<=s; i++)
6603	{
6604	vnm=leadexp(f);
6605	vnm=vnm[n+2..n+d+1]-vnm[2..d+1];
6606	kmin=sum(vnm)+v[l];
6607	rem1[size(rem1)+1]=lead(f);
6608	rem2[size(rem2)+1]=kmin;
6609	findmin=insert(findmin,kmin);
6610	f=f-lead(f);
6611	}
6612	rempoly[l]=rem1;
6613	remk[l]=rem2;
6614	rem1=list();
6615	rem2=list();
6616	}
6617	if (size(findmin)!=0)
6618	{
6619	kmin=Min(findmin);
6620	}
6621	for (l=1; l<=ncols(M); l++)
6622	{
6623	if (M[k,l]!=0)
6624	{
6625	M[k,l]=0;
6626	for (i=1; i<=size(rempoly[l]);i++)
6627	{
6628	nhvexp=remk[l][i]-kmin;
6629	M[k,l]=M[k,l]+nhv^(nhvexp)*rempoly[l][i];
6630	maxnhv[size(maxnhv)+1]=nhvexp;
6631	}
6632	}
6633	}
6634	rempoly=list();
6635	remk=list();
6636	findmin=list();
6637	}
6638	maxnhv=Max(maxnhv);
6639	nhvexp=maxnhv[1];
6640	if (size(#)!=0)
6641	{
6642	return(list(M,nhvexp));//only needed for normal form computations
6643	}
6644	return(M);
6645	}
6646
6647	////////////////////////////////////////////////////////////////////////////////////
6648
6649	static proc soldr (matrix M,matrix N)
6650	{
6651	/* We compute a ncols(M) x nrows(M)-matrix C such that
6652	C[i,1]M_1+...+C[i,nrows(M)]M_(nrows(M))= e_i mod im(N),
6653	where e_i is the ith basis element on the range of M, M_j denotes the jth row
6654	of M and im(N) is generated by the rows of N */
6655	int n=nrows(M);
6656	int q=ncols(M);
6657	matrix S=concat(transpose(M),transpose(N));
6658	def W=basering;
6659	list Data=ringlist(W);
6660	list Save=Data[3];
6661	Data[3]=list(list("c",0),list("dp",intvec(1..nvars(W))));
6662	def Wmod=ring(Data);
6663	setring Wmod;
6664	matrix Smod=imap(W,S);
6665	matrix E[q][1];
6666	matrix Smod2,Smodnew;
6667	option(returnSB);
6668	int i,j;
6669	for (i=1;i<=q;i++)
6670	{
6671	E[i,1]=1;
6672	Smod2=concat(E,Smod);
6673	Smod2=syz(Smod2);
6674	E[i,1]=0;
6675	for (j=1;j<=ncols(Smod2);j++)
6676	{
6677	if (Smod2[1,j]==1)
6678	{
6679	Smodnew=concat(Smodnew,(-1)*(submat(Smod2,intvec(2..n+1),j)));
6680	break;
6681	}
6682	}
6683	}
6684	Smodnew=transpose(submat(Smodnew,intvec(1..n),intvec(2..q+1)));
6685	setring W;
6686	matrix Snew=imap(Wmod,Smodnew);
6687	option(none);
6688	return (Snew);
6689	}
6690
6691	////////////////////////////////////////////////////////////////////////////////////
6692
6693	static proc prodr (int k,int l)
6694	{
6695	if (k==0)
6696	{
6697	matrix P=unitmat(l);
6698	return (P);
6699	}
6700	matrix O[l][k];
6701	matrix P=transpose(concat(O,unitmat(l)));
6702	return (P);
6703	}
6704
6705	////////////////////////////////////////////////////////////////////////////////////
6706
6707	static proc VdDeg(matrix M,int d,intvec v,list #)
6708	{
6709	/* We assume that the basering it the nth Weyl algebra and that M is a 1 x r-
6710	matrix.
6711	We compute the V_d-deg of M with respect to the shift vector v,
6712	i.e V_ddeg(M)=max (V_ddeg(M_i)+v[i]), where k=V_ddeg(M_i) if k is the minimal
6713	integer, such that M_i can be expressed as a sum of operators
6714	x(1)^(a_1)...x(n)^(a_n)D(1)^(b_1)...*D(n)^(b_n) with
6715	a_1+..+a_d+k>=b_1+..+b_d*/
6716	int i, j, etoint;
6717	int n=nvars(basering) div 2;
6718	intvec e;
6719	list findmax;
6720	int c=ncols(M);
6721	poly l;
6722	list positionpoly,positionVd;
6723	for (i=1; i<=c; i++)
6724	{
6725	positionpoly[i]=list();
6726	positionVd[i]=list();
6727	while (M[1,i]!=0)
6728	{
6729	l=lead(M[1,i]);
6730	positionpoly[i][size(positionpoly[i])+1]=l;
6731	e=leadexp(l);
6732	e=-e[1..d]+e[n+1..n+d];
6733	e=sum(e)+v[i];
6734	etoint=e[1];
6735	positionVd[i][size(positionVd[i])+1]=etoint;
6736	findmax[size(findmax)+1]=etoint;
6737	M[1,i]=M[1,i]-l;
6738	}
6739	}
6740	if (size(findmax)!=0)
6741	{
6742	int maxVd=Max(findmax);
6743	if (size(#)==0)
6744	{
6745	return (maxVd);
6746	}
6747	}
6748	else // M is 0-modul
6749	{
6750	return(int(0));
6751	}
6752	l=0;
6753	for (i=c; i>=1; i--)
6754	{
6755	for (j=1; j<=size(positionVd[i]); j++)
6756	{
6757	if (positionVd[i][j]==maxVd)
6758	{
6759	l=l+positionpoly[i][j];
6760	}
6761	}
6762	if (l!=0)
6763	{
6764	/*returns the largest component that has maximal V_d-degree
6765	and its terms of maximal V_d-deg (needed for globalBFun)*/
6766	return (list(l,i));
6767	}
6768	}
6769	}
6770
6771	////////////////////////////////////////////////////////////////////////////////////
6772
6773	static proc VdDegTilde(matrix M,int d,intvec v,list #)
6774	{
6775	/* We assume that the basering it the nth Weyl algebra and that M is a 1 x r-
6776	matrix.
6777	We compute the \tilde(V_d)-deg of M with respect to the shift vector v,
6778	i.e \tilde(V_d)deg(M)=max (\tilde(V_d)deg(M_i)+v[i]), where k=\tilde(V_d)deg(M_i) if k is the minimal
6779	integer, such that M_i can be expressed as a sum of operators
6780	x(1)^(a_1)...x(n)^(a_n)D(1)^(b_1)...*D(n)^(b_n) with
6781	a_1+..+a_d<=b_1+..+b_d+k*/
6782	int i, j, etoint;
6783	int n=nvars(basering) div 2;
6784	intvec e;
6785	list findmax;
6786	int c=ncols(M);
6787	poly l;
6788	list positionpoly,positionVd;
6789	for (i=1; i<=c; i++)
6790	{
6791	positionpoly[i]=list();
6792	positionVd[i]=list();
6793	while (M[1,i]!=0)
6794	{
6795	l=lead(M[1,i]);
6796	positionpoly[i][size(positionpoly[i])+1]=l;
6797	e=leadexp(l);
6798	e=e[1..d]-e[n+1..n+d];
6799	e=sum(e)+v[i];
6800	etoint=e[1];
6801	positionVd[i][size(positionVd[i])+1]=etoint;
6802	findmax[size(findmax)+1]=etoint;
6803	M[1,i]=M[1,i]-l;
6804	}
6805	}
6806	if (size(findmax)!=0)
6807	{
6808	int maxVd=Max(findmax);
6809	if (size(#)==0)
6810	{
6811	return (maxVd);
6812	}
6813	}
6814	else // M is 0-modul
6815	{
6816	return(int(0));
6817	}
6818	l=0;
6819	for (i=c; i>=1; i--)
6820	{
6821	for (j=1; j<=size(positionVd[i]); j++)
6822	{
6823	if (positionVd[i][j]==maxVd)
6824	{
6825	l=l+positionpoly[i][j];
6826	}
6827	}
6828	if (l!=0)
6829	{
6830	/*returns the largest component that has maximal V_d-degree
6831	and its terms of maximal V_d-deg (needed for globalBFun)*/
6832	return (list(l,i));
6833	}
6834	}
6835	}
6836
6837	////////////////////////////////////////////////////////////////////////////////////
6838
6839	static proc VdDegnhv(matrix M,int d,intvec v,list #)
6840	{
6841	/* As the procedure VdDeg, but the basering is the nth Weyl algebra
6842	with a commutative variable nhv*/
6843	int i,j,etoint;
6844	int n=nvars(basering) div 2;
6845	intvec e;
6846	int etoint;
6847	list findmax;
6848	int c=ncols(M);
6849	poly l;
6850	list positionpoly;
6851	list positionVd;
6852	for (i=1; i<=c; i++)
6853	{
6854	positionpoly[i]=list();
6855	positionVd[i]=list();
6856	while (M[1,i]!=0)
6857	{
6858	l=lead(M[1,i]);
6859	positionpoly[i][size(positionpoly[i])+1]=l;
6860	e=leadexp(l);
6861	e=-e[2..d+1]+e[n+2..n+d+1];
6862	e=sum(e)+v[i];
6863	etoint=e[1];
6864	positionVd[i][size(positionVd[i])+1]=etoint;
6865	findmax[size(findmax)+1]=etoint;
6866	M[1,i]=M[1,i]-l;
6867	}
6868	}
6869	if (size(findmax)!=0)
6870	{
6871	int maxVd=Max(findmax);
6872	if (size(#)==0)
6873	{
6874	return (maxVd);
6875	}
6876	}
6877	else // M is 0-modul
6878	{
6879	return(int(0));
6880	}
6881	}
6882
6883	////////////////////////////////////////////////////////////////////////////////////
6884
6885	static proc deletecol(matrix M,int l)
6886	{
6887	if (ncols(M)==1)
6888	{
6889	return(M);
6890	}
6891	int s=ncols(M);
6892	if (l==1)
6893	{
6894	M=submat(M,(1..nrows(M)),(2..ncols(M)));
6895	return(M);
6896	}
6897	if (l==s)
6898	{
6899	M=submat(M,(1..nrows(M)),(1..(ncols(M)-1)));
6900	return(M);
6901	}
6902	intvec v=(1..(l-1)),((l+1)..s);
6903	M=submat(M,(1..nrows(M)),v);
6904	return(M);
6905	}
6906
6907	////////////////////////////////////////////////////////////////////////////////////
6908
6909	static proc mHom(poly f)
6910	{/for globalBFunOT/
6911	poly g;
6912	poly l;
6913	poly add;
6914	intvec e;
6915	list minint;
6916	list remf;
6917	int i;
6918	int j;
6919	int n=nvars(basering) div 4;
6920	if (f==0)
6921	{
6922	return(f);
6923	}
6924	while (f!=0)
6925	{
6926	l=lead(f);
6927	e=leadexp(l);
6928	remf[size(remf)+1]=list();
6929	remf[size(remf)][1]=l;
6930	for (i=1; i<=n; i++)
6931	{
6932	remf[size(remf)][i+1]=-e[2n+i]+e[3n+i];
6933	if (size(minint)<i)
6934	{
6935	minint[i]=list();
6936	}
6937	minint[i][size(minint[i])+1]=-e[2n+i]+e[3n+i];
6938	}
6939	f=f-l;
6940	}
6941	for (i=1; i<=n; i++)
6942	{
6943	minint[i]=Min(minint[i]);
6944	}
6945	for (i=1; i<=size(remf); i++)
6946	{
6947	add=remf[i][1];
6948	for (j=1; j<=n; j++)
6949	{
6950	add=v(j)^(remf[i][j+1]-minint[j])*add;
6951	}
6952	g=g+add;
6953	}
6954	return (g);
6955	}
6956
6957	////////////////////////////////////////////////////////////////////////////////////
6958
6959	static proc permuteVar(list L,int n)
6960	{/for globalBFunOT/
6961	if (typeof(L[1])=="intvec")
6962	{
6963	intvec v=L[1];
6964	}
6965	else
6966	{
6967	intvec v=(1:L[1]),(0:L[1]);
6968	}
6969	int i;int k; int indi=0;
6970	int j;
6971	int s=size(v);
6972	poly e;
6973	intvec fore;
6974	for (i=2; i<=size(v); i=i+2)
6975	{
6976
6977	if (v[i]!=0)
6978	{
6979	j=i+1;
6980	while (v[j]!=0)
6981	{
6982	j=j+1;
6983	}
6984	v[i]=0;
6985	v[j]=1;
6986	fore=0;
6987	indi=0;
6988	for (k=1; k<=size(v); k++)
6989	{
6990	if (k!=i and k!=j)
6991	{
6992	if (indi==0)
6993	{
6994	indi=1;
6995	fore[1]=v[k];
6996	}
6997	else
6998	{
6999	fore[size(fore)+1]=v[k];
7000	}
7001	}
7002	}
7003	e=e-(j-i)*permutevar(list(fore),n);
7004	}
7005	}
7006	e=e+s(n)^(size(v) div 2);
7007	return (e);
7008	}
7009
7010	////////////////////////////////////////////////////////////////////////////////////
7011
7012	static proc makeHomogenizedWeyl(int n,list #)
7013	{
7014	/modified version of the procedure makeWeyl() from the library nctools.lib/
7015	/*Creates the nth homogenized Weyl algebra with variables x(1),..,x(n),D(1),..,
7016	D(n) and homogenization variable h, i.e. it holds x(i)D(i)=D(i)x(1)+h^2.
7017	If # contains on intvec v, we assign weight v[i] to the ith module component.*/
7018	if (n<1)
7019	{
7020	print*("Incorrect input");
7021	return();
7022	}
7023	if (n ==1)
7024	{
7025	ring @rr = 0,(x(1),D(1),h),dp;
7026	}
7027	else
7028	{
7029	ring @rr = 0,(x(1..n),D(1..n),h),dp;
7030	}
7031	setring @rr;
7032	int i=0;
7033	if (size(#)==0)
7034	{
7035	def @rrr = homogenizedWeyl(i);
7036	}
7037	else
7038	{
7039	def @rrr=homogenizedWeyl(i,#);
7040	}
7041	return(@rrr);
7042	}
7043
7044	////////////////////////////////////////////////////////////////////////////////////
7045
7046	static proc makeHomogenizedWeylTilde(int n,list #)
7047	{
7048	/modified version of the procedure makeWeyl() from the library nctools.lib/
7049	/*Creates the nth homogenized Weyl algebra with variables x(1),..,x(n),D(1),..,
7050	D(n) and homogenization variable h, i.e. it holds x(i)D(i)=D(i)x(1)+h^2.
7051	If # contains on intvec v, we assign weight v[i] to the ith module component.*/
7052	if (n<1)
7053	{
7054	print*("Incorrect input");
7055	return();
7056	}
7057	if (n ==1)
7058	{
7059	ring @rr = 0,(x(1),D(1),h),dp;
7060	}
7061	else
7062	{
7063	ring @rr = 0,(x(1..n),D(1..n),h),dp;
7064	}
7065	setring @rr;
7066	int i=1;
7067	if (size(#)==0)
7068	{
7069	def @rrr = homogenizedWeyl(i);
7070	}
7071	else
7072	{
7073	def @rrr=homogenizedWeyl(i,#);
7074	}
7075	return(@rrr);
7076	}
7077
7078	////////////////////////////////////////////////////////////////////////////////////
7079
7080	static proc makeConverseHomogenizedWeylTilde(int n,list #)
7081	{
7082	/modified version of the procedure makeWeyl() from the library nctools.lib/
7083	/*Creates the nth homogenized Weyl algebra with variables x(1),..,x(n),D(1),..,
7084	D(n) and homogenization variable h, i.e. it holds x(i)D(i)=D(i)x(1)+h^2.
7085	If # contains on intvec v, we assign weight v[i] to the ith module component.*/
7086	if (n<1)
7087	{
7088	print*("Incorrect input");
7089	return();
7090	}
7091	if (n ==1)
7092	{
7093	ring @rr = 0,(D(1),x(1),h),dp;
7094	}
7095	else
7096	{
7097	ring @rr = 0,(D(1..n),x(1..n),h),dp;
7098	}
7099	setring @rr;
7100	int i=1;
7101	if (size(#)==0)
7102	{
7103	def @rrr = converseHomogenizedWeyl(i);
7104	}
7105	else
7106	{
7107	def @rrr=converseHomogenizedWeyl(i,#);
7108	}
7109	return(@rrr);
7110	}
7111
7112	////////////////////////////////////////////////////////////////////////////////////
7113
7114	static proc converseHomogenizedWeyl (int tilde,list #)
7115	{
7116	/modified version of the procedure Weyl() from the library nctools.lib/
7117	/*Creates a homogenized Weyl algebra structure on the basering. We assume
7118	n=nvars(basering) is odd. The first (n-1)/2 variables will be treated as the
7119	x(i), the next (n-1)/2 as the corresponding differentials D(i) and the last as
7120	the homogenization variable h, i.e. it holds x(i)D(i)=D(i)x(1)+h^2.
7121	If # contains on intvec v, we assign weight v[i] to the ith module component.*/
7122	string rname=nameof(basering);
7123	if ( rname == "basering") // i.e. no ring has been set yet
7124	{
7125	"You have to call the procedure from the ring";
7126	return();
7127	}
7128	int nv = nvars(basering);
7129	int N = (nv-1) div 2;
7130	if (((nv-1) % 2) != 0)
7131	{
7132	"Cannot create homogenized Weyl structure for an even number of generators";
7133	return();
7134	}
7135	matrix @D[nv][nv];
7136	int i;
7137	for ( i=1; i<=N; i++ )
7138	{
7139	@D[i,N+i]=-h^2;
7140	}
7141	def @R = nc_algebra(1,@D);
7142	setring @R;
7143	list RL=ringlist(@R);
7144	intvec v;
7145	/we need this ordering for Groebner basis computations/
7146	if (tilde==0)
7147	{
7148	for (i=1; i<=N; i++)
7149	{
7150	v[i]=-1;
7151	v[N+i]=1;
7152	}
7153	}
7154	else
7155	{
7156	for (i=1; i<=N; i++)
7157	{
7158	v[i]=1;
7159	v[N+i]=-1;
7160	}
7161	}
7162	v[nv]=0;
7163	/* we assign weights to module components*/
7164	if (size(#)!=0)
7165	{
7166	if (typeof(#[1])=="intvec")
7167	{
7168	intvec m=#[1];
7169	for (i=1; i<=size(m); i++)
7170	{
7171	v[size(v)+1]=m[i];//assigns weight m[i] to the ith module component
7172	}
7173	RL[3]=insert(RL[3],list("am",v));
7174	}
7175	else
7176	{
7177	RL[3]=insert(RL[3],list("a",v));
7178	}
7179	}
7180	else
7181	{
7182	RL[3]=insert(RL[3],list("a",v));
7183	}
7184	intvec w=(1:nv);
7185	if (size(#)>=2)
7186	{
7187	if (typeof(#[2])=="intvec")
7188	{
7189	intvec n=#[2];
7190	for (i=1; i<=size(n); i++)
7191	{
7192	w[size(w)+1]=n[i];
7193	}
7194	RL[3]=insert(RL[3],list("am",w));
7195	}
7196	else
7197	{
7198	RL[3]=insert(RL[3],list("a",w));
7199	}
7200	}
7201	else
7202	{
7203	RL[3]=insert(RL[3],list("a",w));
7204	}
7205	/this ordering is needed for globalBFun and globalBFunOT/
7206	list saveord=RL[3][3];
7207	RL[3][3]=RL[3][4];
7208	RL[3][4]=saveord;
7209	intvec notforh=(1:(size(RL[3][4][2])-1));
7210	RL[3][4][2]=notforh;
7211	RL[3][5]=list("dp",1);
7212	def @@R=ring(RL);
7213	return(@@R);
7214	}
7215	///////////////////////////////////////////////////////////////////////////////////
7216
7217	static proc homogenizedWeyl (int tilde,list #)
7218	{
7219	/modified version of the procedure Weyl() from the library nctools.lib/
7220	/*Creates a homogenized Weyl algebra structure on the basering. We assume
7221	n=nvars(basering) is odd. The first (n-1)/2 variables will be treated as the
7222	x(i), the next (n-1)/2 as the corresponding differentials D(i) and the last as
7223	the homogenization variable h, i.e. it holds x(i)D(i)=D(i)x(1)+h^2.
7224	If # contains on intvec v, we assign weight v[i] to the ith module component.*/
7225	string rname=nameof(basering);
7226	if ( rname == "basering") // i.e. no ring has been set yet
7227	{
7228	"You have to call the procedure from the ring";
7229	return();
7230	}
7231	int nv = nvars(basering);
7232	int N = (nv-1) div 2;
7233	if (((nv-1) % 2) != 0)
7234	{
7235	"Cannot create homogenized Weyl structure for an even number of generators";
7236	return();
7237	}
7238	matrix @D[nv][nv];
7239	int i;
7240	for ( i=1; i<=N; i++ )
7241	{
7242	@D[i,N+i]=h^2;
7243	}
7244	def @R = nc_algebra(1,@D);
7245	setring @R;
7246	list RL=ringlist(@R);
7247	intvec v;
7248	/we need this ordering for Groebner basis computations/
7249	if (tilde==0)
7250	{
7251	for (i=1; i<=N; i++)
7252	{
7253	v[i]=-1;
7254	v[N+i]=1;
7255	}
7256	}
7257	else
7258	{
7259	for (i=1; i<=N; i++)
7260	{
7261	v[i]=1;
7262	v[N+i]=-1;
7263	}
7264	}
7265	v[nv]=0;
7266	/* we assign weights to module components*/
7267	if (size(#)!=0)
7268	{
7269	if (typeof(#[1])=="intvec")
7270	{
7271	intvec m=#[1];
7272	for (i=1; i<=size(m); i++)
7273	{
7274	v[size(v)+1]=m[i];//assigns weight m[i] to the ith module component
7275	}
7276	RL[3]=insert(RL[3],list("am",v));
7277	}
7278	else
7279	{
7280	RL[3]=insert(RL[3],list("a",v));
7281	}
7282	}
7283	else
7284	{
7285	RL[3]=insert(RL[3],list("a",v));
7286	}
7287	intvec w=(1:nv);
7288	if (size(#)>=2)
7289	{
7290	if (typeof(#[2])=="intvec")
7291	{
7292	intvec n=#[2];
7293	for (i=1; i<=size(n); i++)
7294	{
7295	w[size(w)+1]=n[i];
7296	}
7297	RL[3]=insert(RL[3],list("am",w));
7298	}
7299	else
7300	{
7301	RL[3]=insert(RL[3],list("a",w));
7302	}
7303	}
7304	else
7305	{
7306	RL[3]=insert(RL[3],list("a",w));
7307	}
7308	/this ordering is needed for globalBFun and globalBFunOT/
7309	list saveord=RL[3][3];
7310	RL[3][3]=RL[3][4];
7311	RL[3][4]=saveord;
7312	intvec notforh=(1:(size(RL[3][4][2])-1));
7313	RL[3][4][2]=notforh;
7314	RL[3][5]=list("dp",1);
7315	def @@R=ring(RL);
7316	return(@@R);
7317	}
7318
7319	////////////////////////////////////////////////////////////////////////////////////
7320
7321	static proc nHomogenize (matrix M,list #)
7322	{
7323	/* # may contain an intvec v, if no intvec is given, we assume that v=(0:ncols(M))
7324	We compute the h[v]-homogenization of the rows of M as in Definition 9.2 [OT]*/
7325	int l; poly f; int s; int i; intvec vnm;int kmin; list findmax;
7326	int n=(nvars(basering)-1) div 2;
7327	list rempoly;
7328	list remk;
7329	list rem1;
7330	list rem2;
7331	list maxhexp;
7332	int hexp;
7333	intvec v=(0:ncols(M));
7334	if (size(#)!=0)
7335	{
7336	if (typeof(#[1])=="intvec")
7337	{
7338	v=#[1];
7339	}
7340	}
7341	if (size(v)<ncols(M))
7342	{
7343	for (i=size(v)+1; i<=ncols(M); i++)
7344	{
7345	v[i]=0;
7346	}
7347	}
7348	for (int k=1; k<=nrows(M); k++)
7349	{
7350	for (l=1; l<=ncols (M); l++)
7351	{
7352	f=M[k,l];
7353	s=size(f);
7354	for (i=1; i<=s; i++)
7355	{
7356	vnm=leadexp(f);
7357	kmin=sum(vnm)+v[l];
7358	rem1[size(rem1)+1]=lead(f);
7359	rem2[size(rem2)+1]=kmin;
7360	findmax=insert(findmax,kmin);
7361	f=f-lead(f);
7362	}
7363	rempoly[l]=rem1;
7364	remk[l]=rem2;
7365	rem1=list();
7366	rem2=list();
7367	}
7368	if (size(findmax)!=0)
7369	{
7370	kmin=Max(findmax);
7371	}
7372	else
7373	{
7374	kmin=0;
7375	}
7376	for (l=1; l<=ncols(M); l++)
7377	{
7378	if (M[k,l]!=0)
7379	{
7380	M[k,l]=0;
7381	for (i=1; i<=size(rempoly[l]);i++)
7382	{
7383	hexp=kmin-remk[l][i];
7384	maxhexp[size(maxhexp)+1]=hexp;
7385	M[k,l]=M[k,l]+h^hexp*rempoly[l][i];
7386	}
7387	}
7388	}
7389	rempoly=list();
7390	remk=list();
7391	findmax=list();
7392	}
7393	if (size(maxhexp)!=0)
7394	{
7395	maxhexp=Max(maxhexp);
7396	hexp=maxhexp[1];
7397	}
7398	else
7399	{
7400	hexp=0;
7401	}
7402	if (size(#)>1)
7403	{
7404	list forreturn=M,hexp;
7405
7406	return(forreturn);
7407	}
7408	return(M);
7409	}
7410
7411	////////////////////////////////////////////////////////////////////////////////////
7412
7413	static proc max(int i,int j)
7414	{
7415	if(i>j){return(i);}
7416	return(j);
7417	}
7418
7419	////////////////////////////////////////////////////////////////////////////////////
7420
7421	static proc nDeg (matrix M,intvec m)
7422	{/*we compute an intvec n such that n[i]=max(deg(M[i,j])+m[j]\|M[i,j]!=0) (where deg
7423	stands for the total degree) if (M[i,j]!=0 for some j) and n[i]=0 else*/
7424	int i; int j;
7425	intvec n;
7426	list L;
7427	for (i=1; i<=nrows(M); i++)
7428	{
7429	L=list();
7430	for (j=1; j<=ncols(M); j++)
7431	{
7432	if (M[i,j]!=0)
7433	{
7434	L=insert(L,deg(M[i,j])+m[j]);
7435	}
7436	}
7437	if (size(L)==0)
7438	{
7439	n[i]=0;
7440	}
7441	else
7442	{
7443	n[i]=Max(L);
7444	}
7445	}
7446	return(n);
7447	}
7448
7449	////////////////////////////////////////////////////////////////////////////////////
7450
7451	static proc minIntRoot(list L,list #)
7452	"USAGE:minIntRoot(L [,M]); L list, M optinonal list
7453	ASSUME:L a list of univariate polynomials with rational coefficients @*
7454	the variable of the polynomial is s if size(#)==0 (needed for proc
7455	MVComplex) and t else (needed for globalBFun)
7456	RETURN:-if size(#)==0: int i, where i is an integer root of one of the polynomials
7457	and it is minimal with respect to that property@*
7458	-if size(#)!=0: list L=(i,j), where i is as above and j is an integer root
7459	of one of the polynomials and is maximal with respect to that property (if
7460	an integer root exists) or L=list() else
7461	"
7462	{
7463	def B=basering;
7464	if (size(#)==0)
7465	{
7466	ring rnew=0,s,dp;
7467	}
7468	else
7469	{
7470	ring rnew=0,t,dp;
7471	}
7472	list L=imap(B,L);
7473
7474	int i;
7475	int j;
7476	number isint;
7477	list possmin;
7478	ideal allfac;
7479	list allfacs;
7480	for (i=1; i<=size(L); i++)
7481	{
7482	allfac=factorize(L[i],1);
7483	for (j=1; j<=ncols(allfac); j++)
7484	{
7485	allfacs[j]=allfac[j];
7486	}
7487	for (j=1; j<=size(allfacs); j++)
7488	{
7489	if (deg(allfacs[j])==1)
7490	{
7491	isint=number(subst(allfacs[j],var(1),0)/leadcoef(allfacs[j]));
7492	if (isint-int(isint)==0)
7493	{
7494	possmin[size(possmin)+1]=int(isint);
7495	}
7496	}
7497	}
7498	allfacs=list();
7499	}
7500	int zerolist;
7501	if (size(possmin)!=0)
7502	{
7503	int miniroot=(-1)*Max(possmin);
7504	int maxiroot=(-1)*Min(possmin);
7505	}
7506	else
7507	{
7508	zerolist=1;
7509	}
7510	setring B;
7511	if (size(#)==0)
7512	{
7513	return(miniroot);
7514	}
7515	else
7516	{
7517	if (zerolist==0)
7518	{
7519	return(list(miniroot,maxiroot));
7520	}
7521	else
7522	{
7523	return(list());
7524	}
7525	}
7526	}
7527
7528	////////////////////////////////////////////////////////////////////////////////////
7529
7530	proc converseWeyl(list #)
7531	{
7532	string rname=nameof(basering);
7533	int @chr = 0;
7534	int nv = nvars(basering);
7535	int N = nv div 2;
7536	matrix @D[nv][nv];
7537	int i;
7538	for ( i=1; i<=N; i++)
7539	{
7540	@D[i,N+i]=-1;
7541	}
7542	def @R = nc_algebra(1,@D);
7543	return(@R);
7544	}
7545
7546	////////////////////////////////////////////////////////////////////////////////////
7547
7548	proc makeConverseWeyl(int n, list #)
7549	{
7550	if (n==1)
7551	{
7552	ring @rr = 0,(D(1),x(1)),dp;
7553	}
7554	else
7555	{
7556	ring @rr = 0,(D(1..n),x(1..n)),dp;
7557	}
7558	setring @rr;
7559	def @rrr = converseWeyl();
7560	return(@rrr);
7561	}
7562
7563	////////////////////////////////////////////////////////////////////////////////////
7564
7565	proc makeOmega(int n)
7566	{
7567	def R=basering;
7568	int i;
7569	int j,k,l;
7570	list omega;
7571	omega[1]=list(list(list()));
7572	omega[2]=list();
7573	for (i=1; i<=n; i++)
7574	{
7575	omega[2][i]=list(i);
7576	}
7577	for (i=2; i<=n; i++)
7578	{
7579	omega[i+1]=list();
7580	for (j=1; j<=size(omega[i]); j++)
7581	{
7582	if (omega[i][j][size(omega[i][j])]<n)
7583	{
7584	for (k=omega[i][j][size(omega[i][j])]+1; k<=n; k++)
7585	{
7586	omega[i+1][size(omega[i+1])+1]=omega[i][j];
7587	omega[i+1][size(omega[i+1])][size( omega[i+1][size(omega[i+1])])+1]=k;
7588	}
7589	}
7590	}
7591	}
7592	list omegamaps;
7593	matrix om;
7594	list lms;
7595	omegamaps[1]=matrix(0,n,1);
7596	for (i=1; i<=n; i++)
7597	{
7598	omegamaps[1][i,1]=var(n+i);
7599	}
7600	for (i=2; i<=n; i++)
7601	{
7602	om=matrix(0,size(omega[i+1]),size(omega[i]));
7603	for (k=1; k<=size(omega[i]); k++)
7604	{
7605	for (l=1; l<=size(omega[i+1]); l++)
7606	{
7607	lms=LMSubset(omega[i][k],omega[i+1][l],1);
7608	om[l,k]=lms[2]*var(n+lms[1]);
7609	}
7610	}
7611	omegamaps[i]=om;
7612	}
7613	omegamaps[n+1]=matrix(0,1,1);
7614	list allomega;
7615	for (i=1; i<=n+1; i++)
7616	{
7617	allomega[2*i]=omega[n+2-i];
7618	allomega[2*i-1]=omegamaps[n+2-i];
7619	}
7620	return(allomega);
7621	}
7622
7623	////////////////////////////////////////////////////////////////////////////////////
7624
7625	static proc makeDoubleComplex(list L, list M, list Q, list G)
7626	{
7627	list doublecomplex;
7628	int i,j,k,l;
7629	int s1;
7630	int s2;
7631	int c;
7632	int d;
7633	list gens=list();
7634	for (i=1; i<=size(L) div 2; i++)
7635	{
7636	doublecomplex[i]=list();
7637	for (j=1; j<=size(M) div 2; j++)
7638	{
7639	doublecomplex[i][j]=list();
7640	doublecomplex[i][j]=list(M[2j]+list(L[2i-1]));
7641	gens=list();
7642	doublecomplex[i][j][6]=G[i];
7643	if (size(Q[i])!=0)
7644	{
7645	doublecomplex[i][j][4]=tensor(unitmat(size(M[2*j])),Q[i]);
7646	for (c=1; c<=size(M[2*j]); c++)
7647	{
7648	for (d=1; d<=ncols(Q[i]); d++)
7649	{
7650	gens[size(gens)+1]=list(M[2*j][c],d);
7651	}
7652	}
7653	doublecomplex[i][j][5]=gens;
7654	}
7655	else
7656	{
7657	doublecomplex[i][j][4]=list();
7658	doublecomplex[i][j][5]=list();
7659	}
7660	if (size(Q[i])!=0)
7661	{
7662	if (Q[i]==matrix(0,nrows(Q[i]),ncols(Q[i])))
7663	{
7664	doublecomplex[i][j][4]=list();
7665	}
7666	}
7667	if (j!=1)
7668	{
7669	s1=(size(doublecomplex[i][j-1][1])-1)*doublecomplex[i][j-1][1][size(doublecomplex[i][j-1][1])];
7670	s2=(size(doublecomplex[i][j][1])-1)*doublecomplex[i][j][1][size(doublecomplex[i][j][1])];
7671	if (s1==0 or s2==0)
7672	{
7673	doublecomplex[i][j-1][3]=list();
7674	}
7675	else
7676	{
7677	doublecomplex[i][j-1][3]=tensor(M[2j-1],unitmat(L[2i-1]));
7678	}
7679
7680	}
7681	if (j==size(M) div 2)
7682	{
7683	doublecomplex[i][j][3]=list();
7684	}
7685	if (i!=1)
7686	{
7687	s1=(size(doublecomplex[i-1][j][1])-1)*doublecomplex[i-1][j][1][size(doublecomplex[i-1][j][1])];
7688	s2=(size(doublecomplex[i][j][1])-1)*doublecomplex[i][j][1][size(doublecomplex[i][j][1])];
7689	if (s1==0 or s2==0)
7690	{
7691	doublecomplex[i-1][j][2]=list();
7692	}
7693	else
7694	{
7695	doublecomplex[i-1][j][2]=tensor(unitmat(size(M[2j])),L[2(i-1)]);
7696	}
7697	}
7698	if (i==size(L) div 2)
7699	{
7700	doublecomplex[i][j][2]=list();
7701	}
7702	}
7703	}
7704	return(doublecomplex);
7705	}
7706
7707	////////////////////////////////////////////////////////////////////////////////////
7708
7709	static proc transferDiffforms(matrix m, list L)
7710	{
7711	int i;
7712	list transfered;
7713	if (size(L[4])==0)
7714	{
7715	return(list());
7716	}
7717	if (size(L[5])==0)
7718	{
7719	return(list());
7720	}
7721	m=m*L[4];
7722	list transferedm=list();
7723	int si=L[5][size(L[5])][2];//Anzahl der direkten Summanden in \oplus R_F_I
7724	matrix fortrans=matrix(0,1,si);
7725	list omegagen=list();
7726	list save=list();
7727	int t;
7728	int c;
7729	int j;
7730	list converteddiff;
7731	vector w;
7732	poly p=1;
7733	for (i=1; i<=ncols(m); i++)
7734	{
7735	if (m[1,i]!=0)
7736	{
7737	if (size(omegagen)==0)
7738	{
7739	omegagen=L[5][i][1];
7740	fortrans[1,L[5][i][2]]= fortrans[1,L[5][i][2]]+m[1,i];
7741	}
7742	else
7743	{
7744	t=0;
7745	for (j=1; j<=size(omegagen);j++)
7746	{
7747	if (size(omegagen[j])!=0)
7748	{
7749	if (omegagen[j]!=L[5][i][1][j])
7750	{
7751	t=1;
7752	}
7753	}
7754	}
7755	if (t==0)
7756	{
7757	fortrans[1,L[5][i][2]]= fortrans[1,L[5][i][2]]+m[1,i];
7758	}
7759	else
7760	{
7761	converteddiff=list();
7762	for (j=1; j<=ncols(fortrans); j++)
7763	{
7764	if (fortrans[1,j]!=0)
7765	{
7766	w=[p,L[6][j]];
7767	converteddiff[j]=dmodActionRat(fortrans[1,j],w);
7768	}
7769	else
7770	{
7771	converteddiff[j]=0;
7772	}
7773
7774	}
7775	save[size(save)+1]=list(converteddiff,omegagen);
7776	omegagen=L[5][i][1];
7777	fortrans=matrix(0,1,si);
7778	fortrans[1,L[5][i][2]]= fortrans[1,L[5][i][2]]+m[1,i];
7779	}
7780	}
7781	}
7782	}
7783	if (fortrans==matrix(0,1,si))
7784	{
7785	return(list());
7786	}
7787	converteddiff=list();
7788	for (j=1; j<=ncols(fortrans); j++)
7789	{
7790	if (fortrans[1,j]!=0)
7791	{
7792	w=[p,L[6][j]];
7793	converteddiff[j]=dmodActionRat(fortrans[1,j],w);
7794	}
7795	else
7796	{
7797	converteddiff[j]=0;
7798	}
7799	}
7800	save[size(save)+1]=list(converteddiff,omegagen);
7801	return(save);
7802	}
7803
7804	////////////////////////////////////////////////////////////////////////////////////
7805	////////////////////////////////////////////////////////////////////////////////////
7806	////////////////////////////////////////////////////////////////////////////////////
7807	/*
7808	////////////////////////////////////////////////////////////////////////////////////
7809	FURTHER EXAMPLES FOR TESTING THE PROCEDURES
7810	////////////////////////////////////////////////////////////////////////////////////
7811	LIB "derham.lib";
7812
7813	//----------------------------------------
7814	//EXAMPLE 1
7815	//----------------------------------------
7816	ring r=0,(x,y),dp;
7817	poly f=y2-x3-2x+3;
7818	list L=deRhamCohomology(f);
7819	L;
7820	kill r;
7821
7822	//----------------------------------------
7823	//EXAMPLE 2
7824	//----------------------------------------
7825	ring r=0,(x,y),dp;
7826	poly f=y2-x3-x;
7827	list L=deRhamCohomology(f);
7828	L;
7829	kill r;
7830
7831	//----------------------------------------
7832	//EXAMPLE 3
7833	//----------------------------------------
7834	ring r=0,(x,y),dp;
7835	list C=list(x2-1,(x+1)y,y(y2+2x+1));
7836	list L=deRhamCohomology(C);
7837	L;
7838	kill r;
7839
7840	//----------------------------------------
7841	//EXAMPLE 4
7842	//----------------------------------------
7843	ring r=0,(x,y,z),dp;
7844	list C=list(x(x-1),y,z(z-1),z*(x-1));
7845	list L=deRhamCohomology(C);
7846	L;
7847	kill r;
7848
7849	//----------------------------------------
7850	//EXAMPLE 5
7851	//----------------------------------------
7852	ring r=0,(x,y,z),dp;
7853	list C=list(xy,yz);
7854	list L=deRhamCohomology(C,"Vdres");
7855	L;
7856	kill r;
7857
7858	//----------------------------------------
7859	//EXAMPLE 6
7860	//----------------------------------------
7861	ring r=0,(x,y,z,u),dp;
7862	list C=list(x,y,z,u);
7863	list L=deRhamCohomology(C);
7864	L;
7865	kill r;
7866
7867	//----------------------------------------
7868	//EXAMPLE 7
7869	//----------------------------------------
7870	ring r=0,(x,y,z),dp;
7871	poly f=x3+y3+z3;
7872	list L=deRhamCohomology(f);
7873	L;
7874	kill r;
7875
7876	//----------------------------------------
7877	//EXAMPLE 8
7878	//----------------------------------------
7879	ring r=0,(x,y,z),dp;
7880	poly f=x2+y2+z2;
7881	list L=deRhamCohomology(f,"Vdres");
7882	L;
7883	kill r;
7884
7885	//----------------------------------------
7886	//EXAMPLE 9
7887	//----------------------------------------
7888	ring r=0,(x,y,z,u),dp;
7889	list C=list(x2+y2+z2,u);
7890	list L=deRhamCohomology(C);
7891	L;
7892	kill r;
7893
7894
7895	//----------------------------------------
7896	//EXAMPLE 10
7897	//----------------------------------------
7898	ring r=0,(x,y,z),dp;
7899	list C=list((x*(y-1),y2-1));
7900	list L=deRhamCohomology(C);
7901	L;
7902	kill r;
7903
7904
7905	*/

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

Download in other formats:

Original Format