source: git/Singular/LIB/deform.lib @ 75089b

spielwiese
Last change on this file since 75089b was 75089b, checked in by Kai Krüger <krueger@…>, 26 years ago
made fixes requested by libparse (s.a. brackets, ....) git-svn-id: file:///usr/local/Singular/svn/trunk@1198 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 33.0 KB
Line 
1// $Id: deform.lib,v 1.6 1998-03-06 11:52:52 krueger Exp $
2//(bm, last modified 12/97)   
3///////////////////////////////////////////////////////////////////////////////
4LIBRARY:  deform.lib       PROCEDURES FOR COMPUTING MINIVERSAL DEFORMATION
5                            (new version)
6 versal(Fo[,d,any])       miniversal deformation of isolated singularity Fo
7 mod_versal(Mo,I,[,d,any])
8                          miniversal deformation of module Mo modulo ideal I
9 lift_rel_kb(N,M[,kbM,p]) lifting N into a kbase of M
10 kill_rings(["prefix"])   kills the exported rings from above
11 lift_kbase(N,M);         coef-matrix expressing N as lin. comb. of k-basis of M
12 
13  SUB-PROCEDURES            used by main procedure:
14                  get_rings,compute_ext,get_inf_def,interact1,
15                  interact2,negative_part,homog_test
16LIB "inout.lib";
17LIB "general.lib";
18LIB "matrix.lib";
19LIB "homolog.lib";
20LIB "inout.lib";
21LIB "general.lib";
22LIB "sing.lib";
23LIB "matrix.lib";
24LIB "homolog.lib";
25///////////////////////////////////////////////////////////////////////////////
26proc versal (ideal Fo,list #)
27USAGE:   versal(Fo[,d,any]); Fo=ideal, d=int, any=list
28COMUPTE: miniversal deformation of Fo up to degree d (default d=100),
29CREATE:  Rings (exported):
30         'my'Px = extending the basering Po by new variables given by "A,B,.."
31                  (deformation parameters), returns as basering,
32                  the new variables come before the old ones,
33                  the ordering is the product between "ls" and "ord(Po)",
34         'my'Qx = Px/Fo extending Qo=Po/Fo,
35         'my'So = being the embedding-ring of the versal base space,
36         'my'Ox = Px/Js extending So/Js.   (default my="")
37      Matrices (in Px, exported):
38         Js  = giving the versal base space (obstructions),
39         Fs  = giving the versal family of Fo,
40         Rs  = giving the lifting of Ro=syz(Fo).
41      If d is defined (!=0), it computes up to degree d.
42      If 'any' is defined and any[1] is no string, interactive version.
43      Otherwise 'any' gives predefined strings: "my","param","order","out"
44      ("my" prefix-string, "param" is a letter (e.g. "A")  for the name of
45      first parameter or (e.g. "A(") for index parameter variables, "order"
46      ordering string for ring extension), "out" name of output-file).
47NOTE:   printlevel < 0        no output at all,
48        printlevel >=0,1,2,.. informs you, what is going on;           
49        this proc uses 'execute'.
50EXAMPLE:example versal; shows an example
51{
52//------- prepare -------------------------------------------------------------
53  string str,@param,@order,@my,@out,@degrees;
54  int @d,d_max,@t1,t1',@t2,@colR,ok_ann,@smooth,@noObstr,@size,@j;
55  int p    = printlevel-voice+3;
56  int time = timer;
57  intvec @iv,@jv,@is_qh,@degr;
58  d_max    = 100; 
59  @my = ""; @param="A"; @order="ds"; @out="no";
60  @size    = size(#);
61  if( @size>0 ) { d_max = #[1]; }
62  if( @size>1 )
63  { if(typeof(#[2])!="string")
64    { string @active;
65      @my,@param,@order,@out = interact1();
66    }
67    else
68    { @my = #[2];
69      if (@size>2) {@param = #[3];}
70      if (@size>3) {@order = #[4];}
71      if (@size>4) {@out   = #[5];}
72    }
73  }
74  string myPx = @my+"Px";
75  string myQx = @my+"Qx";
76  string myOx = @my+"Ox";
77  string mySo = @my+"So";
78         Fo   = simplify(Fo,10);
79  @is_qh      = qhweight(Fo);
80  int    @rowR= size(Fo);
81  def    Po   = basering;
82setring  Po;
83  poly   X_s  = product(maxideal(1));
84//-------  reproduce T12 ------------------------------------------------------
85  list   Ls   = T12(Fo,1);
86  matrix Ro   = Ls[6];                         // syz(i)
87  matrix InfD = Ls[5];                         // matrix of inf. deformations
88  matrix PreO = Ls[7];                         // representation of (Syz/Kos)*
89  module PreO'= std(PreO);
90  module PreT = Ls[2];                         // representation of modT2 (sb)
91  if(dim(PreT)==0)
92  {
93    matrix kbT2 = kbase(PreT);                 // kbase of T2
94  }
95  else
96  {
97    matrix kbT2 ;                              // kbase of T2 : empty
98  }
99  @t1 = Ls[3];                                 // vdim of T1
100  @t2 = Ls[4];                                 // vdim of T2
101  kill Ls;
102  t1' = @t1; 
103  if( @t1==0) { dbprint(p,"// rigit!"); return();} 
104  if( @t2==0) { @smooth=1; dbprint(p,"// smooth base space");}   
105  dbprint(p,"// ready: T1 and T2");
106  @colR = ncols(Ro);
107//-----  test: quasi-homogeneous, choice of inf. def.--------------------------
108  @degrees = homog_test(@is_qh,matrix(Fo),InfD);
109  @jv = 1..@t1;
110  if (@degrees!="")
111  { dbprint(p-1,"// T1 is quasi-homogeneous represented with weight-vector",
112    @degrees);
113  }
114  if (defined(@active))
115  { "// matrix of infinitesimal deformations:";print(InfD);
116    "// weights of infinitesimal deformations (  emty ='not qhomog'):";
117     @degrees;
118     matrix dummy;
119     InfD,dummy,t1' = interact2(InfD,@jv);kill dummy;
120  }
121 //---- create new rings and objects ------------------------------------------
122  get_rings(Fo,t1',1,@my,@order,@param);
123 setring `myPx`;
124  @jv=0; @jv[t1']=0; @jv=@jv+1; @jv[nvars(basering)]=0;       
125                                               //weight-vector for calculating
126                                               //rel-jet with resp to def-para
127  ideal  Io   = imap(Po,Fo);               
128  ideal  J,m_J,tid;     attrib(J,"isSB",1);
129  matrix Fo   = matrix(Io);                   //initial equations
130  matrix homF = kohom(Fo,@colR);
131  matrix Ro   = imap(Po,Ro);
132  matrix homR = transpose(Ro);
133  matrix homFR= concat(homR,homF);
134  print(homFR);
135  test(6);
136  module hom' = std(homFR);
137  matrix Js[1][@t2];
138  matrix F_R,Fs,Rs,Fn,Rn;
139  export Js,Fs,Rs;                         
140  matrix Mon[t1'][1]=maxideal(1);             
141  Fn  = transpose(imap(Po,InfD)*Mon);         //infinitesimal deformations
142  Fs  = Fo + Fn;
143  dbprint(p-1,"// infinitesimal deformation: Fs: ",Fs);
144  Rn  = (-1)*lift(Fo,Fs*Ro);                  //infinit. relations
145  Rs  = Ro + Rn;
146  F_R = Fs*Rs;
147  tid = 0 + ideal(F_R);
148  if (tid[1]==0) {d_max=1;}                   //finished ?
149 setring `myOx`; 
150  matrix Fs,Rs,Cup,Cup',F_R,homFR,New,Rn,Fn;
151  module hom';
152  ideal  null,tid;  attrib(null,"isSB",1);
153 setring `myQx`;   
154  poly X_s = imap(Po,X_s);       
155  matrix Cup,Cup',MASS;             
156  ideal  tid,null;               attrib(null,"isSB",1);
157  ideal  J,m_J;                  attrib(J,"isSB",1);
158                                 attrib(m_J,"isSB",1);
159  matrix PreO = imap(Po,PreO);
160  module PreO'= imap(Po,PreO');  attrib(PreO',"isSB",1);
161  module PreT = imap(Po,PreT);   attrib(PreT,"isSB",1);
162  matrix kbT2 = imap(Po,kbT2);
163  matrix Mon  = fetch(`myPx`,Mon);
164  matrix F_R  = fetch(`myPx`,F_R);
165  matrix Js[1][@t2];
166//------- start the loop ------------------------------------------------------
167   for (@d=2;@d<=d_max;@d=@d+1)
168   {
169     if( @t1==0) {break};
170     dbprint(p,"// start computation in degree "+string(@d)+".");     
171     dbprint(p-1,">>> TIME = "+string(timer-time));
172     dbprint(p-1,"==> memory = "+string(kmemory())+"k");
173//------- compute obstruction-vector  -----------------------------------------
174     if (@smooth) { @noObstr=1;}
175     else
176     { Cup = jet(F_R,@d,@jv);
177       Cup = matrix(reduce(ideal(Cup),m_J),@colR,1);   
178       Cup = jet(Cup,@d,@jv);         
179     }   
180//------- express obstructions in kbase of T2  --------------------------------
181     if ( @noObstr==0 )
182     {  Cup' = reduce(Cup,PreO');
183        tid  = simplify(ideal(Cup'),10);
184        if(tid[1]!=0)
185        {  dbprint(p-4,"// *");
186           Cup=Cup-Cup';
187        }
188        Cup   = lift(PreO,Cup);
189        MASS  = lift_rel_kb(Cup,PreT,kbT2,X_s);
190        dbprint(p-3,"// next MASSEY-products:",MASS-jet(MASS,@d-1,@jv));
191        if    (MASS==transpose(Js))
192              { @noObstr=1;dbprint(p-1,"// no obstruction"); }
193         else { @noObstr=0; }
194      }
195//------- obtain equations of base space --------------------------------------
196      if ( @noObstr==0 )
197      { Js = transpose(MASS);
198        dbprint(p-2,"// next equation of base space:",
199        simplify(ideal(Js),10));
200 setring `myPx`;
201        Js   = imap(`myQx`,Js);
202      degBound = @d+1;
203        J    = std(ideal(Js));
204        m_J  = std(J*ideal(Mon));
205      degBound = 0;
206//--------------- obtain new base-ring ----------------------------------------
207        kill `myOx`;
208  qring `myOx` = J; 
209        matrix Fs,Rs,F_R,Cup,Cup',homFR,New,Rn,Fn;
210        module hom';
211        ideal  null,tid;  attrib(null,"isSB",1);
212      }
213//---------------- lift equations F and relations R ---------------------------
214 setring `myOx`;
215      Fs    = fetch(`myPx`,Fs);                 
216      Rs    = fetch(`myPx`,Rs);   
217      F_R   = Fs*Rs;   
218      F_R   = matrix(reduce(ideal(F_R),null)); 
219      tid   = 0 + ideal(F_R);
220      if (tid[1]==0) { dbprint(p-1,"// finished"); break;}   
221      Cup   = (-1)*transpose(jet(F_R,@d,@jv)); 
222      homFR = fetch(`myPx`,homFR); 
223      hom'  = fetch(`myPx`,hom');  attrib(hom',"isSB",1);
224      Cup'  = simplify(reduce(Cup,hom'),10);
225      tid   = simplify(ideal(Cup'),10);
226      if (tid[1]!=0)
227      {  dbprint(p-4,"// #");
228         Cup=Cup-Cup';
229      }
230      New   = lift(homFR,Cup);
231      Rn    = matrix(ideal(New[1+@rowR..nrows(New),1]),@rowR,@colR);
232      Fn    = matrix(ideal(New[1..@rowR,1]),1,@rowR);
233      Fs    = Fs+Fn;
234      Rs    = Rs+Rn;
235      F_R   = Fs*Rs;
236      tid   = 0+reduce(ideal(F_R),null);
237//---------------- fetch results into other rings -----------------------------
238  setring `myPx`;
239      Fs    = fetch(`myOx`,Fs);
240      Rs    = fetch(`myOx`,Rs);
241      F_R   = Fs*Rs;
242  setring `myQx`;
243      F_R = fetch(`myPx`,F_R);
244      m_J = fetch(`myPx`,m_J);  attrib(m_J,"isSB",1);
245      J   = fetch(`myPx`,J);    attrib(J,"isSB",1);
246      Js  = fetch(`myPx`,Js);
247      tid = fetch(`myOx`,tid);
248      if (tid[1]==0) { dbprint(p-1,"// finished");break;}         
249   }
250//---------  end loop and final output ----------------------------------------
251  setring `myPx`;
252   if (@out!="no")
253   {  string out = @out+"_"+string(@d);
254      "// writing file "+out+" with matrix Js, matrix Fs, matrix Rs ready
255      for reading in rings "+myPx+" or "+myQx;
256      write(out,"matrix Js[1][",@t2,"]=",Js,";matrix Fs[1][",@rowR,"]=",Fs,
257      ";matrix Rs[",@rowR,"][",@colR,"]=",Rs,";");
258   }
259   dbprint(p,">>> TIME = "+string(timer-time));
260   if (@is_qh != 0)
261   { @degr = qhweight(ideal(Js));
262     @degr = @degr[1..t1'];
263     dbprint(p-1,"// quasi-homogeneous weights of miniversal base",@degr);
264   }
265   dbprint(p-1,
266   "// ___ Equations of miniversal base space ___",Js,
267   "// ___ Equations of miniversal total space ___",Fs);
268   dbprint(p,"","// Result belongs to ring "+myPx+".",
269   "// Equations of total space of miniversal deformation are ",
270   "// given by Fs, equations of miniversal base space by Js.",
271   "// Make "+myPx+" the basering and list objects defined in "
272   +myPx+" by typing:",
273   "   setring "+myPx+"; show("+myPx+");","   listvar(matrix);",
274   "// NOTE: rings "+myQx+", "+myPx+", "+mySo+" are alive!",
275   "// (use 'kill_rings(\""+@my+"\");' to remove)");
276   return();
277}
278example
279{ "EXAMPLE:"; echo = 2;
280   int p          = printlevel;
281   printlevel     = 0;
282   ring r1        = 0,(x,y,z,u,v),ds;
283   matrix m[2][4] = x,y,z,u,y,z,u,v;
284   ideal Fo       = minor(m,2);   
285                    // cone over rational normal curve of degree 4
286   versal(Fo);
287   setring Px;
288   // ___ Equations of miniversal base space ___:
289   Js;"";
290   // ___ Equations of miniversal total space ___:
291   Fs;"";
292   kill Px,Qx,So;
293   ring  r2       = 0,(x,y,z),ds;
294   ideal Fo       = x2,xy,yz,zx;
295   printlevel     = 3;
296   versal(Fo);
297   printlevel     = p;
298   kill Px,Qx,So;
299}
300///////////////////////////////////////////////////////////////////////////////
301proc mod_versal(matrix Mo, ideal I, list #)
302
303USAGE:   mod_versal(Mo,I[,d,any]); I=ideal, M=module, d=int, any =list
304COMUPTE: miniversal deformation of coker(Mo) over Qo=Po/Io, Po=basering;
305CREATE:  Ringsr (exported):
306         'my'Px  = extending the basering by new variables
307                   (deformation parameters),
308                   the new variables come before the old ones,
309                   the ordering is the product between "my_ord" and "ord(Po)",
310         'my'Qx  = Px/Io extending Qo (returns as basering),
311         'my'Ox  = Px/(Io+Js) ring of the versal deformation of coker(Ms),
312         'my'So  = embedding-ring of the versal base space.  (default 'my'="")
313      Matrices (in Qx, exported):
314         Js  = giving the versal base space (obstructions),
315         Ms  = giving the versal family of Mo,
316         Ls  = giving the lifting of syzygies Lo=syz(Mo),
317      If d is defined (!=0), it computes up to degree d.
318      If 'any' is defined and any[1] is no string, interactive version.
319      Otherwise 'any' gives predefined strings:"my","param","order","out"
320      ("my" prefix-string, "param" is a letter (e.g. "A")  for the name of
321      first parameter or (e.g. "A(") for index parameter variables, "ord"
322      ordering string for ringextension), "out" name of output-file).
323NOTE:   printlevel < 0        no output at all,
324        printlevel >=0,1,2,.. informs you, what is going on,             
325        this proc uses 'execute'.
326EXAMPLE:example mod_versal; shows an example
327{
328//------- prepare -------------------------------------------------------------
329  string str,@param,@order,@my,@out,@degrees;
330  int @d,d_max,f0,f1,f2,e1,e1',e2,ok_ann,@smooth,@noObstr,@size,@j;
331  int p    = printlevel-voice+3;
332  int time = timer;
333  intvec @iv,@jv,@is_qh,@degr;
334  d_max    = 100; 
335  @my = ""; @param="A"; @order="ds"; @out="no";
336  @size = size(#);
337  if( @size>0 ) { d_max = #[1]; }
338  if( @size>1 )
339  { if(typeof(#[2])!="string")
340    { string @active;
341      @my,@param,@order,@out = interact1();
342    }
343    else
344    { @my = #[2];
345      if (@size>2) {@param = #[3];}
346      if (@size>3) {@order = #[4];}
347      if (@size>4) {@out   = #[5];}
348    }
349  } 
350  string myPx = @my+"Px";
351  string myQx = @my+"Qx";
352  string myOx = @my+"Ox";
353  string mySo = @my+"So";
354  @is_qh      = qhweight(I);
355  def    Po   = basering;
356 setring Po;
357  poly   X_s = product(maxideal(1));
358//-------- compute Ext's ------------------------------------------------------
359         I   = std(I);
360 qring   Qo  = I;   
361  matrix Mo  = fetch(Po,Mo);
362  list   Lo  = compute_ext(Mo,p);
363         f0,f1,f2,e1,e2,ok_ann=Lo[1];
364  matrix Ls,kb1,lift1 = Lo[2],Lo[3],Lo[4];
365  matrix kb2,C',D' = Lo[5][2],Lo[5][3],Lo[5][5];
366  module ex2,Co,Do = Lo[5][1],Lo[5][4],Lo[5][6];
367  kill Lo;
368  dbprint(p,"// ready: Ext1 and Ext2");
369//-----  test: quasi-homogeneous, choice of inf. def.--------------------------
370  @degrees = homog_test(@is_qh,Mo,kb1); 
371  e1' = e1;  @jv = 1..e1;
372  if (@degrees != "")
373  { dbprint(p-1,"// Ext1 is quasi-homogeneous represented: "+@degrees);
374  }
375  if (defined(@active))
376  { "// kbase of Ext1:";
377    print(kb1);
378    "// weights of kbase of Ext1 ( empty = 'not qhomog')";@degrees;
379    kb1,lift1,e1' = interact2(kb1,@jv,lift1);
380  }
381//-------- get new rings and objects ------------------------------------------
382 setring Po;
383  get_rings(I,e1',0,@my,@order,@param);
384 setring `myPx`;
385  ideal  J,m_J;
386  ideal  I_J  = imap(Po,I);
387  ideal  Io   = I_J;
388  matrix Mon[e1'][1] = maxideal(1);
389  matrix Ms   = imap(Qo,Mo);             
390  matrix Ls   = imap(Qo,Ls);       
391  matrix Js[1][e2];           
392 setring `myQx`;
393  ideal  J,I_J,tet,null;              attrib(null,"isSB",1);
394  ideal  m_J  = fetch(`myPx`,m_J);   attrib(m_J,"isSB",1);
395  @jv=0;  @jv[e1] = 0; @jv = @jv+1;   @jv[nvars(`myPx`)] = 0;
396  matrix Ms   = imap(Qo,Mo);          export(Ms);       
397  matrix Ls   = imap(Qo,Ls);          export(Ls);
398  matrix Js[e2][1];                   export(Js);
399  matrix MASS;
400  matrix Mon  = fetch(`myPx`,Mon);
401  matrix Mn,Ln,ML,Cup,Cup',Lift;
402  matrix C'   = imap(Qo,C');
403  module Co   = imap(Qo,Co);          attrib(Co,"isSB",1);
404  module ex2  = imap(Qo,ex2);         attrib(ex2,"isSB",1);
405  matrix D'   = imap(Qo,D');
406  module Do   = imap(Qo,Do);          attrib(Do,"isSB",1);
407  matrix kb2  = imap(Qo,kb2);   
408  matrix kb1  = imap(Qo,kb1);
409  matrix lift1= imap(Qo,lift1);
410  poly   X_s  = imap(Po,X_s);
411  intvec intv = e1',e1,f0,f1,f2;
412         Ms,Ls= get_inf_def(Ms,Ls,kb1,lift1,X_s);     
413  kill   kb1,lift1;
414  dbprint(p-1,"// infinitesimal extension",Ms);
415//----------- start the loop --------------------------------------------------
416  for (@d=2;@d<=d_max;@d=@d+1)
417  {
418    dbprint(p-1,">>> time = "+string(timer-time));
419    dbprint(p-1,"==> memory = "+string(memory(0)/1000)+
420                ",  allocated = "+string(memory(1)/1000));
421    dbprint(p,"// start deg = "+string(@d));   
422//-------- get obstruction ----------------------------------------------------
423    Cup  = matrix(ideal(Ms*Ls),f0*f2,1);
424    Cup  = jet(Cup,@d,@jv);
425    Cup  = reduce(ideal(Cup),m_J);
426    Cup  = jet(Cup,@d,@jv);
427//-------- express obstruction in kbase ---------------------------------------
428    Cup' = reduce(Cup,Do);
429    tet  = simplify(ideal(Cup'),10);
430    if (tet[1]!=0)
431    { dbprint(p-4,"// *");
432      Cup = Cup-Cup';
433    }
434    Cup  = lift(D',Cup);
435    if (ok_ann)
436    { MASS = lift_rel_kb(Cup,ex2,kb2,X_s);}
437    else
438    { MASS = reduce(Cup,ex2);}     
439    dbprint(p-3,"// next MATRIC-MASSEY-products",
440    MASS-jet(MASS,@d-1,@jv));
441    if   ( MASS==transpose(Js))
442         { @noObstr = 1;dbprint(p-1,"//no obstruction"); }
443    else { @noObstr = 0; }       
444//-------- obtain equations of base space -------------------------------------
445    if (@noObstr == 0)
446    { Js = MASS;
447      dbprint(p-2,"// next equation of base space:",simplify(ideal(Js),10));
448 setring `myPx`;
449      Js = imap(`myQx`,Js);
450     degBound=@d+1;
451      J   = std(ideal(Js));
452      m_J = std(ideal(Mon)*J);
453     degBound=0;
454      I_J = Io,J;                attrib(I_J,"isSB",1);
455//-------- obtain new base ring -----------------------------------------------
456      kill `myOx`;
457 qring `myOx` = I_J;     
458      ideal null,tet;            attrib(null,"isSB",1);
459      matrix Ms  = imap(`myQx`,Ms);
460      matrix Ls  = imap(`myQx`,Ls);
461      matrix Mn,Ln,ML,Cup,Cup',Lift;
462      matrix C'  = imap(Qo,C'); 
463      module Co  = imap(Qo,Co);   attrib(Co,"isSB",1);
464      module ex2 = imap(Qo,ex2);  attrib(ex2,"isSB",1);
465      matrix kb2 = imap(Qo,kb2);
466      poly   X_s = imap(Po,X_s);
467    } 
468//-------- get lifts ----------------------------------------------------------
469   setring `myOx`;
470    ML  = matrix(reduce(ideal(Ms*Ls),null),f0,f2);
471    Cup = matrix(ideal(ML),f0*f2,1);
472    Cup = jet(Cup,@d,@jv);
473    Cup'= reduce(Cup,Co);
474    tet = simplify(ideal(Cup'),10);   
475    if (tet[1]!=0)
476    { dbprint(p-4,"// #");
477     Cup = Cup-Cup';
478    }
479    Lift = lift(C',Cup);                 
480    Mn   = matrix(ideal(Lift),f0,f1);
481    Ln   = matrix(ideal(Lift[f0*f1+1..nrows(Lift),1]),f1,f2);
482    Ms   = Ms-Mn;
483    Ls   = Ls-Ln;
484    dbprint(p-3,"// next extension of Mo",Mn);
485    dbprint(p-3,"// next extension of syz(Mo)",Ln);
486    ML   = reduce(ideal(Ms*Ls),null);
487//--------- test: finished ----------------------------------------------------
488    tet  = simplify(ideal(ML),10);
489    if (tet[1]==0) { dbprint(p-1,"// finished in degree ",@d);}
490//---------fetch results into Qx and Px ---------------------------------------
491   setring `myPx`;
492    Ms   = fetch(`myOx`,Ms);
493    Ls   = fetch(`myOx`,Ls);
494   setring `myQx`;
495    Ms   = fetch(`myOx`,Ms);
496    Ls   = fetch(`myOx`,Ls);
497    ML   = Ms*Ls;
498    ML   = matrix(reduce(ideal(ML),null),f0,f2);
499    tet  = imap(`myOx`,tet);
500    if (tet[1]==0) { break;}
501  } 
502//------- end of loop, final output -------------------------------------------
503  if (@out != "no")
504  { string out = @out+"_"+string(@d);
505    "// writing file '"+out+"' with matrix Js, matrix Ms, matrix Ls
506    ready for reading in rings "+myPx+" or "+myQx;
507    write(out,"matrix Js[1][",e2,"]=",Js,";matrix Ms[",f0,"][",f1,"]=",Ms,
508    ";matrix Ls[",f1,"][",f2,"]=",Ls,";");
509  }
510  dbprint(p,">>> TIME = "+string(timer-time));
511  if (@is_qh != 0)
512  { @degr = qhweight(ideal(Js));
513    @degr = @degr[1..e1'];
514    dbprint(p-1,"// quasi-homogeneous weights of miniversal base",@degr);
515  }
516  dbprint(p-1,"// Result belongs to qring "+myQx,
517  "// Equations of total space of miniversal deformation are in Js",
518  simplify(ideal(Js),10),
519  "// Matrix of the deformed module is Ms and lifted syzygies are Ls.",
520  "// Make "+myQx+" the basering and list objects defined in "+myQx+
521  " by typing:",
522  "   listvar(ring);setring "+myQx+"; show("+myQx+");listvar(ideal);"+
523  "listvar(matrix);",
524  "// NOTE: rings "+myQx+", "+myOx+", "+mySo+" are still alive!",
525  "// (use: 'kill_rings("+@my+");' to remove them)");
526  return();
527}
528example
529{ "EXAMPLE:"; echo = 2;
530  int p = printlevel;
531  printlevel = 1;
532  ring  Ro = 0,(x,y),wp(3,4);
533  ideal Io = x4+y3;
534  matrix Mo[2][2] = x2,y,-y2,x2;
535  mod_versal(Mo,Io);
536  printlevel = p;
537  kill Px,Qx,So;
538}
539//=============================================================================
540///////////////////////////////////////////////////////////////////////////////
541proc kill_rings(list #)
542USAGE: kill_rings([string]);
543Sub-procedure: kills exported rings of 'versal' and
544               'mod_versal' with prefix 'string'
545{
546  string my,br;
547  if (size(#)>0)     { my = #[1];}
548  string na=nameof(basering);
549  br = my+"Qx";
550  if (defined(`br`)) { kill `br`;}
551  br = my+"Px";
552  if (defined(`br`)) { kill `br`;}
553  br = my+"So";
554  if (defined(`br`)) { kill `br`;}
555  br = my+"Ox";
556  if (defined(`br`)) { kill `br`;}
557  br = my+"Sx";
558  if (defined(`br`)) { kill `br`}
559  if (defined(basering)==0)
560  { "// choose new basering?";
561    listvar(ring);
562  }
563  return();
564}
565///////////////////////////////////////////////////////////////////////////////
566proc compute_ext(matrix Mo,int p)
567
568Sub-procedure: obtain Ext1 and Ext2 and other objects used by mod_versal
569{
570   int    l,f0,f1,f2,f3,e1,e2,ok_ann;
571   module Co,Do,ima,ex1,ex2;
572   matrix M0,M1,M2,ker,kb1,lift1,kb2,A,B,C,D; 
573//------- resM ---------------------------------------------------------------
574   list resM = res(Mo,3);   
575   M0 = resM[1];
576   M1 = resM[2];
577   M2 = resM[3];   kill resM;
578   f0 = nrows(M0);
579   f1 = ncols(M0);
580   f2 = ncols(M1);
581   f3 = ncols(M2);
582//------ compute Ext^2  ------------------------------------------------------
583   B    = kohom(M0,f3);
584   A    = kontrahom(M2,f0);
585   D    = modulo(A,B);
586   Do   = std(D);   
587   ima  = kohom(M0,f2),kontrahom(M1,f0);
588   ex2  = modulo(D,ima);
589   ex2  = std(ex2);
590   e2   = vdim(ex2);
591   kb2  = kbase(ex2);
592      dbprint(p,"// vdim (Ext^2) = "+string(e2));
593//------ test: max = Ann(Ext2) -----------------------------------------------
594   for (l=1;l<=e2;l=l+1)
595   { ok_ann = ok_ann+ord(kb2[l]);
596   }
597   if (ok_ann==0)
598   {  e2 =nrows(ex2);   
599      dbprint(p,"// Ann(Ext2) is maximal");
600   }
601//------ compute Ext^1 -------------------------------------------------------
602   B     = kohom(M0,f2);
603   A     = kontrahom(M1,f0);
604   ker   = modulo(A,B);
605   ima   = kohom(M0,f1),kontrahom(M0,f0); 
606   ex1   = modulo(ker,ima);
607   ex1   = std(ex1);
608   e1    = vdim(ex1);
609      dbprint(p,"// vdim (Ext^1) = "+string(e1));
610   kb1   = kbase(ex1);
611   kb1   = ker*kb1;
612   C     = concat(A,B);
613   Co    = std(C);
614//------ compute the liftings of Ext^1 ---------------------------------------
615   lift1 = A*kb1;
616   lift1 = lift(B,lift1);
617   intvec iv = f0,f1,f2,e1,e2,ok_ann;
618   list   L' = ex2,kb2,C,Co,D,Do;
619   return(iv,M1,kb1,lift1,L');
620}
621//////////////////////////////////////////////////////////////////////////////
622proc get_rings(ideal Io,int e1,int switch, list #)
623
624Sub-procedure: creating ring-extensions
625{
626   def Po = basering;
627   string my;
628   string my_ord = "ds";
629   string my_var = "A";
630   if (size(#)>2)
631   {
632     my     = #[1];
633     my_ord = #[2];
634     my_var = #[3];
635   }
636   string my_Px = my+"Px";
637   string my_Qx = my+"Qx";
638   string my_Ox = my+"Ox";
639   string my_So = my+"So";
640  extendring(my_Px,e1,my_var,my_ord);
641   ideal Io  = imap(Po,Io);         attrib(Io,"isSB",1);
642   my ="qring "+my_Qx+" = Io;       export("+my_Qx+");";
643  execute(my);
644   if (switch)
645   {
646     setring `my_Px`;
647     my = "qring "+my_Ox+" = std(ideal(0));export("+my_Ox+");";
648   }
649   else
650   {
651     my = "def "+my_Ox+" = "+my_Qx+";export("+my_Ox+");";
652   }
653  execute(my);
654  defring(my_So,charstr(Po),e1,my_var,my_ord);
655  return();
656}
657//////////////////////////////////////////////////////////////////////////////
658proc get_inf_def(list #);     
659
660Sub-procedure: compute infinitesimal family of a module and its syzygies
661               from a kbase of Ext1 and its lifts
662{
663  matrix Ms  = #[1];
664  matrix Ls  = #[2];
665  matrix kb1 = #[3];
666  matrix li1 = #[4];
667  int   e1,f0,f1,f2;
668  poly X_s     = #[5];
669  e1 = ncols(kb1);
670  f0 = nrows(Ms);
671  f1 = nrows(Ls);
672  f2 = ncols(Ls);
673  int  l;
674  for (l=1;l<=e1;l=l+1)
675  {
676     Ms = Ms + var(l)*matrix(ideal(kb1[l]),f0,f1);
677     Ls = Ls - var(l)*matrix(ideal(li1[l]),f1,f2);
678  }
679  return(Ms,Ls);
680}
681//////////////////////////////////////////////////////////////////////////////
682proc lift_rel_kb (module N, module M, list #)
683
684USAGE   lift_rel_kb(N,M[,kbaseM,p]);
685ASSUME  [p a monomial ] or the product of all variables
686        N, M modules of same rank,
687        M depending only on variables not in p and vdim(M) finite in this ring,
688        [ kbaseM the kbase of M in the subring given by variables not in p ]
689        warning: check that these assumtions are fulfilled!
690RETURN  matrix A, whose j-th columnes present the coeff's of N[j] in kbaseM,
691        i.e. kbaseM*A = reduce(N,std(M))
692EXAMPLE example lift_rel_kb;  shows examples
693{
694  poly p = product(maxideal(1));
695       M = std(M);
696  matrix A;
697  if (size(#)>0) { p=#[2]; module kbaseM=#[1];}
698  else
699  { if (vdim(M)<=0) { "// vdim(M) not finite";return(A);}
700    module kbaseM = kbase(M);
701  }
702  N = reduce(N,M);
703  if (simplify(N,10)[1]==[0]) {return(A);}
704  A = coeffs(N,kbaseM,p);
705  return(A);
706}
707example
708{
709  "EXAMPLE"; echo=2;
710  ring r=0,(A,B,x,y),dp;
711  module M      = [x2,xy],[xy,y3],[y2],[0,x];
712  module kbaseM = [1],[x],[xy],[y],[0,1],[0,y],[0,y2];
713  poly f=xy;
714  module N = [AB,BBy],[A3xy+x4,AB*(1+y2)];
715  matrix A = lift_rel_kb(N,M,kbaseM,f);
716  print(A);
717  "TEST:";
718  print(matrix(kbaseM)*A-matrix(reduce(N,std(M))));
719  "2nd EXAMPLE";
720  ring   r = 100,(x,y),dp;
721  ideal  I = x2+y2,x2y;
722  module M = jacob(I)+I*freemodule(2);
723  module N = [x+y,1+x2+xy];
724  matrix A = lift_rel_kb(N,M);
725  print(A);
726  print(kbase(std(M))*A);
727  print(reduce(N,std(M)));
728}
729///////////////////////////////////////////////////////////////////////////////
730proc interact1 ()
731
732Sub_procedure: asking for and reading your input-strings
733{
734 string my = "@";
735 string str,out,my_ord,my_var;
736 my_ord = "ds";
737 my_var = "A";
738 "INPUT: name of output-file (ENTER = no output, do not use \"my\"!)";
739   str = read("");                                 
740   if (size(str)>1)
741   { out = str[1..size(str)-1];}
742   else
743   { out = "no";}
744 "INPUT: prefix-string of ring-extension (ENTER = '@')";
745   str = read("");
746   if ( size(str) > 1 )
747   { my = str[1..size(str)-1]; }     
748 "INPUT:parameter-string
749   (give a letter corresponding to first new variable followed by the next letters,
750   or 'T('       - a letter + '('  - getting a string of indexed variables)
751   (ENTER = A) :";
752   str = read("");
753   if (size(str)>1) { my_var=str[1..size(str)-1]; }
754 "INPUT:order-string (local or weighted!) (ENTER = ds) :";
755   str = read("");
756   if (size(str)>1) { my_ord=str[1..size(str)-1]; }   
757   if( find(my_ord,"s")+find(my_ord,"w") == 0 )
758   { "// ordering must be an local! changed into 'ds'";
759     my_ord = "ds";
760   }
761   return(my,my_var,my_ord,out);
762}
763///////////////////////////////////////////////////////////////////////////////
764proc interact2 (matrix A, intvec col_vec, list #)
765
766Sub-procedure: asking for and reading your input
767{
768  module B,C;
769  matrix D;
770  int flag;
771  if (size(#)>0) { D=#[1];flag=1;}
772  int t1 = ncols(A);
773  ">>Do you want all deformations? (ENTER=yes)";
774  string str = read("");
775  if (size(str)>1)
776  { ">> Choose columnes of the matrix";
777    ">> (Enter = all columnes)";
778    "INPUT (number of columnes to use as integer-list 'i_1,i_2,.. ,i_t' ):";
779    string columnes = read("");
780    if (size(columnes)<2) {columnes=string(col_vec);}
781    t1 = size(columnes)/2;
782    int l,l1;
783    for (l=1;l<=t1;l=l+1)
784    {
785      execute("l1= "+columnes[2*l-1]+";");
786      B[l] = A[l1];
787      if(flag) { C[l]=D[l1];}   
788    }
789    A = matrix(B,nrows(A),size(B));
790    D = matrix(C,nrows(D),size(C));
791  }
792  return(A,D,t1);
793}
794///////////////////////////////////////////////////////////////////////////////
795proc negative_part(intvec iv)
796
797RETURNS intvec of indices of jv having negative entries (or iv, if non)
798{
799   intvec jv;
800   int    l,k;
801   for (l=1;l<=size(iv);l=l+1)
802   { if (iv[l]<0)
803     {  k = k+1;
804        jv[k]=l;
805     }
806   }
807   if (jv==0) {jv=1; dbprint(printlevel-1,"// empty negative part, return all ");}
808   return(jv);
809}
810///////////////////////////////////////////////////////////////////////////////
811proc find_ord(matrix A, intvec w_vec)
812
813Sub-proc: return martix ord(a_ij) with respect to weight_vec, or
814          0 if A non-qh
815{
816  int @r = nrows(A);
817  int @c = ncols(A);
818  int i,j;
819  string ord_str = "wp("+string(w_vec)+")";
820  def br = basering;
821 changeord("nr",ord_str);
822  matrix A    = imap(br,A);
823  intmat degA[@r][@c];
824  if (homog(ideal(A)))
825  { for (i=1;i<=@r;i=i+1)
826    { for(j=1;j<=@c;j=j+1)
827      {  degA[i,j]=ord(A[i,j]); }
828    }
829  }
830 setring br;
831  kill nr;
832  return(degA);
833}
834//////////////////////////////////////////////////////////////////////////////////
835proc homog_test(intvec w_vec, matrix Mo, matrix A)
836
837Sub proc: return relative weight string of columnes of A with respect
838          to the given w_vec and to Mo, or "" if not qh
839    NOTE: * means weight is not determined
840{
841  int k,l;
842  intvec tv;
843  string @nv;
844  int @r = nrows(A);
845  int @c = ncols(A);
846  A = concat(matrix(ideal(Mo),@r,1),A);
847  intmat a = find_ord(A,w_vec);     
848  intmat b[@r][@c];
849  for (l=1;l<=@c;l=l+1)
850  {
851    for (k=1;k<=@r;k=k+1)
852    {  if (A[k,l+1]!=0)
853       { b[k,l] = a[k,l+1]-a[k,1];}
854    }
855    tv = 0;
856    for (k=1;k<=@r;k=k+1)
857    {  if (A[k,l+1]*A[k,1]!=0)
858       {tv = tv,b[k,l];}
859    }
860    if (size(tv)>1)
861    { k = tv[2];
862      tv = tv[2..size(tv)]; tv = tv -k;
863      if (tv==0) { @nv = @nv+string(-k)+",";}
864      else {return("");}
865    }
866    else { @nv = @nv+"*,";}
867  }
868  @nv = @nv[1..size(@nv)-1];
869  return(@nv);
870}
871//////////////////////////////////////////////////////////////////////////////////
872proc homog_t(intvec d_vec, matrix Fo, matrix A)
873
874Sub-procedure: Computing relative (with respect to flatten(Fo)) weight_vec
875               of columnes of A (return zero if Fo or A not qh)
876{
877   Fo = matrix(Fo,nrows(A),1);
878   A  = concat(Fo,A);
879   A  = transpose(A);
880   def br = basering;
881   string o_str = "wp("+string(d_vec)+")";
882 changeord("nr",o_str);
883   module A = fetch(br,A);
884   intvec dv;
885   int l = homog(A) ;
886   if (l==0) {setring br; kill nr; return(l);}
887   dv = attrib(A,"isHomog");
888   l  = dv[1];
889   dv = dv[2..size(dv)];
890   dv = dv-l;
891 setring br;
892   kill nr;
893   return(dv);
894}
895
896
897///////////////////////////////////////////////////////////////////////////////
898
899proc lift_kbase (N, M)
900USAGE:   lift_kbase(N,M); N,M=poly/ideal/vector/module
901RETURN:  matrix A, coefficient matrix expressing N as linear combination of
902         k-basis of M. Let the k-basis have k elements and size(N)=c columns.
903         Then A satisfies:
904             matrix(reduce(N,std(M)),k,c) = matrix(kbase(std(M)))*A
905ASSUME:  dim(M)=0 and the monomial ordering is a well ordering or the last
906         block of the ordering is c or C
907EXAMPLE: example lift_kbase; shows an example
908{
909//----------  initialisation  -------------------------------------------------
910   string ords = ordstr(basering);
911   int    d,col,k,l;
912   module kb;
913   matrix testm;
914   vector v,p,q;
915//------- check wether ordering is correct ------------------------------------
916   k=1;
917   for( l=1;l<=nvars(basering);l=l+1 ) { k=k*(lead(1+var(l))==var(l)); }
918   if( k==0 )
919   {
920      if( ords[size(ords)]!="c" and ords[size(ords)]!="C" )
921      {
922         "// change ordering!";
923         "// ordering "+ordstr(basering)+" not implemented for this proc";
924         return();
925      }
926   }
927//----------  check assumtions  -----------------------------------------------
928   if( typeof(N)=="poly" ) { ideal J=ideal(N); kill N; module N=J; kill J; }
929   if( typeof(M)=="poly" ) { ideal J=ideal(M); kill M; module M=J; }
930   M = std(M);
931   d = vdim(M);
932   if( d<1 )
933   { "// second argument in `lift_kbase` has vdim",d; return(); }
934//----------  compute kbase and reduce(N,M) -----------------------------------
935   kb = kbase(M);
936   col = ncols(N);
937   N = reduce(N,M);
938   N = matrix(N,nrows(N),col);
939//----------  collecting coefficients of reduce(N,M) --------------------------
940   matrix result[d][col];
941   for( l=1;l<=col;l=l+1 )
942   {
943      v = N[l];
944      if( size(v)>0 )
945      {
946         for( k=1;k<=d;k=k+1 )
947         {
948            p = kb[k];
949            q = lead(v);
950            if( size(p-q)<2 )
951            {
952               result[k,l] = leadcoef(q);
953               v = v-q;
954               if( size(v)<1 ) { k=d+1; }
955               else { k=0; }
956            }
957         }
958      }
959   }
960//---------  final test -------------------------------------------------------
961   testm = matrix(N,nrows(kb),ncols(result))- matrix(kb)*result;
962   if( size(module(testm))!=0 )
963   {
964      "// proc `lift_kbase` did'nt work correctly!";
965      "// Please inform tthe authors";
966      return();
967   }
968   return(result);
969}
970example
971{"EXAMPLE:";     echo=2;
972  ring R=0,(x,y),ds;
973  module M=[x2,xy],[y2,xy],[0,xx],[0,yy];
974  module N=[x3+xy,x],[x,x+y2];
975  print(M);
976  module kb=kbase(std(M));
977  print(kb);
978  print(N);
979  matrix A=lift_kbase(N,M);
980  print(A);
981  matrix(reduce(N,std(M)),nrows(kb),ncols(A)) - matrix(kbase(std(M)))*A;
982}
Note: See TracBrowser for help on using the repository browser.