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

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