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

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