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