source: git/Singular/LIB/deform.lib @ f0c6f4

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