Annotation of OpenXM/src/kan96xx/Doc/restall.sm1, Revision 1.1.1.1
1.1 maekawa 1: %% changed the following names.
2: %% complement ---> complement.oaku
3: %% syz ==> o.syz
4:
5: %%%%%%%%%%%%%%%%%%%%%%% restall.sm1 (Version 19980415) %%%%%%%%%%%%%%%%%%%%%%%
6: (restall.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: (non-Schreyer Version: 19980415 by T.Oaku) message-quiet
9: (usage: [(P1)...] [(t1)...] bfm --> the b-function) message-quiet
10: ( [(P1)...] [(t1)...] k0 k1 deg restall --> cohomologies of restriction)
11: message-quiet
12: ( [(P1)...] [(t1)...] intbfm --> the b-function for integration) message-quiet
13: ( [(P1)...] [(t1)...] k0 k1 deg intall --> cohomologies of integration)
14: message-quiet
15: % History: Oct.23, Nov.1, Nov.11: bug fix for m2vec, Nov.13: bug fix for psi1
16: % Apr.15,1998 bug fix for truncation from below
17: %%%%%%%%%%%%%%%%%%%%%%%%%%%% Global variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
18: /BFvarlist %% Set all the variables (except s and the parameters) here.
19: [(x) (y) (z)]
20: def
21: /BFparlist %% Set the parameters here if any.
22: [ ]
23: def
24: /BFs (s) def
25: /BFth (s) def
26: /BFu (u) def
27: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28: %% [(P1) ...] [(t1) ...] bfm --> the b-function along t1 = ... = 0.
29: %% the variables and parameters are assumed to be given by the global variables
30: %% BFvarlist and BFparlist
31:
32: /bfm {
33: /arg2 set
34: /arg1 set
35: [ /ff /tt ] pushVariables
36: [
37: arg1 /ff set
38: arg2 /tt set
39: ff tt bfm1 bfm2 {(string) dc} map /arg1 set
40: ] pop
41: popVariables
42: arg1
43: } def
44:
45: /bfm1 {
46: /arg2 set
47: /arg1 set
48: [
49: /ff /tt /d /nff /gg /gg0 /xvarlist /n /i /xtvarlist /xtusvarlist
50: /sxtusvarlist /allvarlist /gg1 /si /gg1 /j /ui /uu /ss /su1
51: /input /ggpsi0 /ggpsi /dxvarlist /sxvarlist /ggpsi1
52: /sxallvarlist /sxpoly_weight /hh /bb /us_weight
53: ] pushVariables
54: [
55: arg1 /ff set
56: arg2 /tt set
57: tt length /d set
58: ff length /nff set
59:
60: ff tt fwd /gg set
61: gg {fw_symbol (string) dc} map /gg0 set
62:
63: BFvarlist tt setminus /xvarlist set
64: xvarlist length /n set
65:
66: /uu %% uu = [u_1,...,u_d]
67: [ 1 1 d {/i set
68: BFu i toString 2 cat_n
69: } for
70: ] def
71: /ss %% ss = [s_1,...,s_d]
72: [ 1 1 d {/i set
73: BFth i toString 2 cat_n
74: } for
75: ] def
76:
77: tt xvarlist join /xtvarlist set
78: uu ss join xtvarlist join /xtusvarlist set
79: [BFth] xtusvarlist join /sxtusvarlist set
80: sxtusvarlist BFparlist join /allvarlist set
81:
82: sxtusvarlist setupDring
83:
84: 0 1 d 1 sub { /i set
85: gg0 {tt i get fw_homogenize} map /gg1 set
86: ss i get expand /si set
87: gg1 {expand} map /gg1 set
88: gg1 {[[BFs expand si]] replace} map /gg1 set
89: gg1 {(string) dc} map /gg1 set
90: } for
91:
92: /us_weight [ [
93: 0 1 d 1 sub { /i set
94: uu i get 1 ss i get 1
95: } for ]
96: [
97: 0 1 d 1 sub { /i set tt i get 1 } for
98: 0 1 n 1 sub { /j set
99: xvarlist j get xtoDx 1
100: xvarlist j get 1
101: } for
102: ] ] def
103:
104: [ allvarlist listtostring ring_of_differential_operators
105: us_weight weight_vector 0 ] define_ring
106:
107: gg1 {expand} map /gg1 set
108:
109: /su1 [ 0 1 d 1 sub { /i set %% [(1-s1*u1).,...]
110: ss i get expand /si set
111: uu i get expand /ui set
112: si ui mul (1). sub
113: } for ] def
114:
115: su1 gg1 join /input set
116: input {[[(h). (1).]] replace homogenize} map /input set
117: [input] groebner 0 get {[[(h). (1).]] replace} map /gg set
118: gg uu eliminatev /gg set
119: gg ss eliminatev /gg set
120: gg reducedBase /gg set
121:
122: gg /ggpsi0 set
123: 0 1 d 1 sub { /i set
124: ggpsi0 {tt i get fw_psi} map /ggpsi0 set
125: ss i get expand /si set
126: ggpsi0 {[[BFth expand si]] replace} map /ggpsi0 set
127: } for
128: ggpsi0 {(string) dc} map /ggpsi set
129:
130: xvarlist {xtoDx} map /dxvarlist set
131: ss xvarlist join /sxvarlist set
132: sxvarlist setupDring
133:
134: ggpsi {expand [[(h). (1).]] replace homogenize} map /ggpsi set
135: [ggpsi] groebner 0 get /ggpsi set
136: ggpsi dxvarlist eliminatev /ggpsi1 set
137: ggpsi1 {(string) dc} map /ggpsi1 set
138:
139: /sxpoly_weight [
140: [ 0 1 n 1 sub {/i set xvarlist i get 1} for ]
141: [ 0 1 d 1 sub {/i set ss i get 1} for ]
142: ] def
143:
144: sxvarlist BFparlist join /sxallvarlist set
145: [ sxallvarlist listtostring ring_of_polynomials
146: sxpoly_weight weight_vector 0 ] define_ring
147: ggpsi1 {expand} map /ggpsi1 set ;
148: [ggpsi1] groebner 0 get {[[(h). (1).]] replace} map /hh set
149: hh xvarlist eliminatev /bb set
150: [bb {(string) dc} map ss] /arg1 set
151: ] pop
152: popVariables
153: arg1
154: } def
155:
156: /bfm2 {
157: /arg1 set
158: [ /ff /ss /d /sspoly_weight /ssallvarlist /si /hh ] pushVariables
159: [
160: arg1 0 get /ff set
161: arg1 1 get /ss set
162: ss length /d set
163:
164: /sspoly_weight [
165: [ 0 1 d 1 sub {/i set ss i get 1} for ]
166: ] def
167:
168: [BFth] ss join BFparlist join /ssallvarlist set
169: [ ssallvarlist listtostring ring_of_polynomials
170: sspoly_weight weight_vector 0 ] define_ring
171: ff {expand homogenize} map /ff set ;
172: BFth expand /si set
173: 1 1 d 1 sub {/i set
174: si << ss i get expand >> sub /si set
175: } for
176: ff {[[ss 0 get expand si]] replace} map /ff set
177: [ff] groebner 0 get {[[(h). (1).]] replace} map /hh set
178: hh ss eliminatev /arg1 set
179: ] pop
180: popVariables
181: arg1
182: } def
183:
184: %% V-Groebner basis by V-filtration (using the variable s)
185: /fwd {
186: /arg2 set %% bftt
187: /arg1 set %% BFequations
188: [ /bfs /bftt /bfh /bf1 /ff /n /i /d /GG /gbase /o.syz
189: /BFDvarlist /BFs_weight ] pushVariables
190: [
191: /ff arg1 def
192: /bftt arg2 def
193: /BFallvarlist
194: [ BFs ] BFvarlist join BFparlist join
195: def
196: BFvarlist length /n set
197: BFvarlist {xtoDx} map /BFDvarlist set
198: /BFs_weight
199: [ [ BFs 1 ]
200: [ 0 1 n 1 sub
201: { /i set BFDvarlist i get 1 }
202: for
203: 0 1 n 1 sub
204: { /i set BFvarlist i get 1 }
205: for ]
206: ] def
207:
208: [ BFallvarlist listtostring ring_of_differential_operators
209: BFs_weight weight_vector
210: 0] define_ring /BFring set
211:
212: /bfh (h) BFring ,, def
213: /bfs BFs BFring ,, def
214: /bf1 (1) BFring ,, def
215: ff { bftt fwm_homogenize } map /ff set
216: ff {expand} map /ff set
217: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
218: [ff] groebner 0 get reducedBase /gbase set
219: gbase /arg1 set
220: ] pop
221: popVariables
222: arg1
223: } def
224:
225: %% The "b-function" w.r.t. (Dt1),...
226: %% (for integration w.r.t. (t1),...
227: %% [(P1)...] [(t1)...] intbfm
228:
229: /intbfm {
230: /arg2 set /arg1 set
231: [ ] pushVariables
232: [
233: arg1 /ff set
234: arg2 /tt set
235: BFvarlist setupDring
236: ff {tt fourier} map /gg set
237: gg tt bfm /arg1 set
238: ] pop
239: popVariables
240: arg1
241: } def
242:
243: /intall {
244: /arg5 set %% degmax
245: /arg4 set %% k1
246: /arg3 set %% k0
247: /arg2 set %% [(t1) ... (td)]
248: /arg1 set %% BFequations
249: [ /ff /bftt /k0 /k1 /degmax /ffdx ] pushVariables
250: [
251: /ff arg1 def /bftt arg2 def /k0 arg3 def /k1 arg4 def
252: /degmax arg5 def
253: BFvarlist setupDring
254: ff {bftt fourier} map /ffdx set
255: ffdx bftt k0 k1 degmax restall /arg1 set
256: ] pop
257: popVariables
258: arg1
259: } def
260:
261: /intall1 {
262: /arg5 set %% degmax
263: /arg4 set %% k1
264: /arg2 set %% [(t1) ... (td)]
265: /arg1 set %% BFequations
266: [ /ff /bftt /k0 /k1 /degmax /ffdx ] pushVariables
267: [
268: /ff arg1 def /bftt arg2 def /k1 arg4 def
269: /degmax arg5 def
270: BFvarlist setupDring
271: ff {bftt fourier} map /ffdx set
272: ffdx bftt k1 degmax restall1 /arg1 set
273: ] pop
274: popVariables
275: arg1
276: } def
277:
278: %% (P) [(t_1),...,(t_d)] fourier
279: /fourier {
280: /arg2 set /arg1 set
281: [ /P /tt /d /i] pushVariables
282: [
283: arg1 /P set
284: arg2 /tt set
285: tt length /d set
286: 0 1 d 1 sub {/i set
287: P << tt i get >> fourier1 /P set
288: } for
289: P /arg1 set
290: ] pop
291: popVariables
292: arg1
293: } def
294:
295: %% (P) (t) fourier : t --> -Dt, Dt --> t
296: /fourier1 {
297: /arg2 set /arg1 set
298: [/P /bft /bfDt /P /bftv /bfDtv /Pcoefs /degs /coefs /m /PP /i /ki /ci
299: ] pushVariables
300: [
301: arg1 /P set
302: arg2 /bft set
303: bft xtoDx /bfDt set
304: P expand /P set
305: bft expand /bftv set
306: bfDt expand /bfDtv set
307: P bfDtv coefficients /Pcoefs set
308: Pcoefs 0 get /degs set
309: Pcoefs 1 get /coefs set
310: coefs length /m set
311: (0). /PP set
312: 0 1 m 1 sub { /i set
313: degs i get /ki set
314: coefs i get /ci set
315: ci [[ bftv << (0). bfDtv sub >> ]] replace /ci set
316: ci << bftv ki power >> mul /ci set
317: PP ci add /PP set
318: } for
319: PP [[(h). (1).]] replace (string) dc /arg1 set
320: ] pop
321: popVariables
322: arg1
323: } def
324:
325: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
326: %% The cohomology groups of the restriction
327: %% [(P1)...] [(t1)...] k0 k1 degmax restall
328: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
329:
330: /restall {
331: /arg5 set %% degmax
332: /arg4 set %% k1
333: /arg3 set %% k0
334: /arg2 set %% [(t1) ... (td)]
335: /arg1 set %% BFequations
336: [
337: /ff /bftt /k0 /k1 /degmax /syzlist /mveclist /cohomlist
338: /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
339: /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
340: /psi1 /psi1ker /psi2image
341: /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
342: /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
343: ] pushVariables
344: [
345: /ff arg1 def /bftt arg2 def /k0 arg3 def /k1 arg4 def
346: /degmax arg5 def
347: bftt length /d set
348: degmax 0 gt {
349: (Computing a free resolution ... ) message
350: ff bftt degmax syzygyV /GG set
351: (A free resolution obtained.) message
352: }{
353: [[ff bftt fwd {[[BFs expand (1).]] replace (string) dc} map ] [ [ 0 ] ]]
354: /GG set
355: } ifelse
356: GG 0 get /syzlist set
357: GG 1 get /mveclist set
358:
359: [ ] /cohomlist set
360:
361: 0 1 degmax {/ideg set
362:
363: ideg 0 eq {
364: [ (0) ] /gbase set
365: [ 0 ] /m0vec set
366: 1 /r0 set
367: }{
368: syzlist << ideg 1 sub >> get /gbase set
369: m1vec /m0vec set
370: r1 /r0 set
371: } ifelse
372: syzlist ideg get /o.syz set
373: mveclist ideg get /m1vec set
374:
375: %% o.syz gbase
376: %% D^{r2} --> D^{r1} --> D^{r0}
377: %% with weight vectors: m2vec m1vec m0vec
378: %% which will induce a complex
379: %% psi2 psi1
380: %% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
381:
382: gbase length /r1 set
383: o.syz length /r2 set
384:
385: ideg 0 eq {
386: /syz1 [ 0 1 r2 1 sub {/i set
387: [ o.syz i get ]
388: } for ] def
389: syz1 /o.syz set
390: }{ } ifelse
391:
392: %% Computing the weight vector m2vec from m1vec and syz
393: ideg degmax eq {
394: /m2vec [
395: 0 1 r2 1 sub {/i set
396: o.syz i get /syzi set
397: 0 /nonzero set
398: 0 1 r1 1 sub {/j set
399: syzi j get expand /syzij set
400: syzij (0). eq { }{
401: syzij bftt fwh_order m1vec j get add /maxtmp set
402: nonzero 0 eq { maxtmp /max0 set }{
403: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
404: } ifelse
405: 1 /nonzero set
406: } ifelse
407: } for
408: max0 } for ] def
409: }{
410: mveclist << ideg 1 add >> get /m2vec set
411: } ifelse
412:
413: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
414: BFu /estr set
415: /ee
416: [ 1 1 d {/i set estr i toString 2 cat_n} for ]
417: def
418: [@@@.esymbol] ee join /eee set
419:
420: %% Setting up a ring that represents D_{Y->X}^{r1}
421: eee length /neee set
422: /eeemvec [ 1 1 neee {pop 1} for ] def
423: eee [ ] BFvarlist eeemvec setupDringVshift
424: bftt {xtoDx expand} map /bfDtt set
425: [ ] /psi1 set
426: [ ] /psi1index set
427: [ ] /zerolist set
428:
429: %% converting gbase to a list of polynomials
430: %% Be careful to the current ring!
431: ideg 2 lt {
432: gbase {expand} map /gbase1 set
433: }{
434: /gbase1
435: [ 0 1 r1 1 sub {/i set
436: gbase i get {expand} map vector_to_poly
437: } for ] def
438: } ifelse
439: gbase1 /gbase set
440:
441: %(ideg =) messagen ideg ::
442: %(Computing psi1) message
443: %% psi1
444: %% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
445: %% with weight k0 - m1vec <= k <= k1 - m1vec
446: 0 1 r1 1 sub {/i set
447: m1vec i get /m1i set
448: ee {expand} map k0 m1i sub k1 m1i sub monomials /emonoi set
449: bfDtt k0 m1i sub k1 m1i sub monomials /bfDttmonoi set
450: emonoi length /nmono set
451: 0 1 nmono 1 sub {/j set
452: @@@.esymbol expand i npower /eei set
453: emonoi j get eei mul /eei set
454: gbase i get /dtp set
455: bfDttmonoi j get dtp mul /dtp set
456: 0 1 d 1 sub {/k set
457: dtp [[bftt k get expand (0).]] replace /dtp set
458: dtp [[bfDtt k get ee k get expand]] replace /dtp set
459: } for
460: dtp [[(h). (1).]] replace /dtp set
461: dtp << ee {expand} map >> m0vec k0 Vtruncate_below /dtp set
462: dtp (0). eq {
463: zerolist [eei] join /zerolist set
464: }{
465: psi1index [eei] join /psi1index set
466: psi1 [dtp] join /psi1 set
467: } ifelse
468: } for
469: } for
470:
471: %(ideg =) messagen ideg ::
472: %(psi1 obtained.) message
473: %(Computing psi1ker) message
474:
475: %% Computing psi1ker := Ker psi1 :
476: psi1 length 0 eq {
477: [ ] /psi1ker set
478: }{
479: psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
480: [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
481: psi1kervec length /pn set
482: psi1index length /pn0 set
483: [ ] /psi1ker set
484: 0 1 pn 1 sub {/i set
485: psi1kervec i get /psi1i set
486: (0). /psi1keri set
487: 0 1 pn0 1 sub {/j set
488: psi1index j get psi1i j get mul psi1keri add /psi1keri set
489: } for
490: psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
491: } for
492: } ifelse
493: zerolist psi1ker join /psi1ker set
494: % Is it all right to use reducedBase here?
495: % psi1ker length 0 eq { }{
496: % psi1ker reducedBase /psi1ker set
497: % } ifelse
498: %(ideg =) messagen ideg ::
499: %(psi1ker obtained.) message
500: %(Computing psi2image ...) message
501:
502: %% psi2
503: %% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
504: %% with weight k0 - m2vec <= k <= k1 - m2vec
505: /psi2image [
506: 0 1 r2 1 sub {/i set
507: o.syz i get {expand} map vector_to_poly /syzi set
508: m2vec i get /m2i set
509: bfDtt k0 m2i sub k1 m2i sub monomials /bfDttmonoi set
510: bfDttmonoi length /nmono set
511: 0 1 nmono 1 sub {/j set
512: bfDttmonoi j get syzi mul /syzij set
513: 0 1 d 1 sub {/k set
514: syzij [[bftt k get expand (0).]] replace /syzij set
515: syzij [[bfDtt k get ee k get expand]] replace /syzij set
516: } for
517: syzij [[(h). (1).]] replace /syzij set
518: syzij << ee {expand} map >> m1vec k0 Vtruncate_below /syzij set
519: syzij (0). eq { }{syzij} ifelse
520: } for
521: } for
522: ] def
523:
524: %(psi2image obtained.) message
525: %(ideg = ) messagen ideg ::
526: %(psi1ker = ) message psi1ker ::
527: %(psi2image =) message psi2image ::
528:
529: %% Computes the quotient module psi1ker/psi2image
530: psi1ker length /nker set
531: nker 0 eq {
532: [0 [ ]] /cohom set
533: }{
534: psi2image length /nim set
535: psi1ker psi2image join /psiall set
536: psiall {homogenize} map /psiall set
537: [psiall [(needSyz)]] groebner 2 get /psisyz set
538: psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
539: cohom {remove0} map /cohom set
540: cohom length 0 eq {
541: [nker [ ]] /cohom set
542: }{
543: cohom {homogenize} map /cohom set
544: [cohom] groebner 0 get reducedBase /cohom set
545: cohom {[[(h). (1).]] replace} map /cohom set
546: [nker cohom] trimModule /cohom set
547: } ifelse
548: } ifelse
549: cohomlist [cohom] join /cohomlist set
550: 0 ideg sub print (-th cohomology: ) messagen
551: cohom ::
552: } for
553:
554: cohomlist /arg1 set
555: ] pop
556: popVariables
557: arg1
558: } def
559:
560: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
561: %% The cohomology groups of the restriction without truncation from below
562: %% [(P1)...] [(t1)...] k1 degmax restall
563: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
564:
565: /restall1 {
566: /arg5 set %% degmax
567: /arg4 set %% k1
568: /arg2 set %% [(t1) ... (td)]
569: /arg1 set %% BFequations
570: [
571: /ff /bftt /k1 /degmax /syzlist /mveclist /cohomlist
572: /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
573: /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
574: /psi1 /psi1ker /psi2image
575: /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
576: /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
577: ] pushVariables
578: [
579: /ff arg1 def /bftt arg2 def /k1 arg4 def /degmax arg5 def
580: bftt length /d set
581: degmax 0 gt {
582: (Computing a free resolution ... ) message
583: ff bftt degmax syzygyV /GG set
584: (A free resolution obtained.) message
585: }{
586: [[ff bftt fwd {[[BFs expand (1).]] replace (string) dc} map ] [ [ 0 ] ]]
587: /GG set
588: } ifelse
589: GG 0 get /syzlist set
590: GG 1 get /mveclist set
591:
592: [ ] /cohomlist set
593:
594: 0 1 degmax {/ideg set
595:
596: ideg 0 eq {
597: [ (0) ] /gbase set
598: [ 0 ] /m0vec set
599: 1 /r0 set
600: }{
601: syzlist << ideg 1 sub >> get /gbase set
602: m1vec /m0vec set
603: r1 /r0 set
604: } ifelse
605: syzlist ideg get /o.syz set
606: mveclist ideg get /m1vec set
607:
608: %% o.syz gbase
609: %% D^{r2} --> D^{r1} --> D^{r0}
610: %% with weight vectors: m2vec m1vec m0vec
611: %% which will induce a complex
612: %% psi2 psi1
613: %% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
614:
615: gbase length /r1 set
616: o.syz length /r2 set
617:
618: ideg 0 eq {
619: /syz1 [ 0 1 r2 1 sub {/i set
620: [ o.syz i get ]
621: } for ] def
622: syz1 /o.syz set
623: }{ } ifelse
624:
625: %% Computing the weight vector m2vec from m1vec and syz
626: ideg degmax eq {
627: /m2vec [
628: 0 1 r2 1 sub {/i set
629: o.syz i get /syzi set
630: 0 /nonzero set
631: 0 1 r1 1 sub {/j set
632: syzi j get expand /syzij set
633: syzij (0). eq { }{
634: syzij bftt fwh_order m1vec j get add /maxtmp set
635: nonzero 0 eq { maxtmp /max0 set }{
636: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
637: } ifelse
638: 1 /nonzero set
639: } ifelse
640: } for
641: max0 } for ] def
642: }{
643: mveclist << ideg 1 add >> get /m2vec set
644: } ifelse
645:
646: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
647: BFu /estr set
648: /ee
649: [ 1 1 d {/i set estr i toString 2 cat_n} for ]
650: def
651: [@@@.esymbol] ee join /eee set
652:
653: %% Setting up a ring that represents D_{Y->X}^{r1}
654: eee length /neee set
655: /eeemvec [ 1 1 neee {pop 1} for ] def
656: eee [ ] BFvarlist eeemvec setupDringVshift
657: bftt {xtoDx expand} map /bfDtt set
658: [ ] /psi1 set
659: [ ] /psi1index set
660: [ ] /zerolist set
661:
662: %% converting gbase to a list of polynomials
663: %% Be careful to the current ring!
664: ideg 2 lt {
665: gbase {expand} map /gbase1 set
666: }{
667: /gbase1
668: [ 0 1 r1 1 sub {/i set
669: gbase i get {expand} map vector_to_poly
670: } for ] def
671: } ifelse
672: gbase1 /gbase set
673:
674: %(ideg =) messagen ideg ::
675: %(Computing psi1) message
676: %% psi1
677: %% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
678: %% with weight k <= k1 - m1vec
679: 0 1 r1 1 sub {/i set
680: m1vec i get /m1i set
681: ee {expand} map 0 k1 m1i sub monomials /emonoi set
682: bfDtt 0 k1 m1i sub monomials /bfDttmonoi set
683: emonoi length /nmono set
684: 0 1 nmono 1 sub {/j set
685: @@@.esymbol expand i npower /eei set
686: emonoi j get eei mul /eei set
687: gbase i get /dtp set
688: bfDttmonoi j get dtp mul /dtp set
689: 0 1 d 1 sub {/k set
690: dtp [[bftt k get expand (0).]] replace /dtp set
691: dtp [[bfDtt k get ee k get expand]] replace /dtp set
692: } for
693: dtp [[(h). (1).]] replace /dtp set
694: dtp (0). eq {
695: zerolist [eei] join /zerolist set
696: }{
697: psi1index [eei] join /psi1index set
698: psi1 [dtp] join /psi1 set
699: } ifelse
700: } for
701: } for
702:
703: %(ideg =) messagen ideg ::
704: %(psi1 obtained.) message
705: %(Computing psi1ker) message
706:
707: %% Computing psi1ker := Ker psi1 :
708: psi1 length 0 eq {
709: [ ] /psi1ker set
710: }{
711: psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
712: [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
713: psi1kervec length /pn set
714: psi1index length /pn0 set
715: [ ] /psi1ker set
716: 0 1 pn 1 sub {/i set
717: psi1kervec i get /psi1i set
718: (0). /psi1keri set
719: 0 1 pn0 1 sub {/j set
720: psi1index j get psi1i j get mul psi1keri add /psi1keri set
721: } for
722: psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
723: } for
724: } ifelse
725: zerolist psi1ker join /psi1ker set
726: % Is it all right to use reducedBase here?
727: % psi1ker length 0 eq { }{
728: % psi1ker reducedBase /psi1ker set
729: % } ifelse
730: %(ideg =) messagen ideg ::
731: %(psi1ker obtained.) message
732: %(Computing psi2image ...) message
733:
734: %% psi2
735: %% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
736: %% with weight m2vec <= k <= k1 - m2vec
737: /psi2image [
738: 0 1 r2 1 sub {/i set
739: o.syz i get {expand} map vector_to_poly /syzi set
740: m2vec i get /m2i set
741: bfDtt 0 k1 m2i sub monomials /bfDttmonoi set
742: bfDttmonoi length /nmono set
743: 0 1 nmono 1 sub {/j set
744: bfDttmonoi j get syzi mul /syzij set
745: 0 1 d 1 sub {/k set
746: syzij [[bftt k get expand (0).]] replace /syzij set
747: syzij [[bfDtt k get ee k get expand]] replace /syzij set
748: } for
749: syzij [[(h). (1).]] replace /syzij set
750: syzij (0). eq { }{syzij} ifelse
751: } for
752: } for
753: ] def
754:
755: %(psi2image obtained.) message
756: %(ideg = ) messagen ideg ::
757: %(psi1ker = ) message psi1ker ::
758: %(psi2image =) message psi2image ::
759:
760: %% Computes the quotient module psi1ker/psi2image
761: psi1ker length /nker set
762: nker 0 eq {
763: [0 [ ]] /cohom set
764: }{
765: psi2image length /nim set
766: psi1ker psi2image join /psiall set
767: psiall {homogenize} map /psiall set
768: [psiall [(needSyz)]] groebner 2 get /psisyz set
769: psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
770: cohom {remove0} map /cohom set
771: cohom length 0 eq {
772: [nker [ ]] /cohom set
773: }{
774: cohom {homogenize} map /cohom set
775: [cohom] groebner 0 get reducedBase /cohom set
776: cohom {[[(h). (1).]] replace} map /cohom set
777: [nker cohom] trimModule /cohom set
778: } ifelse
779: } ifelse
780: cohomlist [cohom] join /cohomlist set
781: 0 ideg sub print (-th cohomology: ) messagen
782: cohom ::
783: } for
784:
785: cohomlist /arg1 set
786: ] pop
787: popVariables
788: arg1
789: } def
790:
791:
792: % Reduce the module representation A^r/[P_1,...,P_m]
793: % by trimming unnecessary higher degree terms
794: % [r [P1,...,p_m]] reduceModule --> [r1, [Q_1,...,Q_m1]]
795: % The current ring must have @@@.esymbol as the highest degree variable.
796: /trimModule {
797: /arg1 set
798: [ /r /ff /ffins /nff /i /ei /j /fj /fjin /qij /fjdeg ] pushVariables
799: [
800: arg1 0 get /r set
801: arg1 1 get /ff set
802: ff {homogenize} map /ff set
803: [ff] groebner 0 get reducedBase {[[(h). (1).]] replace} map /ff set
804: ff {init [[(h). (1).]] replace} map /ffins set
805: ff length /nff set
806:
807: r 1 sub -1 0 {/i set
808: @@@.esymbol . i npower /ei set
809: 0 1 nff 1 sub {/j set
810: 0 /eifound set
811: ff j get /fj set
812: ffins j get /fjin set
813: ei [fjin] reduction 0 get /qij set
814: qij (0). eq {
815: 1 /eifound set
816: 1 break
817: }{ } ifelse
818: } for
819: eifound 0 eq break
820: } for
821: << eifound 1 eq >> << i 0 eq >> and {
822: 0 /r set
823: }{
824: i 1 add /r set
825: } ifelse
826: /gg [ 0 1 nff 1 sub {/j set
827: ff j get /fj set
828: fj @@@.esymbol . coefficients 0 get 0 get (integer) dc /fjdeg set
829: fjdeg r lt {fj}{ } ifelse
830: } for ] def
831: [r gg] /arg1 set
832: ] pop
833: popVariables
834: arg1
835: } def
836:
837: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
838: % syzygyV.sm1 ... free resolution adapted to the V-filtration
839: % w.r.t. tt = (t_1,...,t_d) using h-homogenization.
840: % usage: Equations tt deg syzygyV
841: % Oct. 21, 1997 --- by T.Oaku
842: % Version 19971021
843: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
844: %% Computing a free resolution compatible with the V-filtration
845: %% w.r.t. tt
846: /syzygyV {
847: /arg3 set %% rdegmax
848: /arg2 set %% tt
849: /arg1 set %% ff
850: [
851: /ff /tt /rdegmax /ttxx /aa /d /i /syzlist /rdeg
852: /nff /mvec /estr /ee /edeg /dffi /r0 /syzpoly
853: /syzi /syzij /syzpolyi /j
854: /gbase /o.syz /syzlist /mvecist
855: /r1 /m1vec /gbi /nonzero /gbijc /gbijd /gbij /maxtmp /max0 /gbase1
856: /m0vec
857: ] pushVariables
858: [
859: arg1 /ff set
860: arg2 /tt set
861: arg3 /rdegmax set
862:
863: BFvarlist /ttxx set
864: BFparlist /aa set
865: tt length /d set
866:
867: ttxx tt setminus /xx set
868:
869: [ ] /syzlist set
870: [ ] /mveclist set
871:
872: %% start the loop (the counter rdeg represents the degree of the resolution)
873: 0 1 rdegmax {/rdeg set
874: ff length /nff set
875:
876: %% r is the number of graduation variables;
877: %% ff is a list of r0-vectors;
878: %% r = r0 from the 2nd step (i.e. for rdeg >= 1);
879: %% ee = [(u_1),...,(u_r)] or [@@@.esymbol] (in the 1st step).
880: %% From
881: %% ff
882: %% ... <--- D_X^{r0} <--- D_X^{nff},
883: %% computes
884: %% gbase syz
885: %% ... <--- D_X^{r0} <--- D_X^{r1} <--- D_X^{r2}.
886: %% m0vec m1vec m2vec
887:
888: rdeg 0 eq {
889: 1 /r set
890: [@@@.esymbol] /ee set
891: [ 0 ] /mvec set
892: [ 0 ] /mvec0 set
893: }{
894: r1 /r set
895: r1 /r0 set
896: m1vec /mvec set
897: BFu /estr set
898: /ee
899: [ 1 1 r {/i set
900: estr i toString 2 cat_n} for ]
901: def
902: } ifelse
903:
904: %% (Set up a ring with mvec = ) messagen mvec ::
905: ee tt xx mvec setupDringVshift
906:
907: rdeg 0 eq {
908: 0 /edeg set
909: 0 1 nff 1 sub {/i set
910: ff i get expand /ffi set
911: ffi @@@.esymbol . coefficients 0 get 0 get (integer) dc /dffi set
912: dffi edeg gt { dffi /edeg set}{ } ifelse
913: } for
914: edeg 1 add /r0 set %% the input ff is a list of r0-vectors
915: /m0vec [ 1 1 r0 {pop 0} for ] def
916: }{
917: o.syz length /nff set
918: /syzpoly [ 0 1 nff 1 sub {/i set
919: o.syz i get /syzi set
920: (0). /syzpolyi set
921: 0 1 r1 1 sub {/j set
922: syzi j get (string) dc expand /syzij set
923: syzij << ee j get expand >> mul /syzij set
924: syzpolyi syzij add /syzpolyi set
925: } for
926: syzpolyi
927: } for ] def
928: syzpoly {(string) dc} map /ff set
929: } ifelse
930:
931: mveclist [m0vec] join /mveclist set
932:
933: ff {expand [[(h). (1).]] replace homogenize} map /ff set
934: [ff] groebner 0 get reducedBase /gbase set
935: [gbase [(needSyz)]] groebner 2 get /o.syz set
936:
937: gbase length /r1 set
938: o.syz length /nff set
939:
940: 0 rdeg eq {
941: gbase {tt fwh_order} map /m1vec set
942: }{
943: /m1vec [
944: 0 1 r1 1 sub {/i set
945: gbase i get /gbi set
946: 0 /nonzero set
947: 0 1 r0 1 sub {/j set
948: gbi << ee j get expand >> coefficients /gbijc set
949: gbijc 0 get 0 get (integer) dc /gbijd set
950: gbijd 0 eq { }{
951: gbijc 1 get 0 get /gbij set
952: gbij tt fwh_order m0vec j get add /maxtmp set
953: nonzero 0 eq { maxtmp /max0 set }{
954: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
955: } ifelse
956: 1 /nonzero set
957: } ifelse
958: } for
959: max0 } for ] def
960: } ifelse
961:
962: rdeg 0 eq {
963: gbase {[[(h). (1).]] replace (string) dc} map /gbase1 set
964: }{
965: /gbase1 [ 0 1 r1 1 sub {/i set
966: gbase i get /gbi set
967: [ 0 1 r0 1 sub {/j set
968: gbi << ee j get expand >> coefficients /gbijc set
969: gbijc 0 get 0 get (integer) dc /gbijd set
970: gbijd 0 eq { (0) }{
971: gbijc 1 get 0 get [[(h). (1).]] replace (string) dc
972: } ifelse
973: } for ]
974: } for ] def
975: } ifelse
976:
977: syzlist [gbase1] join /syzlist set
978: m1vec /m0vec set
979:
980: o.syz length 0 eq {
981: syzlist [o.syz] join /syzlist set
982: mveclist [m1vec] join /mveclist set
983: 1 break
984: }{ } ifelse
985: } for
986: [syzlist mveclist] /arg1 set
987: ] pop
988: popVariables
989: arg1
990: } def
991: %%%%%%%%%%%%%%%%%%%%%%%%% Libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
992: %% set up a ring for the shifted V-weight given by mvec:
993: %% ee tt xx mvec setupDringVshift
994: %% ee = [e_1,...,e_r], tt = [t_1,...,t_d], xx = [x_1,...,x_n]
995: %% BFparlist = [a_1,...,a_m] (global variable)
996:
997: /setupDringVshift {
998: /arg4 set /arg3 set /arg2 set /arg1 set
999: [
1000: /ee /xx /tt /aa /mvec /allvarlist /allDvarlist /r /n /m /d /i /j /k
1001: % /Dee /Dxx /Dtt /Daa /dnm /rdnm /mat1 /mat2 /mat3 /mat4
1002: ] pushVariables
1003: [
1004: arg1 /ee set
1005: arg2 /tt set
1006: arg3 /xx set
1007: arg4 /mvec set
1008: BFparlist /aa set
1009:
1010: /allvarlist
1011: ee tt join xx join aa join [(H)] join
1012: def
1013:
1014: ee length /r set
1015: tt length /d set
1016: xx length /n set
1017: aa length /m set
1018:
1019: d n add m add /dnm set
1020: r dnm add /rdnm set
1021:
1022: ee {xtoDx} map /Dee set
1023: tt {xtoDx} map /Dtt set
1024: xx {xtoDx} map /Dxx set
1025: aa {xtoDx} map /Daa set
1026:
1027: /allDvarlist
1028: Dee Dtt join Dxx join Daa join [(h)] join
1029: def
1030:
1031: allvarlist reverse /mat1 set allDvarlist reverse /mat2 set
1032: [0 1 1 1 rdnm 1 add 1 1 1 dnm 1 add] /mat3 set
1033: [
1034: [ 0 1 r 1 sub {/i set mvec i get} for %%[(e_1) mvec_1...(e_r) mvec_r
1035: 1 1 d {pop -1} for %% (t_1) -1 ... (t_d) -1
1036: 1 1 n {pop 0 } for %% (x_1) 0 ... (x_n) 0
1037: 1 1 m {pop 0 } for %% (a_1) 0 ... (a_m) 0
1038: 0 %% (H) 0
1039: 1 1 r {pop 0 } for %% (E_1) 0 ... (E_d) 0
1040: 1 1 d {pop 1 } for %% (Dt_1) 1 ... (Dt_d) 1
1041: 1 1 n {pop 0 } for %% (Dx_1) 0 ... (Dx_n) 0
1042: 1 1 m {pop 0 } for %% (Da_1) 0 ... (Da_m) 0
1043: 0 %% (h) 0 ]
1044: ]
1045: [ 1 1 r {pop 1 } for %%[(e_1) 1 ... (e_r) 1
1046: 1 1 d {pop 1 } for %% (t_1) 1 ... (t_d) 1
1047: 1 1 n {pop 1 } for %% (x_1) 1 ... (x_n) 1
1048: 1 1 m {pop 0 } for %% (a_1) 0 ... (a_m) 0
1049: 0 %% (H) 0
1050: 1 1 r {pop 0 } for %% (E_1) 0 ... (E_d) 0
1051: 1 1 d {pop 1 } for %% (Dt_1) 1 ... (Dt_d) 1
1052: 1 1 n {pop 1 } for %% (Dx_1) 1 ... (Dx_n) 1
1053: 1 1 m {pop 0 } for %% (Da_1) 0 ... (Da_m) 0
1054: 0 %% (h) 0 ]
1055: ]
1056: [ 1 1 r {pop 0 } for %%[(e_1) 0 ... (e_r) 0
1057: 1 1 d {pop 0 } for %% (t_1) 0 ... (t_d) 0
1058: 1 1 n {pop 0 } for %% (x_1) 0 ... (x_n) 0
1059: 1 1 m {pop 1 } for %% (a_1) 1 ... (a_m) 1
1060: 0 %% (H) 0
1061: 1 1 r {pop 0 } for %% (E_1) 0 ... (E_d) 0
1062: 1 1 d {pop 0 } for %% (Dt_1) 0 ... (Dt_d) 0
1063: 1 1 n {pop 0 } for %% (Dx_1) 0 ... (Dx_n) 0
1064: 1 1 m {pop 0 } for %% (Da_1) 0 ... (Da_m) 0
1065: 0 %% (h) 0 ]
1066: ]
1067: rdnm 1 sub -1 0 {/i set
1068: [
1069: 0 1 rdnm {pop 0} for
1070: 0 1 rdnm 1 sub {/j set
1071: i j eq { -1 }{ 0 } ifelse
1072: } for
1073: 0
1074: ]
1075: } for
1076: rdnm 1 sub -1 0 {/i set
1077: [
1078: 0 1 rdnm 1 sub {/j set
1079: i j eq { -1 }{ 0 } ifelse
1080: } for
1081: 0
1082: 0 1 rdnm {pop 0} for
1083: ]
1084: } for
1085: [ 0 1 rdnm {pop 0} for
1086: 0 1 rdnm 1 sub {pop 0} for
1087: 1
1088: ]
1089: ] /mat4 set
1090: mat1 mat2 mat3 mat4 [(mpMult) (diff)] set_up_ring@
1091: (red@) (module1) switch_function
1092: (grade) (module1) switch_function
1093: ] pop
1094: popVariables
1095: } def
1096:
1097: /remove0 {
1098: /arg1 set
1099: arg1 (0). eq
1100: { } {arg1} ifelse
1101: } def
1102:
1103: %% return a list of monomials of degree m with m0 <= m <= m1
1104: %% usage: [(t1) ... (td)] m monomials
1105: /monomials {
1106: /arg3 set %% m1 (integer)
1107: /arg2 set %% m0 (integer)
1108: /arg1 set %% [(t1)., ... ,(td).] (polynonmial list)
1109: [/bftt /m /m0 /m1 /d /i /mns0 /j /n /Mn /k ] pushVariables
1110: [
1111: arg1 /bftt set
1112: arg2 /m0 set
1113: arg3 /m1 set
1114:
1115: bftt length /d set
1116: d 0 eq { /mns [ ] def}{
1117: d 1 eq {
1118: /mns [ m0 1 m1 { /i set
1119: i -1 gt {bftt 0 get i npower}{ } ifelse
1120: } for ] def
1121: }
1122: {
1123: /mns [ 0 1 m1 { /i set
1124: bftt rest i i monomials /mns0 set
1125: mns0 length /n set
1126: 0 1 n 1 sub { /j set
1127: mns0 j get /Mn set
1128: m0 i sub /m set
1129: m 0 lt { 0 /m set }{ } ifelse
1130: m 1 m1 i sub { /k set
1131: << bftt 0 get k npower >> Mn mul
1132: } for
1133: } for
1134: } for ] def
1135: } ifelse } ifelse
1136: mns /arg1 set
1137: ] pop
1138: popVariables
1139: arg1
1140: } def
1141:
1142: %% projection to the first m componets of a vector
1143: %% [P1,...,Pm,...] m proj ---> [P1,...,Pm]
1144: /proj {
1145: /arg2 set
1146: /arg1 set
1147: [/n /m /vec /projvec] pushVariables
1148: [
1149: arg2 /m set
1150: arg1 /vec set
1151: vec length /n set
1152:
1153: /projvec [
1154: vec aload
1155: 0 1 << n m sub >> { pop pop } for
1156: ] def
1157:
1158: projvec /arg1 set
1159: ] pop
1160: popVariables
1161: arg1
1162: } def
1163:
1164: /notidentical {
1165: /arg2 set
1166: /arg1 set
1167: arg1 arg2 eq
1168: { } {arg1} ifelse
1169: } def
1170:
1171: %% [u1,...] [v1,...] setminus --> [u1,...] \setminus [v1,...]
1172: /setminus {
1173: /arg2 set /arg1 set
1174: [ /Set1 /Set2 /n2 /i ] pushVariables
1175: [
1176: arg1 /Set1 set arg2 /Set2 set
1177: Set2 length /n2 set
1178: 0 1 n2 1 sub {/i set
1179: Set1 Set2 i get complement.oaku /Set1 set
1180: } for
1181: Set1 /arg1 set
1182: ] pop
1183: popVariables
1184: arg1
1185: } def
1186:
1187: %% (list arg1) \setminus {(an element arg2)}
1188: /complement.oaku {
1189: /arg2 set /arg1 set
1190: arg1 { arg2 notidentical } map
1191: } def
1192:
1193: %% convert a polynomial to one in the current ring
1194: /reexpand {
1195: /arg1 set
1196: arg1 {(string) dc expand} map
1197: } def
1198:
1199: %% Op (poly) [(t1) (t2) ...] fwh_order ---> FW-ord(Op) (integer)
1200: %% The current ring must be adapted to the V-filtration!
1201: /fwh_order {
1202: /arg2 set %% bftt (string list)
1203: /arg1 set %% Op (poly)
1204: [/Op /bftt /fws /m /fwsDt /k /d /i /tt /dtt] pushVariables
1205: [
1206: arg1 /Op set
1207: arg2 /bftt set
1208: Op init /fws set
1209: bftt length /d set
1210: 0 /k set
1211: 0 /m set
1212: 0 1 d 1 sub { /i set
1213: /tt bftt i get expand def
1214: /dtt bftt i get xtoDx expand def
1215: fws dtt coefficients 0 get 0 get (integer) dc m add /m set
1216: fws tt coefficients 0 get 0 get (integer) dc k add /k set
1217: } for
1218: m k sub (integer) data_conversion /arg1 set
1219: ] pop
1220: popVariables
1221: arg1
1222: } def
1223:
1224: %% FW-homogenization
1225: %% Op (string) [(t1) (t2) ...] fw_homogenize ---> h(Op) (string)
1226: /fwm_homogenize {
1227: /arg2 set %% bft (string list)
1228: /arg1 set %% an operator (string)
1229: [ /bftt /bft /bfDt /bfht /bfhDt /Op /degs /m /mn /d /i ] pushVariables
1230: [
1231: /Op arg1 expand def
1232: /bftt arg2 def
1233: bftt length /d set
1234:
1235: 0 1 d 1 sub { /i set
1236: bftt i get /bft set
1237: bft xtoDx /bfDt set
1238: BFs (^(-1)*) bft 3 cat_n /bfht set
1239: BFs (*) bfDt 3 cat_n /bfhDt set
1240: Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
1241: /Op set
1242: } for
1243: Op BFs expand coefficients 0 get
1244: {(integer) data_conversion} map /degs set
1245: degs << degs length 1 sub >> get /m set
1246: 0 m sub /mn set
1247: << BFs expand mn powerZ >> Op mul /Op set
1248: Op (string) data_conversion /arg1 set
1249: ] pop
1250: popVariables
1251: arg1
1252: } def
1253:
1254: %% FW-principal part of an operator (FW-homogeneous)
1255: %% fw_psi from bfunc.sm1
1256: %% Op (poly) fw_symbol ---> FW-symbol(Op) (poly)
1257: /fw_symbol {
1258: [[(h). (1).]] replace (s). coefficients 1 get 0 get
1259: } def
1260:
1261: %% FW-homogenization
1262: %% Op (string) (t) fw_homogenize ---> h(Op) (string)
1263: /fw_homogenize {
1264: /arg2 set %% bft (string)
1265: /arg1 set %% an operator (string)
1266: [ /bft /bfDt /bfht /bfhDt /Op /degs /m /mn ] pushVariables
1267: [
1268: /Op arg1 expand def
1269: /bft arg2 def
1270: bft xtoDx /bfDt set
1271: BFs (^(-1)*) bft 3 cat_n /bfht set
1272: BFs (*) bfDt 3 cat_n /bfhDt set
1273: Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
1274: /Op set
1275: Op BFs expand coefficients 0 get
1276: {(integer) data_conversion} map /degs set
1277: degs << degs length 1 sub >> get /m set
1278: 0 m sub /mn set
1279: << BFs expand mn powerZ >> Op mul /Op set
1280: Op (string) data_conversion /arg1 set
1281: ] pop
1282: popVariables
1283: arg1
1284: } def
1285:
1286: %% get the FW-order
1287: %% Op (poly) (t) fw_order ---> FW-ord(Op) (integer)
1288: %% Op should be FW-homogenized.
1289: /fw_order {
1290: /arg2 set %% bft (string)
1291: /arg1 set %% Op (poly)
1292: [/Op /bft /fws /m /fwsDt /k /tt /dtt] pushVariables
1293: [
1294: arg1 /Op set
1295: arg2 /bft set
1296: Op fw_symbol /fws set
1297: /tt bft expand def
1298: /dtt bft xtoDx expand def
1299: fws [[BFs expand (1).]] replace /fws set
1300: fws dtt coefficients 0 get 0 get /m set
1301: fws dtt coefficients 1 get 0 get /fwsDt set
1302: fwsDt tt coefficients 0 get 0 get /k set
1303: m k sub (integer) data_conversion /arg1 set
1304: ] pop
1305: popVariables
1306: arg1
1307: } def
1308:
1309: %% psi(P)(s)
1310: %% Op (poly) (t) (string) fw_psi ---> psi(P) (poly)
1311: %% Op should be FW-homogeneous.
1312: /fw_psi {
1313: /arg2 set %% bft (string)
1314: /arg1 set %% Op (polynomial)
1315: [/bft /bfDt /P /tt /dtt /k /Q /i /m /kk /PPt /PPC /kk /Ss] pushVariables
1316: [
1317: arg2 /bft set
1318: arg1 fw_symbol /P set
1319: /bfDt bft xtoDx def
1320: /tt bft expand def /dtt bfDt expand def
1321: P bft fw_order /k set
1322: << 1 1 k >>
1323: {pop tt P mul /P set }
1324: for
1325: << -1 -1 k >>
1326: {pop dtt P mul /P set }
1327: for
1328: (0) expand /Q set
1329: P dtt coefficients 0 get length /m set
1330: 0 1 << m 1 sub >>
1331: {
1332: /i set
1333: P dtt coefficients 0 get i get /kk set
1334: kk (integer) data_conversion /kk set
1335: P dtt coefficients 1 get i get /PPt set
1336: PPt tt coefficients 1 get 0 get /PPC set
1337: BFth expand /Ss set
1338: 0 1 << kk 1 sub >> {
1339: pop
1340: PPC Ss mul /PPC set
1341: Ss (1) expand sub /Ss set
1342: } for
1343: Q PPC add /Q set
1344: } for
1345: Q /arg1 set
1346: ] pop
1347: popVariables
1348: arg1
1349: } def
1350:
1351: %% get the FW-order
1352: %% Op (poly) [(t1) (t2) ...] fwm_order ---> FW-ord(Op) (integer)
1353: %% Op should be FW-homogenized.
1354: /fwm_order {
1355: /arg2 set %% bftt (string list)
1356: /arg1 set %% Op (poly)
1357: [/Op /bftt /fws /m /fwsDt /k /d /i /tt /dtt] pushVariables
1358: [
1359: arg1 /Op set
1360: arg2 /bftt set
1361: Op fw_symbol /fws set
1362: fws init /fws set
1363: fws [[BFs expand (1).]] replace /fws set
1364: bftt length /d set
1365: 0 /k set
1366: 0 /m set
1367: 0 1 d 1 sub { /i set
1368: /tt bftt i get expand def
1369: /dtt bftt i get xtoDx expand def
1370: fws dtt coefficients 0 get 0 get (integer) dc m add /m set
1371: fws tt coefficients 0 get 0 get (integer) dc k add /k set
1372: } for
1373: m k sub (integer) data_conversion /arg1 set
1374: ] pop
1375: popVariables
1376: arg1
1377: } def
1378:
1379: %% (x1) --> (Dx1)
1380: /xtoDx {
1381: /arg1 set
1382: @@@.Dsymbol arg1 2 cat_n
1383: } def
1384:
1385: %% [(x1) (x2) (x3)] ---> (x1,x2,x3)
1386: /listtostring {
1387: /arg1 set
1388: [/n /j /ary /str] pushVariables
1389: [
1390: /ary arg1 def
1391: /n ary length def
1392: arg1 0 get /str set
1393: n 1 gt
1394: { str (,) 2 cat_n /str set }{ }
1395: ifelse
1396: 1 1 n 1 sub {
1397: /j set
1398: j n 1 sub eq
1399: {str << ary j get >> 2 cat_n /str set}
1400: {str << ary j get >> (,) 3 cat_n /str set}
1401: ifelse
1402: } for
1403: /arg1 str def
1404: ] pop
1405: popVariables
1406: arg1
1407: } def
1408:
1409: %% converting a vector of polynomials [P1 P2 ...] to P1 + P2*e +...
1410: /vector_to_poly {
1411: /arg1 set
1412: [/aVec /nVec /eForm /j /aVecj ] pushVariables
1413: [
1414: arg1 /aVec set
1415: aVec length /nVec set
1416: (0). /eForm set
1417: 0 1 nVec 1 sub {
1418: /j set
1419: aVec j get /aVecj set
1420: @@@.esymbol . j npower aVecj mul eForm add /eForm set
1421: } for
1422: eForm /arg1 set
1423: ] pop
1424: popVariables
1425: arg1
1426: } def
1427:
1428: %% setup the ring of differential operators with the variables varlist
1429: %% and parameters BFparlist
1430: %% varlist setupBFring
1431: /setupDring {
1432: /arg1 set
1433: [ /varlist /bft /allvarlist /n /dvarlist /D_weight /i
1434: ] pushVariables
1435: [
1436: arg1 /varlist set
1437: /allvarlist
1438: varlist BFparlist join
1439: def
1440: varlist length /n set
1441: varlist {xtoDx} map /dvarlist set
1442: /D_weight
1443: [ [ 0 1 n 1 sub
1444: { /i set dvarlist i get 1 }
1445: for ]
1446: [
1447: 0 1 n 1 sub
1448: { /i set varlist i get 1 }
1449: for ]
1450: ] def
1451:
1452: [ allvarlist listtostring ring_of_differential_operators
1453: D_weight weight_vector
1454: 0] define_ring
1455:
1456: ] pop
1457: popVariables
1458: } def
1459:
1460: %% var (poly) m (integer) ---> var^m (poly)
1461: /powerZ {
1462: /arg2 set %% m
1463: /arg1 set %% Var
1464: [ /m /var /varstr /pow /nvar] pushVariables
1465: [
1466: arg1 /var set
1467: arg2 /m set
1468: var (string) data_conversion /varstr set
1469: m -1 gt
1470: { var m npower /pow set}
1471: { varstr (^(-1)) 2 cat_n expand /nvar set
1472: nvar << 0 m sub >> npower /pow set
1473: }
1474: ifelse
1475: pow /arg1 set
1476: ] pop
1477: popVariables
1478: arg1
1479: } def
1480:
1481:
1482: %% added on April 14, 1998:
1483: %% P [(Dt1). (Dt2). ...] mvec k Vtruncate_below
1484: %% --> the part of P of degree >= mvec - k w.r.t. [(Dt1). ..]
1485:
1486: /Vtruncate_below {
1487: /arg4 set /arg3 set /arg2 set /arg1 set
1488: [/P /bftt /k /Q /InP /DegP /edegP /mvec /i] pushVariables
1489: [
1490: arg1 /P set
1491: arg2 /bftt set
1492: arg3 /mvec set
1493: arg4 /k set
1494: (0). /Q set
1495: {
1496: P (0). eq {exit} { } ifelse
1497: P init /InP set
1498: InP bftt total_degree /DegP set
1499: InP @@@.esymbol . coefficients 0 get 0 get (integer) dc /i set
1500: DegP << k mvec i get sub >> lt { } {InP Q add /Q set } ifelse
1501: P InP sub /P set
1502: } loop
1503: Q /arg1 set
1504: ] pop
1505: popVariables
1506: arg1
1507: } def
1508:
1509: %% P (monomial) [(t1). ,...] total_deg
1510: %% --> the total degree (integer) of P w.r.t. [(t1).,..]
1511: /total_degree {
1512: /arg2 set /arg1 set
1513: [/P /bftt /d /j /PC /tdeg ] pushVariables
1514: [
1515: arg1 /P set
1516: arg2 /bftt set
1517: bftt length /d set
1518: 0 /tdeg set
1519: 0 1 d 1 sub {/j set
1520: P << bftt j get >> coefficients /PC set
1521: PC 0 get 0 get (integer) dc tdeg add /tdeg set
1522: PC 1 get 0 get /P set
1523: } for
1524: tdeg /arg1 set
1525: ] pop
1526: popVariables
1527: arg1
1528: } def
1529:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to restall.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc