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

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