Annotation of OpenXM/src/kan96xx/Doc/restall.sm1, Revision 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