# source:git/Singular/LIB/derham.lib@0e8a5a

spielwiese
Last change on this file since 0e8a5a was 0e8a5a, checked in by Hans Schoenemann <hannes@…>, 10 years ago
new version of derham.lib
• Property mode set to 100644
File size: 228.7 KB
Line
1///////////////////////////////////////////////////////////////////////////////
2version="";
3category="Noncommutative";
4info="
5LIBRARY:  derham.lib      Computation of deRham cohomology
6AUTHORS:  Cornelia Rottner, rottner@mathematik.uni-kl.de
7OVERVIEW:
8PROCEDURES:
9
10";
11
12
13LIB "nctools.lib";
14LIB "matrix.lib";
15LIB "qhmoduli.lib";
16LIB "general.lib";
17LIB "dmod.lib";
18LIB "bfun.lib";
19LIB "dmodapp.lib";
20LIB "poly.lib";
21
22/////////////////////////////////////////////////////////////////////////////
23
24static 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
38static 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
47proc 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
73static 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
86proc VdstrictGB (matrix M, int d ,list #);
87"USAGE:VdstrictGB(M,d[,v]); M a matrix, d an integer, v an optional intvec(shift vector)
88RETURN:matrix M; the rows of M foem a Vd-strict Groebner basis for imM
89ASSUME: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
131static 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
178static 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            {
195              vnm=vnm[n+2..n+d+1]-vnm[2..d+1];
196              kmin=sum(vnm)+v[l];
198              rem2[size(rem2)+1]=kmin;
199              findmin=insert(findmin,kmin);
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
232static 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
274proc 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
339static 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
353proc 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
355RETURN: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        {
374          positionpoly[i][size(positionpoly[i])+1]=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
417proc 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
419RETURN: 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
544proc 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
595proc 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
717proc 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
875proc 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
935proc 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[3*i-2]=out[3*i-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[3*size(L)]=matrix(0,out[3*size(L)-2],1);
1044  return (out);
1045}
1046
1047/////////////////////////////////////////////////////////////////////////////////////
1048
1049proc 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[3*i-2]=nrows(out[3*i]);
1083          v=0;
1084          for (j=1; j<=out[3*i-2]; j++)
1085            {
1086              mem=submat(out[3*i],j,intvec(1..ncols(out[3*i])));
1087              v[j]=Vddeg(mem,d, out[3*i+2]);
1088            }
1089          out[3*i-1]=v;
1090          if (i!=1)
1091            {
1092              out[3*i-3]=transpose(syz(transpose(out[3*i])));
1093              if (out[3*i-3]!=matrix(0,nrows(out[3*i-3]),ncols(out[3*i-3])))
1094                {
1095                  out[3*i-3]=VdstrictGB(out[3*i-3],d,out[3*i-1]);
1096                }
1097              else
1098                {
1099                  out[3*i-3]=matrix(0,1,ncols(out[3*i-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[3*n-3],out[3*n-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
1136proc 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[2*i-1]=dsum(fortoVdstrict[2*i-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[3*i-1][j]=list(minmaxk[1]-newcomplex[3*i-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[2*i]=newcomplex[3*i];
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[3*i-1][j][1],shorten[3*i-1][j][2]);
1319              truncatedcomplex[2*i-1][size(truncatedcomplex[2*i-1])+1]=fortrun[1];
1320              count=count+fortrun[2];
1321              sizetruncom[2*i-1][size(sizetruncom[2*i-1])+1]=list(int(shorten[3*i-1][j][1])-1,int(shorten[3*i-1][j][2])-1);
1322              sizetruncom[2*i][size(sizetruncom[2*i])+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[2*i]=submat(truncatedcomplex[2*i],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[2*i]=matrix(0,1,ncols(truncatedcomplex[2*i]));
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[2*i][size(sizetruncom[2*i])]),sizetruncom[2*i+2][size(sizetruncom[2*i+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[2*i-1][k][j][b][1]*truncatedcomplex[2*i][k,l];
1366                          while (form!=0)
1367                            {
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                                        {
1379                                            {
1381                                              break;
1382                                            }
1383                                        }
1384                                    }
1385                                }
1386                              form=form-lform;
1387                            }
1388                        }
1389                    }
1390                }
1391            }
1392        }
1393      truncatedcomplex[2*i]=M;
1394      truncatedcomplex[2*i-1]=sizetruncom[2*i][size(sizetruncom[2*i])];
1395    }
1396  truncatedcomplex[2*i-1]=sizetruncom[2*i][size(sizetruncom[2*i])];
1397  if (truncatedcomplex[2*i-1]!=0)
1398    {
1399      truncatedcomplex[2*i]=matrix(0,truncatedcomplex[2*i-1],1);
1400    }
1401  setring R;
1402  list truncatedcomplex=imap(W,truncatedcomplex);
1403  list derhamhom=findhomology(truncatedcomplex,le);
1404  return (derhamhom);
1405}
1406
1407///////////////////////////////////
1408static 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//////////////////////////////////////////////////////////////////////////
1427static 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
1455proc 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..2*n]=(1:2*n);
1490  mord[6*n+1..8*n]=(1:2*n);
1491  for (i=0; i<=2*n-2; i++)
1492    {
1493      mord[(3+i)*4*n-i]=-1;
1494      mord[(2*n+2+i)*4*n-2*n-i]=-1;
1495    }
1496  Data[3][1][2]=mord;//ordering mh?????????
1497  matrix Ones=UpOneMatrix(4*n);
1498  Data[5]=Ones;
1499  matrix con[2*n][2*n];
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            {
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[2*n+k]+e[3*n+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                    {
1545                      G1[l][i][j]=G1[l][i][j]-lterm;
1547                      lexp=lexp[2*n+1..3*n];
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
1632proc 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        {
1644          f=f-rest;
1645        }
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
1746proc 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
1809static proc mhom(poly f)
1810{
1811  poly g;
1812  poly l;
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    {
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[2*n+i]+e[3*n+i];
1833          if (size(minint)<i)
1834            {
1835              minint[i]=list();
1836            }
1837          minint[i][size(minint[i])+1]=-e[2*n+i]+e[3*n+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    {
1848      for (j=1; j<=n; j++)
1849        {
1851        }
1853    }
1854  return (g);
1855}
1856
1857
1858
1859
1860//////////////////////////////////////////////////////////////////////////
1861
1862static 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///////////////////////////////////////////////////////////////////////////////
1913static proc max(int i,int j)
1914{
1915  if(i>j){return(i);}
1916  return(j);
1917}
1918
1919////////////////////////////////////////////////////////////////////////////////////
1920version="$Id$";
1921category="Noncommutative";
1922info="
1923LIBRARY:  derham.lib      Computation of deRham cohomology
1924
1925AUTHORS:  Cornelia Rottner, rottner@mathematik.uni-kl.de
1926
1927OVERVIEW:
1928A library for computing the de Rham cohomology of complements of complex affine
1929varieties.
1930
1931
1932REFERENCES:
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
1946PROCEDURES:
1947
1948deRhamCohomology(list[,opt]); computes the de Rham cohomology
1949MVComplex(list);              computes the Mayer-Vietoris complex
1950";
1951
1952LIB "nctools.lib";
1953LIB "matrix.lib";
1954LIB "qhmoduli.lib";
1955LIB "general.lib";
1956LIB "dmod.lib";
1957LIB "bfun.lib";
1958LIB "dmodapp.lib";
1959LIB "poly.lib";
1960LIB "schreyer.lib";
1961LIB "dmodloc.lib";
1962
1963
1964////////////////////////////////////////////////////////////////////////////////////
1965
1966proc 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'.
1988ASSUME: -The basering must be a polynomial ring over the field of rational numbers@*
1989RETURN: 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
1991EXAMPLE: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    {
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[3*i-1], d^i=newcomplex[3*i]), 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[3*i-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[3*i-1][j]=list(minmaxk[1]-newcomplex[3*i-1][j]+1);
2158          if (diffforms==1)
2159            {
2160              shorten[3*i-1][j][1]=1;
2161            }
2162          shorten[3*i-1][j][2]=minmaxk[2]-newcomplex[3*i-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[2*i-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[2*i] 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[2*i]=newcomplex[3*i];
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[3*i-1][j][1],shorten[3*i-1][j][2]);
2233              truncatedcomplex[2*i-1][size(truncatedcomplex[2*i-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[3*i-1][j][1])-1,int(shorten[3*i-1][j][2])-1);
2243              sizetruncom[2*i-1][size(sizetruncom[2*i-1])+1]=fst;
2244              sizetruncom[2*i][size(sizetruncom[2*i])+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[2*i],v,1..ncols(truncatedcomplex[2*i]));
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[2*i]=matrix(0,1,ncols(truncatedcomplex[2*i]));
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[2*i][size(sizetruncom[2*i])]);
2309      nc=max(1,sizetruncom[2*i+2][size(sizetruncom[2*i+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=form*truncatedcomplex[2*i][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                            {
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];
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];
2356                                              break;
2357                                            }
2358                                        }
2359                                    }
2360                                  //        }
2361
2362                              form=form-lform;
2363                            }
2364                        }
2365                    }
2366                }
2367            }
2368        }
2369      truncatedcomplex[2*i]=M;
2370      truncatedcomplex[2*i-1]=sizetruncom[2*i][size(sizetruncom[2*i])];
2371    }
2372  truncatedcomplex[2*i-1]=sizetruncom[2*i][size(sizetruncom[2*i])];
2373  if (truncatedcomplex[2*i-1]!=0)
2374    {
2375      truncatedcomplex[2*i]=matrix(0,truncatedcomplex[2*i-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[2*i-1] and d^i=truncatedcomplex[2*i]*/
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[2*i-1]=newcomplex[3*i-2];
2423     newcomplexmod[2*i]=newcomplex[3*i];
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
2515example
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
2526proc MVComplex(list L,list #)
2527"USAGE:MVComplex(L); L a list of  polynomials
2528ASSUME: -Basering is a polynomial ring with n vwariables and rational coefficients
2529        -L is a list of non-constant polynomials
2530RETURN: 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[2*i-1])/im(C[2*i-1]) and the differentials
2534        d^i are given by C[2*i]
2535EXAMPLE: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        }
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[2*i-1]=dsum(Cech[2*i-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
2822example
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
2833static proc SannfsIBM(poly F,ideal myJ)
2834"USAGE: SannfsIBM(f,J), F poly, J ideal
2835ASSUME: 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
2840RETURN  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 t*s=s*t-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
2939static 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
2942ASSUME: 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_1*f_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])
2952RETURN: 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)
2962THEORY: 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[2*i],L[2*i+1],1);
3016          kernew=divdr(L[2*i],L[2*i+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[2*i]),transpose(L[2*i+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[2*i]),transpose(L[2*i+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[2*i]=newcomplex[3*(n+i-1)];
3181      forsep[2*i-1]=matrix(0,1,nrows(forsep[2*i]));
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
3211static 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
3238static 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
3329static 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
3333ASSUME: 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_1*f_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)@*
3347RETURN: 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)
3357THEORY: 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[3*i-2]=nrows(out[3*i]);
3396              v=0;
3397              for (j=1; j<=out[3*i-2]; j++)
3398                {
3399                  mem=submat(out[3*i],j,intvec(1..ncols(out[3*i])));
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[3*i-3]=transpose(syz(transpose(out[3*i])));
3407                  if (out[3*i-3]!=matrix(0,nrows(out[3*i-3]),ncols(out[3*i-3])))
3408                    {
3409                      /*makes the resolution V_d-strict*/
3410                      out[3*i-3]=VdStrictGB(out[3*i-3],d,out[3*i-1]);
3411                    }
3412                  else
3413                    {
3414                      /*resolution is already computed*/
3415                      out[3*i-3]=matrix(0,1,ncols(out[3*i-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[3*n-3]=subst(out[3*n-3],h,1);
3455          for (i=n-1; i>=1; i--)
3456            {
3457              out[3*i-2]=nrows(out[3*i]);
3458              v=0;
3459              for (j=1; j<=out[3*i-2]; j++)
3460                {
3461                  mem=submat(out[3*i],j,intvec(1..ncols(out[3*i])));
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[3*i-3])-logens+1!=nrows(out[3*i]))
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[3*i-3]=subst(out[3*i-3],h,1);
3493                          logens=logens+ncols(out[3*i-3]);
3494                        }
3495                    }
3496                  if(indi==0)
3497                    {
3498                      out[3*i-3]=matrix(0,1,nrows(out[3*i]));
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[3*n-3],out[3*n-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
3553static 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
3573static 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
3614static 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
3652static 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
3666static 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
3796static 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
4049static 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
4348static 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
5145static 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
5301static 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
5374static 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[3*i-2]; m_i=out[3*i-1] and d^i=out[3*i]*/
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[3*i-2]=out[3*i-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[3*size(L)]=matrix(0,out[3*size(L)-2],1);
5486  return (out);
5487
5488}
5489
5490////////////////////////////////////////////////////////////////////////////////////
5491//COMPUTATION OF THE BLOBAL B-FUNCTION
5492////////////////////////////////////////////////////////////////////////////////////
5493
5494static 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
5613static 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
5730static 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
5846static 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        {
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
5923static 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
5938static 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..2*n]=(1:2*n);
6010  mord[6*n+1..8*n]=(1:2*n);
6011  for (i=0; i<=2*n-2; i++)
6012    {
6013      mord[(3+i)*4*n-i]=-1;
6014      mord[(2*n+2+i)*4*n-2*n-i]=-1;
6015    }
6016  Data[3][1][2]=mord;
6017  matrix Ones=UpOneMatrix(4*n);
6018  Data[5]=Ones;
6019  matrix con[2*n][2*n];
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            {
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[2*n+k]+e[3*n+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                    {
6068                      G1[l][i][j]=G1[l][i][j]-lterm;
6070                      lexp=lexp[2*n+1..3*n];
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
6168static proc findCohomology(list L,int le)
6169{
6170/*computes the cohomology of the complex (D^i,d^i) given by D^i=C^L[2*i-1] and
6171  d^i=L[2*i]*/
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
6215static proc findCohomologyDiffForms(list L,int le)
6216{
6217  /*computes the cohomology of the complex (D^i,d^i) given by D^i=C^L[2*i-1] and
6218    d^i=L[2*i]*/
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
6315static 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
6363static 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
6400static 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
6411static proc VdStrictGB (matrix M,int d,list #)
6412"USAGE:VdStrictGB(M,d[,v]); M a matrix, d an integer, v an optional intvec
6413ASSUME:-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
6417RETURN: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
6462static 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
6465ASSUME:-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 @*
6470RETURN: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
6584static 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            {
6605              vnm=vnm[n+2..n+d+1]-vnm[2..d+1];
6606              kmin=sum(vnm)+v[l];
6608              rem2[size(rem2)+1]=kmin;
6609              findmin=insert(findmin,kmin);
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
6649static 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
6693static 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
6707static 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        {
6730          positionpoly[i][size(positionpoly[i])+1]=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
6773static 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        {
6796          positionpoly[i][size(positionpoly[i])+1]=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
6839static 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        {
6859          positionpoly[i][size(positionpoly[i])+1]=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
6885static 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
6909static proc mHom(poly f)
6910{/*for globalBFunOT*/
6911  poly g;
6912  poly l;
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    {
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[2*n+i]+e[3*n+i];
6933          if (size(minint)<i)
6934            {
6935              minint[i]=list();
6936            }
6937          minint[i][size(minint[i])+1]=-e[2*n+i]+e[3*n+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    {
6948      for (j=1; j<=n; j++)
6949        {
6951        }
6953    }
6954  return (g);
6955}
6956
6957////////////////////////////////////////////////////////////////////////////////////
6958
6959static 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
7012static 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
7046static 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
7080static 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
7114static 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
7217static 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
7321static 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            {
7357              kmin=sum(vnm)+v[l];
7359              rem2[size(rem2)+1]=kmin;
7360              findmax=insert(findmax,kmin);
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
7413static proc max(int i,int j)
7414{
7415  if(i>j){return(i);}
7416  return(j);
7417}
7418
7419////////////////////////////////////////////////////////////////////////////////////
7420
7421static 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
7451static proc minIntRoot(list L,list #)
7452"USAGE:minIntRoot(L [,M]); L list, M optinonal list
7453ASSUME: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)
7456RETURN:-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            {
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
7530proc 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
7548proc 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
7565proc 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
7625static 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[2*j]+list(L[2*i-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[2*j-1],unitmat(L[2*i-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[2*j])),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
7709static 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////////////////////////////////////////////////////////////////////////////////////
7809FURTHER EXAMPLES FOR TESTING THE PROCEDURES
7810////////////////////////////////////////////////////////////////////////////////////
7811LIB "derham.lib";
7812
7813//----------------------------------------
7814//EXAMPLE 1
7815//----------------------------------------
7816ring r=0,(x,y),dp;
7817poly f=y2-x3-2x+3;
7818list L=deRhamCohomology(f);
7819L;
7820kill r;
7821
7822//----------------------------------------
7823//EXAMPLE 2
7824//----------------------------------------
7825ring r=0,(x,y),dp;
7826poly f=y2-x3-x;
7827list L=deRhamCohomology(f);
7828L;
7829kill r;
7830
7831//----------------------------------------
7832//EXAMPLE 3
7833//----------------------------------------
7834ring r=0,(x,y),dp;
7835list C=list(x2-1,(x+1)*y,y*(y2+2x+1));
7836list L=deRhamCohomology(C);
7837L;
7838kill r;
7839
7840//----------------------------------------
7841//EXAMPLE 4
7842//----------------------------------------
7843ring r=0,(x,y,z),dp;
7844list C=list(x*(x-1),y,z*(z-1),z*(x-1));
7845list L=deRhamCohomology(C);
7846L;
7847kill r;
7848
7849//----------------------------------------
7850//EXAMPLE 5
7851//----------------------------------------
7852ring r=0,(x,y,z),dp;
7853list C=list(x*y,y*z);
7854list L=deRhamCohomology(C,"Vdres");
7855L;
7856kill r;
7857
7858//----------------------------------------
7859//EXAMPLE 6
7860//----------------------------------------
7861ring r=0,(x,y,z,u),dp;
7862list C=list(x,y,z,u);
7863list L=deRhamCohomology(C);
7864L;
7865kill r;
7866
7867//----------------------------------------
7868//EXAMPLE 7
7869//----------------------------------------
7870ring r=0,(x,y,z),dp;
7871poly f=x3+y3+z3;
7872list L=deRhamCohomology(f);
7873L;
7874kill r;
7875
7876//----------------------------------------
7877//EXAMPLE 8
7878//----------------------------------------
7879ring r=0,(x,y,z),dp;
7880poly f=x2+y2+z2;
7881list L=deRhamCohomology(f,"Vdres");
7882L;
7883kill r;
7884
7885//----------------------------------------
7886//EXAMPLE 9
7887//----------------------------------------
7888ring r=0,(x,y,z,u),dp;
7889list C=list(x2+y2+z2,u);
7890list L=deRhamCohomology(C);
7891L;
7892kill r;
7893
7894
7895//----------------------------------------
7896//EXAMPLE 10
7897//----------------------------------------
7898ring r=0,(x,y,z),dp;
7899list C=list((x*(y-1),y2-1));
7900list L=deRhamCohomology(C);
7901L;
7902kill r;
7903
7904
7905*/
Note: See TracBrowser for help on using the repository browser.