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