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

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