Annotation of OpenXM/src/kan96xx/Doc/restall_s.sm1.org2, Revision 1.1.1.1
1.1 maekawa 1: %% restall_sn.sm1, New restall_s.sm1 is developed here.
2: %% /BFmessage 0 def controlled from cohom.sm1
3: BFmessage {
4: (**********************************************) message
5: [$ New restall_s (restall_s.sm1) $
6: $ 1999, 1/29: only Schreyer 1 works. For more than one unknowns. $
7: $ 1999, 5/21: Schreyer 2 is working for more than one unknowns.$
8: $ Schryer 2 still contains a bug when we truncate from the below.See gbhg3/Int/bug.sm1 and Example 5.6$
9: $ of Oaku-Takayama, math.AG/980506 $
10: ] {message} map
11: (**********************************************) message
12: } { } ifelse
13: %%changed the following symbols.
14: %% complement ==> oaku.complement
15: %% syz ==> o.syz
16:
17: %%%%%%%%%%%%%%%%%%%%%%% restall.sm1 (Version 19980415) %%%%%%%%%%%%%%%%%%%%%%%
18: (restall_s.sm1...compute all the cohomology groups of the restriction) message-quiet
19: ( of a D-module to tt = (t_1,...,t_d) = (0,...,0).) message-quiet
20: (Schreyer Version: 19990521 by N.Takayama & T.Oaku) message-quiet
21: (usage: [(P1)...] [(t1)...] k0 k1 deg restall_s -> cohomologies of restriction)
22: message-quiet
23: ( [(P1)...] [(t1)...] k0 k1 deg intall_s --> cohomologies of integration)
24: message-quiet
25: % History: Nov.10, 1997, Apr.15,1998
26: %%%%%%%%%%%%%%%%%%%%%%%%%%%% Global variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
27: %/BFvarlist %% Set all the variables (except s and the parameters) here.
28: /BFs (s) def
29: /BFth (s) def
30: /BFu (u) def
31:
32: /BFunknowns 1 def
33: [(x) (y)] /BFvarlist set
34: [ ] /BFparlist set
35:
36: /BFff
37: [ $x^3-y^2$ , $2*x*Dx + 3*y*Dy + 6$ , $2*y*Dx + 3*x^2*Dy$ ]
38: def
39:
40: %% 1 /Schreyer set Controlled from cohom.sm1
41: 0 /Cheat.restall_sn set
42: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
43: %% The cohomology groups of the restriction
44: %% [(P1)...] [(t1)...] k0 k1 degmax restall
45: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
46:
47: /restall_s {
48: /arg5 set %% degmax
49: /arg4 set %% k1
50: /arg3 set %% k0
51: /arg2 set %% [(t1) ... (td)]
52: /arg1 set %% BFequations
53: [
54: /ff /bftt /k0 /k1 /degmax /syzlist /mveclist /cohomlist
55: /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
56: /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
57: /psi1 /psi1ker /psi2image
58: /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
59: /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
60: /syz0
61: ] pushVariables
62: [
63: /ff arg1 def /bftt arg2 def /k0 arg3 def /k1 arg4 def
64: /degmax arg5 def
65: bftt length /d set
66:
67: (Computing a free resolution ... ) message
68:
69: Schreyer 1 eq {ff bftt degmax resolution_SV /syzlist set}
70: { Cheat.restall_sn
71: {
72: Schreyer 0 eq {ff bftt degmax resolution_nsV /syzlist set}{ } ifelse
73: }
74: {
75: Schreyer 2 eq {ff bftt degmax resolution_Sh dehomogenize /syzlist set}
76: { (This version of restall_s works only for Schyreyer 1 and 2) message
77: error
78: } ifelse
79: } ifelse
80: } ifelse
81:
82: syzlist /BFresolution set
83: (A free resolution obtained.) message
84:
85: BFvarlist /ttxx set
86: BFparlist /aa set
87: [BFs] ttxx join aa join /allvarlist set
88: ttxx length /dn set
89: ttxx {xtoDx} map /Dttxx set
90:
91: /BFs_weight
92: [ [ BFs 1 ]
93: [ 0 1 dn 1 sub
94: { /i set Dttxx i get 1 }
95: for
96: 0 1 dn 1 sub
97: { /i set ttxx i get 1 }
98: for ]
99: ] def
100:
101: [ allvarlist listtostring ring_of_differential_operators
102: BFs_weight weight_vector 0 ] define_ring
103:
104: %% Reformatting the free resolution:
105: %% [[f1,f2,..],[syz1,...]] --> [[[f1],[f2],...],[syz,...]] (strings)
106: %% (to be modified for the case with more than one unknowns.)
107:
108: Schreyer 0 gt {
109: /syzlist1 [
110: syzlist 0 get /syz0 set
111: %% start N.T.
112: [BFunknowns syz0 { toString . } map]
113: toVectors2 { {toString} map } map
114: %% end N.T.
115: 1 1 degmax {/i set
116: syzlist 1 get i 1 sub get {toStrings} map
117: } for
118: ] def
119: syzlist1 /syzlist set
120: }{
121: /syzlist1 [
122: syzlist 0 get /syz0 set
123: [ 0 1 syz0 length 1 sub {/i set
124: [ syz0 i get (string) dc ]
125: } for ]
126: 1 1 degmax {/i set
127: syzlist i get {toStrings} map
128: } for
129: ] def
130: syzlist1 /syzlist set
131: } ifelse
132:
133: [ ] /cohomlist set
134:
135: %% Start the loop:
136: 0 1 degmax {/ideg set
137:
138: %(new loop: ) messagen ideg ::
139:
140: ideg 0 eq {
141: 1 /r0 set
142: %% N.T.
143: BFunknowns /r1 set
144: [ 1 1 BFunknowns { pop [ (0) ]} for ] /gbase set
145: [ 0 ] /m0vec set
146: [ 1 1 BFunknowns { pop 0} for ] /m1vec set
147: %% end N.T.
148: }{
149: syzlist << ideg 1 sub >> get /gbase set
150: r0 /r1 set
151: } ifelse
152: syzlist ideg get /o.syz set
153:
154: %% o.syz gbase
155: %% D^{r2} --> D^{r1} --> D^{r0}
156: %% with weight vectors: m2vec m1vec m0vec
157: %% which will induce a complex
158: %% psi2 psi1
159: %% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
160:
161: gbase length /r1 set
162: o.syz length /r2 set
163: /m2vec null def %% initialize.
164: BFmessage {
165: (m2vec = ) messagen m2vec message
166: (o.syz = ) messagen o.syz pmat
167: (m1vec = ) messagen m1vec message
168: (gbase = ) messagen gbase pmat
169: (m0vec = ) messagen m0vec message
170: } { } ifelse
171:
172:
173: %% (Computing the weight vector m2vec from m1vec and syz) message
174: /m2vec [
175: 0 1 r2 1 sub {/i set
176: o.syz i get /syzi set
177: 0 /nonzero set
178: 0 1 r1 1 sub {/j set
179: syzi j get expand /syzij set
180: syzij (0). eq { }{
181: syzij bftt fwh_order m1vec j get add /maxtmp set
182: nonzero 0 eq { maxtmp /max0 set }{
183: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
184: } ifelse
185: 1 /nonzero set
186: } ifelse
187: } for
188: max0 } for ] def
189:
190: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
191: BFu /estr set
192: /ee
193: [ 1 1 d {/i set estr i toString 2 cat_n} for ]
194: def
195: [@@@.esymbol ] ee join /eee set
196:
197: %%(Setting up a ring that represents D_{Y->X}^{r1}) message
198: eee length /neee set
199: /eeemvec [ 1 1 neee {pop 1} for ] def
200: eee [ ] [BFs] BFvarlist join eeemvec setupDringVshift
201: bftt {xtoDx expand} map /bfDtt set
202: [ ] /psi1 set
203: [ ] /psi1index set
204: [ ] /zerolist set
205:
206: %%(converting gbase to a list of polynomials) message
207: /gbase1
208: [ 0 1 r1 1 sub {/i set
209: gbase i get {expand [[BFs expand (1).]] replace} map vector_to_poly
210: } for ] def
211:
212: gbase1 /gbase set
213:
214: %%(ideg =) messagen ideg ::
215: %%(Computing psi1) message
216: %% psi1
217: %% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
218: %% with weight k0 - m1vec <= k <= k1 - m1vec
219: 0 1 r1 1 sub {/i set
220: m1vec i get /m1i set
221: ee {expand} map k0 m1i sub k1 m1i sub monomials /emonoi set
222: bfDtt k0 m1i sub k1 m1i sub monomials /bfDttmonoi set
223: emonoi length /nmono set
224: 0 1 nmono 1 sub {/j set
225: @@@.esymbol expand i npower /eei set
226: emonoi j get eei mul /eei set
227: gbase i get /dtp set
228: bfDttmonoi j get dtp mul /dtp set
229: 0 1 d 1 sub {/k set
230: dtp [[bftt k get expand (0).]] replace /dtp set
231: dtp [[bfDtt k get ee k get expand]] replace /dtp set
232: } for
233: dtp [[(h). (1).]] replace /dtp set
234: dtp << ee {expand} map >> m0vec k0 Vtruncate_below /dtp set
235: dtp (0). eq {
236: zerolist [eei] join /zerolist set
237: }{
238: psi1index [eei] join /psi1index set
239: psi1 [dtp] join /psi1 set
240: } ifelse
241: } for
242: } for
243:
244: %%(ideg =) messagen ideg ::
245: %%(psi1 obtained.) message
246: %%(Computing psi1ker) message
247:
248: %% Computing psi1ker := Ker psi1 :
249: psi1 length 0 eq {
250: [ ] /psi1ker set
251: }{
252: psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
253: [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
254: psi1kervec length /pn set
255: psi1index length /pn0 set
256: [ ] /psi1ker set
257: 0 1 pn 1 sub {/i set
258: psi1kervec i get /psi1i set
259: (0). /psi1keri set
260: 0 1 pn0 1 sub {/j set
261: psi1index j get psi1i j get mul psi1keri add /psi1keri set
262: } for
263: psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
264: } for
265: } ifelse
266: zerolist psi1ker join /psi1ker set
267: % Is it all right to use reducedBase here?
268: % psi1ker length 0 eq { }{
269: % psi1ker reducedBase /psi1ker set
270: % } ifelse
271: %%(ideg =) messagen ideg ::
272: %%(psi1ker obtained.) message
273: %%(Computing psi2image ...) message
274:
275: %% psi2
276: %% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
277: %% with weight k0 - m2vec <= k <= k1 - m2vec
278: /psi2image [
279: 0 1 r2 1 sub {/i set
280: o.syz i get {expand [[BFs expand (1).]] replace} map /syzi set
281: syzi vector_to_poly /syzi set
282: m2vec i get /m2i set
283: bfDtt k0 m2i sub k1 m2i sub monomials /bfDttmonoi set
284: bfDttmonoi length /nmono set
285: 0 1 nmono 1 sub {/j set
286: bfDttmonoi j get syzi mul /syzij set
287: 0 1 d 1 sub {/k set
288: syzij [[bftt k get expand (0).]] replace /syzij set
289: syzij [[bfDtt k get ee k get expand]] replace /syzij set
290: } for
291: syzij [[(h). (1).]] replace /syzij set
292: syzij << ee {expand} map >> m1vec k0 Vtruncate_below /syzij set
293: syzij (0). eq { }{syzij} ifelse
294: } for
295: } for
296: ] def
297:
298: %(psi2image obtained.) message
299: %(ideg = ) messagen ideg ::
300: %(psi1ker = ) message psi1ker ::
301: %(psi2image =) message psi2image ::
302:
303: %% Computes the quotient module psi1ker/psi2image
304: psi1ker length /nker set
305: nker 0 eq {
306: [0 [ ]] /cohom set
307: }{
308: psi2image length /nim set
309: psi1ker psi2image join /psiall set
310: psiall {homogenize} map /psiall set
311: [psiall [(needSyz)]] groebner 2 get /psisyz set
312: psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
313: cohom {remove0} map /cohom set
314: cohom length 0 eq {
315: [nker [ ]] /cohom set
316: }{
317: cohom {homogenize} map /cohom set
318: [cohom] groebner 0 get reducedBase /cohom set
319: cohom {[[(h). (1).]] replace} map /cohom set
320: [nker cohom] trimModule /cohom set
321: } ifelse
322: } ifelse
323: cohomlist [cohom] join /cohomlist set
324: 0 ideg sub print (-th cohomology: ) messagen
325: cohom ::
326: r1 /r0 set
327: r2 /r1 set
328: m1vec /m0vec set
329: m2vec /m1vec set
330: } for
331:
332: cohomlist /arg1 set
333: ] pop
334: popVariables
335: arg1
336: } def
337:
338: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
339: %% The cohomology groups of the restriction without truncation from below
340: %% [(P1)...] [(t1)...] k1 degmax restall
341: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
342:
343: /restall1_s {
344: /arg5 set %% degmax
345: /arg4 set %% k1
346: /arg2 set %% [(t1) ... (td)]
347: /arg1 set %% BFequations
348: [
349: /ff /bftt /k1 /degmax /syzlist /mveclist /cohomlist
350: /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
351: /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
352: /psi1 /psi1ker /psi2image
353: /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
354: /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
355: /syz0
356: ] pushVariables
357: [
358: /ff arg1 def /bftt arg2 def /k1 arg4 def
359: /degmax arg5 def
360: bftt length /d set
361:
362: (Computing a free resolution ... ) message
363: Schreyer 2 eq {ff bftt degmax resolution_Sh /syzlist set}{ } ifelse
364: Schreyer 1 eq {ff bftt degmax resolution_SV /syzlist set}{ } ifelse
365: Schreyer 0 eq {ff bftt degmax resolution_nsV /syzlist set}{ } ifelse
366:
367: (A free resolution obtained.) message
368:
369: BFvarlist /ttxx set
370: BFparlist /aa set
371: [BFs] ttxx join aa join /allvarlist set
372: ttxx length /dn set
373: ttxx {xtoDx} map /Dttxx set
374:
375: /BFs_weight
376: [ [ BFs 1 ]
377: [ 0 1 dn 1 sub
378: { /i set Dttxx i get 1 }
379: for
380: 0 1 dn 1 sub
381: { /i set ttxx i get 1 }
382: for ]
383: ] def
384:
385: [ allvarlist listtostring ring_of_differential_operators
386: BFs_weight weight_vector 0 ] define_ring
387:
388: %% Reformatting the free resolution:
389: %% [[f1,f2,..],[syz1,...]] --> [[[f1],[f2],...],[syz,...]] (strings)
390: %% (to be modified for the case with more than one unknowns.)
391:
392: Schreyer 0 gt {
393: /syzlist1 [
394: syzlist 0 get /syz0 set
395: %% start N.T.
396: [BFunknowns syz0 { toString . } map]
397: toVectors2 { {toString} map } map
398: %% end N.T.
399: 1 1 degmax {/i set
400: syzlist 1 get i 1 sub get {toStrings} map
401: } for
402: ] def
403: syzlist1 /syzlist set
404: }{
405: /syzlist1 [
406: syzlist 0 get /syz0 set
407: [ 0 1 syz0 length 1 sub {/i set
408: [ syz0 i get (string) dc ]
409: } for ]
410: 1 1 degmax {/i set
411: syzlist i get {toStrings} map
412: } for
413: ] def
414: syzlist1 /syzlist set
415: } ifelse
416:
417: [ ] /cohomlist set
418:
419: %% Start the loop:
420: 0 1 degmax {/ideg set
421:
422: %(new loop: ) messagen ideg ::
423:
424: ideg 0 eq {
425: 1 /r0 set
426: %% N.T.
427: BFunknowns /r1 set
428: [ 1 1 BFunknowns { pop [ (0) ]} for ] /gbase set
429: [ 0 ] /m0vec set
430: [ 1 1 BFunknowns { pop 0} for ] /m1vec set
431: %% end N.T.
432: }{
433: syzlist << ideg 1 sub >> get /gbase set
434: r0 /r1 set
435: } ifelse
436: syzlist ideg get /o.syz set
437:
438: %% o.syz gbase
439: %% D^{r2} --> D^{r1} --> D^{r0}
440: %% with weight vectors: m2vec m1vec m0vec
441: %% which will induce a complex
442: %% psi2 psi1
443: %% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
444:
445: gbase length /r1 set
446: o.syz length /r2 set
447:
448: BFmessage {
449: (m2vec = ) messagen m2vec message
450: (o.syz = ) messagen o.syz pmat
451: (m1vec = ) messagen m1vec message
452: (gbase = ) messagen gbase pmat
453: (m0vec = ) messagen m0vec message
454: } { } ifelse
455:
456: %% (Computing the weight vector m2vec from m1vec and syz) message
457: /m2vec [
458: 0 1 r2 1 sub {/i set
459: o.syz i get /syzi set
460: 0 /nonzero set
461: 0 1 r1 1 sub {/j set
462: syzi j get expand /syzij set
463: syzij (0). eq { }{
464: syzij bftt fwh_order m1vec j get add /maxtmp set
465: nonzero 0 eq { maxtmp /max0 set }{
466: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
467: } ifelse
468: 1 /nonzero set
469: } ifelse
470: } for
471: max0 } for ] def
472:
473: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
474: BFu /estr set
475: /ee
476: [ 1 1 d {/i set estr i toString 2 cat_n} for ]
477: def
478: [@@@.esymbol ] ee join /eee set
479:
480: %%(Setting up a ring that represents D_{Y->X}^{r1}) message
481: eee length /neee set
482: /eeemvec [ 1 1 neee {pop 1} for ] def
483: eee [ ] [BFs] BFvarlist join eeemvec setupDringVshift
484: bftt {xtoDx expand} map /bfDtt set
485: [ ] /psi1 set
486: [ ] /psi1index set
487: [ ] /zerolist set
488:
489: %%(converting gbase to a list of polynomials) message
490: /gbase1
491: [ 0 1 r1 1 sub {/i set
492: gbase i get {expand [[BFs expand (1).]] replace} map vector_to_poly
493: } for ] def
494:
495: gbase1 /gbase set
496:
497: %%(ideg =) messagen ideg ::
498: %%(Computing psi1) message
499: %% psi1
500: %% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
501: %% with weight = k <= k1 - m1vec
502: 0 1 r1 1 sub {/i set
503: m1vec i get /m1i set
504: ee {expand} map 0 k1 m1i sub monomials /emonoi set
505: bfDtt 0 k1 m1i sub monomials /bfDttmonoi set
506: emonoi length /nmono set
507: 0 1 nmono 1 sub {/j set
508: @@@.esymbol expand i npower /eei set
509: emonoi j get eei mul /eei set
510: gbase i get /dtp set
511: bfDttmonoi j get dtp mul /dtp set
512: 0 1 d 1 sub {/k set
513: dtp [[bftt k get expand (0).]] replace /dtp set
514: dtp [[bfDtt k get ee k get expand]] replace /dtp set
515: } for
516: dtp [[(h). (1).]] replace /dtp set
517: dtp (0). eq {
518: zerolist [eei] join /zerolist set
519: }{
520: psi1index [eei] join /psi1index set
521: psi1 [dtp] join /psi1 set
522: } ifelse
523: } for
524: } for
525:
526: %%(ideg =) messagen ideg ::
527: %%(psi1 obtained.) message
528: %%(Computing psi1ker) message
529:
530: %% Computing psi1ker := Ker psi1 :
531: psi1 length 0 eq {
532: [ ] /psi1ker set
533: }{
534: psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
535: [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
536: psi1kervec length /pn set
537: psi1index length /pn0 set
538: [ ] /psi1ker set
539: 0 1 pn 1 sub {/i set
540: psi1kervec i get /psi1i set
541: (0). /psi1keri set
542: 0 1 pn0 1 sub {/j set
543: psi1index j get psi1i j get mul psi1keri add /psi1keri set
544: } for
545: psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
546: } for
547: } ifelse
548: zerolist psi1ker join /psi1ker set
549: % Is it all right to use reducedBase here?
550: % psi1ker length 0 eq { }{
551: % psi1ker reducedBase /psi1ker set
552: % } ifelse
553: %%(ideg =) messagen ideg ::
554: %%(psi1ker obtained.) message
555: %%(Computing psi2image ...) message
556:
557: %% psi2
558: %% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
559: %% with weight m2vec <= k <= k1 - m2vec
560: /psi2image [
561: 0 1 r2 1 sub {/i set
562: o.syz i get {expand [[BFs expand (1).]] replace} map /syzi set
563: syzi vector_to_poly /syzi set
564: m2vec i get /m2i set
565: bfDtt 0 k1 m2i sub monomials /bfDttmonoi set
566: bfDttmonoi length /nmono set
567: 0 1 nmono 1 sub {/j set
568: bfDttmonoi j get syzi mul /syzij set
569: 0 1 d 1 sub {/k set
570: syzij [[bftt k get expand (0).]] replace /syzij set
571: syzij [[bfDtt k get ee k get expand]] replace /syzij set
572: } for
573: syzij [[(h). (1).]] replace /syzij set
574: syzij (0). eq { }{syzij} ifelse
575: } for
576: } for
577: ] def
578:
579: %(psi2image obtained.) message
580: %(ideg = ) messagen ideg ::
581: %(psi1ker = ) message psi1ker ::
582: %(psi2image =) message psi2image ::
583:
584: %% Computes the quotient module psi1ker/psi2image
585: psi1ker length /nker set
586: nker 0 eq {
587: [0 [ ]] /cohom set
588: }{
589: psi2image length /nim set
590: psi1ker psi2image join /psiall set
591: psiall {homogenize} map /psiall set
592: [psiall [(needSyz)]] groebner 2 get /psisyz set
593: psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
594: cohom {remove0} map /cohom set
595: cohom length 0 eq {
596: [nker [ ]] /cohom set
597: }{
598: cohom {homogenize} map /cohom set
599: [cohom] groebner 0 get reducedBase /cohom set
600: cohom {[[(h). (1).]] replace} map /cohom set
601: [nker cohom] trimModule /cohom set
602: } ifelse
603: } ifelse
604: cohomlist [cohom] join /cohomlist set
605: 0 ideg sub print (-th cohomology: ) messagen
606: cohom ::
607: r1 /r0 set
608: r2 /r1 set
609: m1vec /m0vec set
610: m2vec /m1vec set
611: } for
612:
613: cohomlist /arg1 set
614: ] pop
615: popVariables
616: arg1
617: } def
618:
619: /intall_s {
620: /arg5 set %% degmax
621: /arg4 set %% k1
622: /arg3 set %% k0
623: /arg2 set %% [(t1) ... (td)]
624: /arg1 set %% BFequations
625: [ /ff /bftt /k0 /k1 /degmax /ffdx ] pushVariables
626: [
627: /ff arg1 def /bftt arg2 def /k0 arg3 def /k1 arg4 def
628: /degmax arg5 def
629: BFvarlist setupDring
630: ff {bftt fourier} map /ffdx set
631: ffdx bftt k0 k1 degmax restall_s /arg1 set
632: ] pop
633: popVariables
634: arg1
635: } def
636:
637: /intall1_s {
638: /arg5 set %% degmax
639: /arg4 set %% k1
640: /arg2 set %% [(t1) ... (td)]
641: /arg1 set %% BFequations
642: [ /ff /bftt /k1 /degmax /ffdx ] pushVariables
643: [
644: /ff arg1 def /bftt arg2 def /k0 arg3 def /k1 arg4 def
645: /degmax arg5 def
646: BFvarlist setupDring
647: ff {bftt fourier} map /ffdx set
648: ffdx bftt k1 degmax restall1_s /arg1 set
649: ] pop
650: popVariables
651: arg1
652: } def
653:
654: /resolution_Sh {
655: /arg3 set /arg2 set /arg1 set
656: [ /tt /ff /deg /ttxx /aa /allvarlist /d /n /m /Dtt /Dxx /xx
657: /i /V_weight /G
658: ] pushVariables
659: [
660: arg1 /ff set arg2 /tt set arg3 /deg set
661: BFvarlist /ttxx set
662: BFparlist /aa set
663: ttxx aa join /allvarlist set
664: tt length /d set
665: ttxx tt setminus /xx set
666: xx length /n set
667: aa length /m set
668: tt {xtoDx} map /Dtt set
669: xx {xtoDx} map /Dxx set
670:
671: /V_weight [
672: [ 0 1 d 1 sub {/i set Dtt i get 1} for
673: 0 1 d 1 sub {/i set tt i get -1} for ]
674: [ 0 1 n 1 sub {/i set Dxx i get 1} for
675: 0 1 n 1 sub {/i set xx i get 1} for ]
676: ] def
677:
678: ttxx aa join /allvarlist set
679:
680: %% start N.T.
681: ff 0 get isArray {
682: /BFunknowns ff 0 get length def
683: } { /BFunknowns 1 def } ifelse
684: ff 0 get isArray {
685: ff { {toString} map } map /ff set
686: }{ ff { toString } map /ff set } ifelse
687: BFmessage
688: { (Homogenized ff = ) messagen ff message
689: (BFvarlist = ) messagen BFvarlist message
690: (BFparlist = ) messagen BFparlist message
691: (BFs = ) messagen BFs message
692: } { } ifelse
693: %% end N.T.
694:
695: [ allvarlist listtostring s_ring_of_differential_operators
696: V_weight s_weight_vector 0 [(schreyer) 1]] define_ring
697: ff 0 get isArray {
698: deg ff { {tparse} map } map sResolution /G set
699: } {
700: deg ff {tparse} map sResolution /G set
701: } ifelse
702: G /arg1 set
703: ] pop
704: popVariables
705: arg1
706: } def
707:
708: /resolution_SV {
709: /arg3 set /arg2 set /arg1 set
710: [ /ff /tt /deg /ttxx /aa /allvarlist /xx /dn /Dttxx /BFs_weight /i /G
711: ] pushVariables
712: [
713: arg1 /ff set arg2 /tt set arg3 /deg set
714: BFvarlist /ttxx set
715: BFparlist /aa set
716: [BFs] ttxx join aa join /allvarlist set
717: ttxx tt setminus /xx set
718: ttxx length /dn set
719: ttxx {xtoDx} map /Dttxx set
720:
721: /BFs_weight
722: [ [ BFs 1 ]
723: [ 0 1 dn 1 sub
724: { /i set Dttxx i get 1 }
725: for
726: 0 1 dn 1 sub
727: { /i set ttxx i get 1 }
728: for ]
729: ] def
730:
731: %% start N.T.
732: ff 0 get isArray {
733: /BFunknowns ff 0 get length def
734: } { /BFunknowns 1 def } ifelse
735: [ allvarlist listtostring ring_of_differential_operators
736: BFs_weight s_weight_vector 0] define_ring
737: ff 0 get isArray {
738: ff { {toString .} map
739: [0 1 BFunknowns 1 sub { /i set @@@.esymbol . i npower } for]
740: mul toString
741: } map /ff set
742: }{ ff { toString } map /ff set } ifelse
743: ff {tt fwm_homogenize} map /ff set
744: BFmessage
745: { (Homogenized ff = ) messagen ff message
746: (BFvarlist = ) messagen BFvarlist message
747: (BFparlist = ) messagen BFparlist message
748: (BFs = ) messagen BFs message
749: } { } ifelse
750: %% end N.T.
751:
752: [ allvarlist listtostring s_ring_of_differential_operators
753: BFs_weight s_weight_vector 0 [(schreyer) 1]] define_ring
754:
755: deg ff {tparse [[(h).(1).]] replace } map sResolution /G set
756:
757: G /arg1 set
758: ] pop
759: popVariables
760: arg1
761: } def
762:
763: %% Computing a free resolution compatible with the V-filtration
764: %% w.r.t. tt
765: /resolution_nsV {
766: /arg3 set %% rdegmax
767: /arg2 set %% tt
768: /arg1 set %% ff
769: [
770: /ff /tt /rdegmax /ttxx /xx /aa /dn /d /Dttxx /i /syzlist /rdeg
771: /allvarlist /gbase /o.syz /gbase1 /syz2 /syz3 /nsyz /syz2i /syz2ij
772: ] pushVariables
773: [
774: arg1 /ff set
775: arg2 /tt set
776: arg3 /rdegmax set
777: BFvarlist /ttxx set
778: BFparlist /aa set
779: ttxx tt setminus /xx set
780: ttxx length /dn set
781: /allvarlist
782: [ BFs ] ttxx join aa join
783: def
784: ttxx {xtoDx} map /Dttxx set
785: /BFs_weight
786: [ [ BFs 1 ]
787: [ 0 1 dn 1 sub
788: { /i set Dttxx i get 1 }
789: for
790: 0 1 dn 1 sub
791: { /i set ttxx i get 1 }
792: for ]
793: ] def
794: [ allvarlist listtostring ring_of_differential_operators
795: BFs_weight weight_vector
796: 0] define_ring
797: BFs expand /bfs set
798: [ ] /syzlist set
799:
800: %% start the loop (the counter rdeg represents the degree of the resolution)
801: 0 1 rdegmax {/rdeg set
802: %% From
803: %% ff=syz
804: %% ... <--- D_X^{r0} <--- D_X^{#ff},
805: %% computes
806: %% gbase syz
807: %% ... <--- D_X^{r0} <--- D_X^{r1} <--- D_X^{#syz}.
808:
809: rdeg 0 eq {
810: 1 /r0 set
811: ff {tt fwm_homogenize expand} map /ff set
812: }{
813: r1 /r0 set
814: o.syz {vector_to_poly} map /ff set
815: } ifelse
816:
817: ff {[[(h). (1).]] replace homogenize} map /ff set
818: %% Is it OK to use reducedBase here?
819: [ff] groebner 0 get {[[(h). (1).]] replace} map /gbase set
820: gbase reducedBase {homogenize} map /gbase set
821: [gbase [(needSyz)]] groebner 2 get /o.syz set
822: gbase length /r1 set
823:
824: %% V-homogenize syz:
825: gbase {bfs coefficients 0 get 0 get} map /msvec set
826: o.syz length /nsyz set
827: o.syz /syz2 set
828: /syz3 [ 0 1 nsyz 1 sub {/i set
829: syz2 i get /syz2i set
830: [ 0 1 r1 1 sub {/j set
831: syz2i j get /syz2ij set
832: msvec j get /msj set
833: syz2ij << bfs msj npower >> mul
834: } for ]
835: } for ] def
836: syz3 /o.syz set
837:
838: %% Comment out % if you want the output to be string lists
839: gbase {[[(h). (1).]] replace} map /gbase set
840: rdeg 0 eq {
841: % gbase toStrings /gbase1 set
842: gbase /gbase1 set
843: }{
844: % gbase r0 n_toVectors {toStrings} map /gbase1 set
845: gbase r0 n_toVectors /gbase1 set
846: } ifelse
847: syzlist [gbase1] join /syzlist set
848: o.syz length 0 eq {
849: syzlist [o.syz] join /syzlist set
850: 1 break
851: }{ } ifelse
852: } for
853:
854: syzlist /arg1 set
855: ] pop
856: popVariables
857: arg1
858: } def
859: %%%%%%%%%%%%%%%%%%%%% Utilities %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
860: %% [u1,...] [v1,...] setminus --> [u1,...] \setminus [v1,...]
861: /setminus {
862: /arg2 set /arg1 set
863: [ /Set1 /Set2 /n2 /i ] pushVariables
864: [
865: arg1 /Set1 set arg2 /Set2 set
866: Set2 length /n2 set
867: 0 1 n2 1 sub {/i set
868: Set1 Set2 i get complement.oaku /Set1 set
869: } for
870: Set1 /arg1 set
871: ] pop
872: popVariables
873: arg1
874: } def
875:
876: %% (list arg1) \setminus {(an element arg2)}
877: /complement.oaku {
878: /arg2 set /arg1 set
879: arg1 { arg2 notidentical } map
880: } def
881:
882: /notidentical {
883: /arg2 set
884: /arg1 set
885: arg1 arg2 eq
886: { } {arg1} ifelse
887: } def
888:
889: %% Convert a polynomial list to a list of vectors of length r
890: %% [(P1).,,,,] r n_toVectors
891: /n_toVectors {
892: /arg2 set /arg1 set
893: [ ] pushVariables
894: [
895: arg1 /Ps set
896: arg2 /r set
897: Ps length /n set
898: Ps toVectors /Vecs set
899: /Vecs1 [ 0 1 n 1 sub {/i set
900: Vecs i get /Veci set
901: Veci length /ri set
902: 1 1 r ri sub {pop Veci [(0).] join /Veci set} for
903: Veci
904: } for ] def
905: Vecs1 /arg1 set
906: ] pop
907: popVariables
908: arg1
909: } def
910:
911: /toStrings {
912: /arg1 set
913: arg1 {(string) dc} map /arg1 set
914: arg1
915: } def
916:
917: %% (x1) --> (Dx1)
918: /xtoDx {
919: /arg1 set
920: @@@.Dsymbol arg1 2 cat_n
921: } def
922:
923: %% [(x1) (x2) (x3)] ---> (x1,x2,x3)
924: /listtostring {
925: /arg1 set
926: [/n /j /ary /str] pushVariables
927: [
928: /ary arg1 def
929: /n ary length def
930: arg1 0 get /str set
931: n 1 gt
932: { str (,) 2 cat_n /str set }{ }
933: ifelse
934: 1 1 n 1 sub {
935: /j set
936: j n 1 sub eq
937: {str << ary j get >> 2 cat_n /str set}
938: {str << ary j get >> (,) 3 cat_n /str set}
939: ifelse
940: } for
941: /arg1 str def
942: ] pop
943: popVariables
944: arg1
945: } def
946:
947: %% FW-homogenization
948: %% Op (string) [(t1) (t2) ...] fw_homogenize ---> h(Op) (string)
949: /fwm_homogenize {
950: /arg2 set %% bft (string list)
951: /arg1 set %% an operator (string)
952: [ /bftt /bft /bfDt /bfht /bfhDt /Op /degs /m /mn /d /i ] pushVariables
953: [
954: /Op arg1 expand def
955: /bftt arg2 def
956: bftt length /d set
957:
958: 0 1 d 1 sub { /i set
959: bftt i get /bft set
960: bft xtoDx /bfDt set
961: BFs (^(-1)*) bft 3 cat_n /bfht set
962: BFs (*) bfDt 3 cat_n /bfhDt set
963: Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
964: /Op set
965: } for
966: Op BFs expand coefficients 0 get
967: {(integer) data_conversion} map /degs set
968: degs << degs length 1 sub >> get /m set
969: 0 m sub /mn set
970: << BFs expand mn powerZ >> Op mul /Op set
971: Op (string) data_conversion /arg1 set
972: ] pop
973: popVariables
974: arg1
975: } def
976:
977: %% var (poly) m (integer) ---> var^m (poly)
978: /powerZ {
979: /arg2 set %% m
980: /arg1 set %% Var
981: [ /m /var /varstr /pow /nvar] pushVariables
982: [
983: arg1 /var set
984: arg2 /m set
985: var (string) data_conversion /varstr set
986: m -1 gt
987: { var m npower /pow set}
988: { varstr (^(-1)) 2 cat_n expand /nvar set
989: nvar << 0 m sub >> npower /pow set
990: }
991: ifelse
992: pow /arg1 set
993: ] pop
994: popVariables
995: arg1
996: } def
997:
998:
999:
1000: [(restall_s)
1001: [(f v s_0 s_1 level restall_s c)
1002: (array f; array v; integer s_0, s_1, level; array c)
1003: (f is a set of generators. v is a set of variables.)
1004: (s_0 is the minimal integral root of the b-function.)
1005: (s_1 is the maximal integral root of the b-function.)
1006: (level is the truncation degree of the resolution.)
1007: (c is the cohomolgy.)
1008: (This command is vector clean for Schreyer 1 and 2.)
1009: ( )
1010: (Global variables: array BFvarlist : list of variables.)
1011: ( array BFparlist : list of parameters.)
1012: ( int BFmessage : verbose or not.)
1013: ( int Schreyer : Schreyer 1 with tower-sugar.sm1 -- V-homog.)
1014: ( Schreyer 2 with tower.sm1 --- H-homog.)
1015: ( Schreyer 0 is a step by step resolution.)
1016: (result global var:array BFresolution : resolution matrices.)
1017: ( )
1018: (cf. /tower.verbose 1 def /tower-sugar.verbose 1 def )
1019: ( /debug.sResolution 1 def)
1020: ( to see steps of resoluitons.)
1021: $ /Schreyer 2 def (tower.sm1) run to try Schreyer 2. Schreyer 2 is default.$
1022: (See bfm --- b-function, restriction.)
1023: (restall1_s is as same as restall_s, except it does not truncate from below.)
1024: (Example 1: /BFvarlist [(x1) (x2)] def /BFparlist [ ] def)
1025: ( [(x1) (Dx2-1)] [(x1)] -1 -1 1 restall_s )
1026: (Example 1a: /BFvarlist [(x1) (x2)] def /BFparlist [ ] def)
1027: ( [(x1) (Dx2-1)] [(x1)] bfm )
1028: (Example 2: /BFvarlist [(x) (y)] def /BFparlist [ ] def)
1029: $ [[(x Dx -1) (0)] [(y Dy -2) (0)] [(1) (1)] ] /ff set $
1030: $ ff [(x) (y)] 0 4 2 restall_s $
1031: ]] putUsages
1032:
1033:
1034: %%%%%%% code for test.
1035:
1036: /test2 {
1037: [(x) ring_of_differential_operators 0] define_ring
1038: [(-x*Dx^2-Dx). [(x) (Dx)] laplace0 (-2*x*Dx-2). [(x) (Dx)] laplace0]
1039: {toString} map /ff1 set
1040: [(-x^2*Dx^3+4*x^2*Dx-3*x*Dx^2+4*x*Dx+4*x-Dx+2). [(x) (Dx)] laplace0 (0).]
1041: {toString} map /ff2 set
1042: (ff1, ff2, BFresolution ) message
1043: /BFvarlist [(x)] def /BFparlist [ ] def
1044: [ff1 ff2] [(x)] 0 4 1 restall_s ::
1045: [ [ff1 ff2] [(x)] [[(x)] [ ]]] restriction
1046: } def
1047:
1048: /test3 {
1049: [(x,y) ring_of_differential_operators 0] define_ring
1050: [(x Dx -1). (0).]
1051: [(1). @@@.esymbol .] mul toString /ff1 set
1052: [(y Dy -2). (0).]
1053: [(1). @@@.esymbol .] mul toString /ff2 set
1054: [(1). (1).]
1055: [(1). @@@.esymbol .] mul toString /ff3 set
1056: (ff1, ff2, ff3, BFresolution ) message
1057: /BFvarlist [(x) (y)] def
1058: /BFparlist [ ] def
1059: [ff1 ff2 ff3] [(x) (y)] 0 2 2 restall_s
1060: } def
1061:
1062: /test {
1063: [(x,y) ring_of_differential_operators 0] define_ring
1064: [(x Dx -1) (0)] /ff1 set
1065: [(y Dy -2) (0)] /ff2 set
1066: [(1) (1)] /ff3 set
1067: (ff1, ff2, ff3, BFresolution ) message
1068: /BFvarlist [(x) (y)] def
1069: /BFparlist [ ] def
1070: [ff1 ff2 ff3] [(x) (y)] 0 4 2 restall_s
1071: } def
1072:
1073:
1074:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to restall_s.sm1.org2 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc