source: git/Singular/LIB/deform.lib @ 07329b2

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