source: git/Singular/LIB/deform.lib @ 0b59f5

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