source: git/Singular/LIB/deform.lib @ 5480da

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