source: git/Singular/LIB/deform.lib @ 1d202e

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