Annotation of OpenXM/src/kan96xx/Doc/bfunction.sm1, Revision 1.1
1.1 ! maekawa 1: %%% oaku/kan/bfunction.sm1, 1998, 11/5
! 2:
! 3: %%% global variables for bfunction
! 4: %%% bfunction.*
! 5: /bfunction.version (2.981105) def
! 6: bfunction.version [(Version)] system_variable gt
! 7: { (This package requires the latest version of kan/sm1) message
! 8: (Please get it from http://www.math.kobe-u.ac.jp/KAN) message
! 9: error
! 10: } { } ifelse
! 11: /bfunction.v [(x) (y) (z)] def %% default variables of the input polynomial
! 12: /bfunction.s (s) def %% default variable of the output b-function
! 13: /bfunction.vh (v_) def %% default variable for V-homogenization
! 14: /bfunction.t (t_) def %% default variable for t in delta(t-f)
! 15: /bfunction.a [] def %% parameters are not available yet
! 16: /bfunction.verbose 0 def %% no messages if 0
! 17: /bfunction.strategy 0 def %% V-homogenization + h-homogenization if 0
! 18: %% V-homogenization if 1 (not available yet)
! 19: %% h-homogenization if 2 (not available yet)
! 20: /bfunction.result 0 def
! 21:
! 22: (bfunction.sm1, 11/05,1998 (C) T. Oaku. bfunction ) message-quiet
! 23:
! 24: [(bfunction)
! 25: [( a bfunction b)
! 26: (array a; poly b;)
! 27: (a : [f] ; string f ;)
! 28: (a : [f] ; polynomial f ;)
! 29: (a : [f v] ; string f,v; )
! 30: (a : [f v] ; polynomial f, string v; )
! 31: (b is the b-function (=Bernstein-Sato polynomial) of a polynomial f)
! 32: (in variables v.)
! 33: (If v is not specified, the variables are assumed to be (x,y,z). )
! 34: (b will be a polynomial in s. This variable can be changed by typing in)
! 35: ( (variable) /bfunction.s set )
! 36: (For the algorithm, see Duke Math. J. 87 (1997),115-132,)
! 37: ( J. Pure and Applied Algebra 117&118(1997), 495--518.)
! 38: $Example [(x^3-y^2) (x,y)] bfunction :: $
! 39: ]
! 40: ] putUsages
! 41:
! 42: /bfunction {
! 43: /arg1 set
! 44: [/aa /typev /setarg /f /s /v /bf /bfs /vt ] pushVariables
! 45: [(CurrentRingp) (KanGBmessage)] pushEnv %% push current global environment.
! 46: [
! 47:
! 48: /aa arg1 def
! 49: aa isArray { } { (array bfunction) message error } ifelse
! 50: /setarg 0 def
! 51: aa { tag } map /typev set
! 52: typev [ StringP ] eq
! 53: { /f aa 0 get def
! 54: /v bfunction.v def
! 55: /s bfunction.s def
! 56: /setarg 1 def
! 57: } { } ifelse
! 58: typev [ PolyP ] eq
! 59: { /f aa 0 get (string) data_conversion def
! 60: /v bfunction.v def
! 61: /s bfunction.s def
! 62: /setarg 1 def
! 63: } { } ifelse
! 64: typev [StringP StringP] eq
! 65: { /f aa 0 get def
! 66: /v [ aa 1 get to_records pop ] def
! 67: /s bfunction.s def
! 68: /setarg 1 def
! 69: } { } ifelse
! 70: typev [PolyP StringP] eq
! 71: { /f aa 0 get (string) data_conversion def
! 72: /v [ aa 1 get to_records pop ] def
! 73: /s bfunction.s def
! 74: /setarg 1 def
! 75: } { } ifelse
! 76: typev [StringP ArrayP] eq
! 77: { /f aa 0 get def
! 78: /v aa 1 get def
! 79: /s bfunction.s def
! 80: /setarg 1 def
! 81: } { } ifelse
! 82: typev [PolyP ArrayP] eq
! 83: { /f aa 0 get (string) data_conversion def
! 84: /v aa 1 get def
! 85: /s bfunction.s def
! 86: /setarg 1 def
! 87: } { } ifelse
! 88: setarg { } { (Argument mismatch) message error } ifelse
! 89:
! 90: [(KanGBmessage) bfunction.verbose] system_variable
! 91:
! 92: v bfunction.t append /vt set
! 93:
! 94: [f v fw_delta bfunction.t vt] indicial 0 get /bf set
! 95: [bfunction.s ring_of_polynomials 0] define_ring
! 96: bf . /bf set
! 97: bfunction.s . /bfs set
! 98: bf [[bfs (-1). bfs sub]] replace /bf set
! 99: /bfunction.result bf def
! 100: /arg1 bf def
! 101: ] pop
! 102: popEnv
! 103: popVariables
! 104: arg1
! 105: } def
! 106:
! 107: %% Computing the indicial polynomial (the b-function) of a D-module
! 108: /indicial {
! 109: /arg1 set %% [equations, the variable to be restricted to 0, all variables]
! 110: [/eqs /t /vars /allvars /newvars /x_vars /ans1 /ans2 ] pushVariables
! 111: [(CurrentRingp)] pushEnv
! 112: [
! 113: arg1 0 get /eqs set
! 114: arg1 1 get /t set
! 115: arg1 2 get /vars set
! 116: vars bfunction.s append /allvars set
! 117: [bfunction.t] allvars complement /newvars set
! 118: [bfunction.t] vars complement /x_vars set
! 119: [eqs t vars] indicial1 /ans1 set
! 120: [ans1 x_vars newvars] eliminate_Dx /ans2 set
! 121: [ans2 x_vars newvars] eliminate_x /arg1 set
! 122: ] pop
! 123: popEnv
! 124: popVariables
! 125: arg1
! 126: } def
! 127:
! 128: %% (-1,0;1,0)-Groebner basis
! 129: %% [equations (t) vars] indical1 ---> psi(BFequations) (as a list of strings)
! 130: /indicial1 {
! 131: /arg1 set
! 132: [/bft /bfs /bfh /bf1 /ff /ans /n /i /BFallvarlist /BFDvarlist
! 133: /BFs_weight /BFvarlist ] pushVariables
! 134: [(CurrentRingp)] pushEnv
! 135: [
! 136: /ff arg1 0 get def
! 137: /bft arg1 1 get def
! 138: /BFvarlist arg1 2 get def
! 139: /BFallvarlist
! 140: [ bfunction.vh bfunction.s] BFvarlist concat bfunction.a concat
! 141: def
! 142: BFvarlist length /n set
! 143: BFvarlist {xtoDx} map /BFDvarlist set
! 144: /BFs_weight
! 145: [ [ bfunction.vh 1 ]
! 146: [ 0 1 n 1 sub
! 147: { /i set BFDvarlist i get 1 }
! 148: for
! 149: 0 1 n 1 sub
! 150: { /i set BFvarlist i get 1 }
! 151: for ]
! 152: ] def
! 153:
! 154: [ BFallvarlist listtostring ring_of_differential_operators
! 155: BFs_weight weight_vector
! 156: 0] define_ring
! 157:
! 158: /bfh (h). def
! 159: /bfs bfunction.vh . def
! 160: /bf1 (1). def
! 161: ff { bft fw_homogenize . } map /ff set
! 162: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
! 163: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
! 164: ff reducedBase /ans set
! 165: ans {bft fw_psi} map /ans set
! 166: ans {(string) data_conversion} map /arg1 set
! 167: ] pop
! 168: popEnv
! 169: popVariables
! 170: arg1
! 171: } def
! 172:
! 173: %% eliminates Dx in the ring of differential operators
! 174: /eliminate_Dx {
! 175: /arg1 set %% [operators x variables]
! 176: [/bfh /bf1 /ff /ans /nx /ny /x_varlist /Dx_weight /BFvarlist
! 177: /allvarlist /Dx_varlist /y_varlist /Dy_varlist /allvarlist /i
! 178: ] pushVariables
! 179: [(CurrentRingp)] pushEnv
! 180: [
! 181: /ff arg1 0 get def
! 182: /x_varlist arg1 1 get def
! 183: /BFvarlist arg1 2 get def
! 184: x_varlist length /nx set
! 185: BFvarlist bfunction.a concat /allvarlist set
! 186:
! 187: x_varlist {xtoDx} map /Dx_varlist set
! 188: x_varlist BFvarlist complement /y_varlist set
! 189: y_varlist length /ny set
! 190: y_varlist {xtoDx} map /Dy_varlist set
! 191:
! 192: /Dx_weight
! 193: [ [ 0 1 nx 1 sub
! 194: { /i set Dx_varlist i get 1 }
! 195: for ]
! 196: [ 0 1 nx 1 sub
! 197: { /i set x_varlist i get 1 }
! 198: for
! 199: 0 1 ny 1 sub
! 200: { /i set y_varlist i get 1 }
! 201: for
! 202: 0 1 ny 1 sub
! 203: { /i set Dy_varlist i get 1 }
! 204: for
! 205: ]
! 206: ] def
! 207:
! 208: [ allvarlist listtostring ring_of_differential_operators
! 209: Dx_weight weight_vector
! 210: 0] define_ring
! 211:
! 212: /bfh (h). def
! 213: /bf1 (1). def
! 214: ff {.} map /ff set
! 215: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
! 216: bfunction.verbose 1 eq
! 217: {(Eliminating the derivations w.r.t. ) messagen x_varlist ::}
! 218: { }
! 219: ifelse
! 220: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
! 221: ff reducedBase /ans set
! 222: ans Dx_varlist eliminatev /ans set
! 223: ans {(string) data_conversion} map /arg1 set
! 224: ] pop
! 225: popEnv
! 226: popVariables
! 227: arg1
! 228: } def
! 229:
! 230: %% eliminates x in the ring of polynomials
! 231: /eliminate_x {
! 232: /arg1 set %% [operators x variables]
! 233: [/bfh /bfs /bf1 /ff /ans /nx /ny /x_varlist /BFvarlist
! 234: /allvarlist /y_varlist /i
! 235: ] pushVariables
! 236: [(CurrentRingp)] pushEnv
! 237: [
! 238: /ff arg1 0 get def
! 239: /x_varlist arg1 1 get def
! 240: /BFvarlist arg1 2 get def
! 241: x_varlist length /nx set
! 242: BFvarlist bfunction.a concat /allvarlist set
! 243:
! 244: x_varlist BFvarlist complement /y_varlist set
! 245: y_varlist length /ny set
! 246:
! 247: /x_weight
! 248: [ [ 0 1 nx 1 sub
! 249: { /i set x_varlist i get 1 }
! 250: for ]
! 251: [ 0 1 ny 1 sub
! 252: { /i set y_varlist i get 1 }
! 253: for
! 254: ]
! 255: ] def
! 256:
! 257: [ allvarlist listtostring ring_of_polynomials x_weight weight_vector
! 258: 0] define_ring
! 259:
! 260: /bfh (h). def
! 261: /bf1 (1). def
! 262: ff {.} map /ff set
! 263: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
! 264: bfunction.verbose 1 eq
! 265: {(Eliminating the variables ) messagen x_varlist ::}
! 266: { }
! 267: ifelse
! 268: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
! 269: ff reducedBase /ans set
! 270: ans x_varlist eliminatev /ans set
! 271: ans {(string) data_conversion} map /arg1 set
! 272: ] pop
! 273: popEnv
! 274: popVariables
! 275: arg1
! 276: } def
! 277: %%%%%%%%%%%%%%%%%%%%%%% libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 278:
! 279: %% FW-principal part of an operator (FW-homogeneous)
! 280: %% Op (poly) fw_symbol ---> FW-symbol(Op) (poly)
! 281: /fw_symbol {
! 282: [[(h). (1).]] replace bfunction.vh . coefficients 1 get 0 get
! 283: } def
! 284:
! 285: %% FW-homogenization
! 286: %% Op (string) (t) fw_homogenize ---> h(Op) (string)
! 287: /fw_homogenize {
! 288: /arg2 set %% bft (string)
! 289: /arg1 set %% an operator (string)
! 290: [ /bft /bfDt /bfht /bfhDt /Op /degs /m /mn ] pushVariables
! 291: [
! 292: /Op arg1 expand def
! 293: /bft arg2 def
! 294: bft xtoDx /bfDt set
! 295: bfunction.vh (^(-1)*) bft 3 cat_n /bfht set
! 296: bfunction.vh (*) bfDt 3 cat_n /bfhDt set
! 297: Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
! 298: /Op set
! 299: Op bfunction.vh expand coefficients 0 get
! 300: {(integer) data_conversion} map /degs set
! 301: degs << degs length 1 sub >> get /m set
! 302: 0 m sub /mn set
! 303: << bfunction.vh expand mn powerZ >> Op mul /Op set
! 304: Op (string) data_conversion /arg1 set
! 305: ] pop
! 306: popVariables
! 307: arg1
! 308: } def
! 309:
! 310: %% setup the ring of differential operators with the variables varlist
! 311: %% and parameters bfunction.a
! 312: %% varlist setupBFring
! 313: /setupDring {
! 314: /arg1 set
! 315: [ /varlist /bft /allvarlist /n /dvarlist /D_weight /i
! 316: ] pushVariables
! 317: [
! 318: arg1 /varlist set
! 319: /allvarlist
! 320: varlist bfunction.a join
! 321: def
! 322: varlist length /n set
! 323: varlist {xtoDx} map /dvarlist set
! 324: /D_weight
! 325: [ [ 0 1 n 1 sub
! 326: { /i set dvarlist i get 1 }
! 327: for ]
! 328: [
! 329: 0 1 n 1 sub
! 330: { /i set varlist i get 1 }
! 331: for ]
! 332: ] def
! 333:
! 334: [ allvarlist listtostring ring_of_differential_operators
! 335: D_weight weight_vector
! 336: 0] define_ring
! 337:
! 338: ] pop
! 339: popVariables
! 340: } def
! 341:
! 342: %% psi(P)(s)
! 343: %% Op (poly) (t) (string) fw_psi ---> psi(P) (poly)
! 344: %% Op should be FW-homogeneous.
! 345: /fw_psi {
! 346: /arg2 set %% bft (string)
! 347: /arg1 set %% Op (polynomial)
! 348: [/bft /bfDt /P /tt /dtt /k /Q /i /m /kk /PPt /PPC /kk /Ss] pushVariables
! 349: [
! 350: arg2 /bft set
! 351: arg1 fw_symbol /P set
! 352: /bfDt bft xtoDx def
! 353: /tt bft expand def /dtt bfDt expand def
! 354: P bft fw_order /k set
! 355: << 1 1 k >>
! 356: {pop tt P mul /P set }
! 357: for
! 358: << -1 -1 k >>
! 359: {pop dtt P mul /P set }
! 360: for
! 361: (0) expand /Q set
! 362: P dtt coefficients 0 get length /m set
! 363: 0 1 << m 1 sub >>
! 364: {
! 365: /i set
! 366: P dtt coefficients 0 get i get /kk set
! 367: kk (integer) data_conversion /kk set
! 368: P dtt coefficients 1 get i get /PPt set
! 369: PPt tt coefficients 1 get 0 get /PPC set
! 370: bfunction.s expand /Ss set
! 371: 0 1 << kk 1 sub >> {
! 372: pop
! 373: PPC Ss mul /PPC set
! 374: Ss (1) expand sub /Ss set
! 375: } for
! 376: Q PPC add /Q set
! 377: } for
! 378: Q /arg1 set
! 379: ] pop
! 380: popVariables
! 381: arg1
! 382: } def
! 383:
! 384: %% get the FW-order
! 385: %% Op (poly) (t) fw_order ---> FW-ord(Op) (integer)
! 386: %% Op should be FW-homogenized.
! 387: /fw_order {
! 388: /arg2 set %% bft (string)
! 389: /arg1 set %% Op (poly)
! 390: [/Op /bft /fws /m /fwsDt /k /tt /dtt] pushVariables
! 391: [
! 392: arg1 /Op set
! 393: arg2 /bft set
! 394: Op fw_symbol /fws set
! 395: /tt bft expand def
! 396: /dtt bft xtoDx expand def
! 397: fws [[bfunction.s expand (1).]] replace /fws set
! 398: fws dtt coefficients 0 get 0 get /m set
! 399: fws dtt coefficients 1 get 0 get /fwsDt set
! 400: fwsDt tt coefficients 0 get 0 get /k set
! 401: m k sub (integer) data_conversion /arg1 set
! 402: ] pop
! 403: popVariables
! 404: arg1
! 405: } def
! 406:
! 407: /remove0 {
! 408: /arg1 set
! 409: arg1 (0). eq
! 410: { } {arg1} ifelse
! 411: } def
! 412:
! 413: %% functions for list operations etc.
! 414:
! 415: /notidentical {
! 416: /arg2 set
! 417: /arg1 set
! 418: arg1 arg2 eq
! 419: { } {arg1} ifelse
! 420: } def
! 421:
! 422: %% [(x1) (x2) (x3)] ---> (x1,x2,x3)
! 423: /listtostring {
! 424: /arg1 set
! 425: [/n /j /ary /str] pushVariables
! 426: [
! 427: /ary arg1 def
! 428: /n ary length def
! 429: arg1 0 get /str set
! 430: n 1 gt
! 431: { str (,) 2 cat_n /str set }{ }
! 432: ifelse
! 433: 1 1 n 1 sub {
! 434: /j set
! 435: j n 1 sub eq
! 436: {str << ary j get >> 2 cat_n /str set}
! 437: {str << ary j get >> (,) 3 cat_n /str set}
! 438: ifelse
! 439: } for
! 440: /arg1 str def
! 441: ] pop
! 442: popVariables
! 443: arg1
! 444: } def
! 445:
! 446: %% (x1) --> (Dx1)
! 447: /xtoDx {
! 448: /arg1 set
! 449: @@@.Dsymbol arg1 2 cat_n
! 450: } def
! 451:
! 452: %% concatenate two lists
! 453: /concat {
! 454: /arg2 set
! 455: /arg1 set
! 456: [/n /j /lst1 /lst2 ] pushVariables
! 457: [
! 458: /lst1 arg1 def
! 459: /lst2 arg2 def
! 460: /n lst2 length def
! 461: 0 1 n 1 sub {
! 462: /j set
! 463: lst1 lst2 j get append /lst1 set
! 464: } for
! 465: /arg1 lst1 def
! 466: ] pop
! 467: popVariables
! 468: arg1
! 469: } def
! 470:
! 471: %% var (poly) m (integer) ---> var^m (poly)
! 472: /powerZ {
! 473: /arg2 set %% m
! 474: /arg1 set %% Var
! 475: [ /m /var /varstr /pow /nvar] pushVariables
! 476: [
! 477: arg1 /var set
! 478: arg2 /m set
! 479: var (string) data_conversion /varstr set
! 480: m -1 gt
! 481: { var m npower /pow set}
! 482: { varstr (^(-1)) 2 cat_n expand /nvar set
! 483: nvar << 0 m sub >> npower /pow set
! 484: }
! 485: ifelse
! 486: pow /arg1 set
! 487: ] pop
! 488: popVariables
! 489: arg1
! 490: } def
! 491:
! 492:
! 493: %% (f) varlist fw_delta ---> [t - f, Dx + f_xDt, ...]
! 494: /fw_delta {
! 495: /arg2 set %% [(x) (y) ...]
! 496: /arg1 set %% (f)
! 497: [ /fstr /f /bft /n /j /varlist /dxvarlist /allvarlist /xi /fxi /dxi /dt
! 498: /delta /BFdt /BFDtx_weight ] pushVariables
! 499: [
! 500: arg1 /fstr set
! 501: arg2 /varlist set
! 502: [bfunction.t] varlist join bfunction.a join /allvarlist set
! 503: bfunction.t xtoDx /BFdt set
! 504: varlist {xtoDx} map /dxvarlist set
! 505: varlist length /n set
! 506: /BFDtx_weight [ [ BFdt 1
! 507: 0 1 n 1 sub {/j set varlist j get 1} for ]
! 508: [ bfunction.t 1
! 509: 0 1 n 1 sub {/j set dxvarlist j get 1} for ]
! 510: ] def
! 511:
! 512: [ allvarlist listtostring ring_of_differential_operators
! 513: BFDtx_weight weight_vector 0 ] define_ring
! 514:
! 515: fstr expand /f set
! 516: bfunction.t expand /bft set
! 517: BFdt expand /dt set
! 518: /delta [
! 519: bft f sub
! 520: 0 1 n 1 sub {
! 521: /i set
! 522: varlist i get xtoDx expand /dxi set
! 523: << dxi f mul >> << f dxi mul >> sub [[(h). (1).]] replace /fxi set
! 524: dxi << fxi dt mul >> add
! 525: } for
! 526: ] def
! 527: delta {(string) data_conversion} map /arg1 set
! 528: ] pop
! 529: popVariables
! 530: arg1
! 531: } def
! 532:
! 533:
! 534:
! 535:
! 536:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to bfunction.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc