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