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