Annotation of OpenXM/src/kan96xx/Doc/Old/bfunc.sm1, Revision 1.1
1.1 ! maekawa 1: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 2: % The b-function b_f(s), %
! 3: % generators of the annihilators of f^s, %
! 4: % and the 1st algebraic local cohomology group %
! 5: % for f = f(x,y,z) %
! 6: % 18 Dec. 1995 by T. Oaku %
! 7: % modified 26 Feb. 1996 %
! 8: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 9:
! 10: (Type in << f bf3 >> for the b-function for f(x,y,z).) message
! 11: (Type in bf for the b-function for x^3-y^2 z^2.) message
! 12: ( ) message
! 13: /bf {(x^3 - y^2*z^2 ) bf3} def
! 14: %%%%%%%%%%%%% Template to compute b-function for f(x,y,z) %%%%%%%%%%%%
! 15: /bf3 {
! 16: /f set
! 17: %%% s is used both for F-homogenization and for tDt %%%%%%%
! 18: [(s,t,x,y,z) ring_of_differential_operators
! 19: [[(s) 1] ]
! 20: weight_vector 0 ] define_ring
! 21: %%% GIVE THE POLYNOMIAL f(x,y,z) HERE %%%%%%%%%%%%%%%%%%%%%
! 22: f . /f set
! 23: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 24: f fw_delta /ff set
! 25: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 26: (Computing the b-function of) message
! 27: f ::
! 28: (The generators are) message
! 29: ff ::
! 30: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 31: (Computing FW-groebner basis in Q[t,x,y,z]<Dt,Dx,Dy,Dz> ) message
! 32: [ff] groebner 0 get /ansG set
! 33: ( ) message
! 34: %%%%% ansG is an FW-Groebner basis in Q[t,x,y,z]<Dt,Dx,Dy,Dz> %%%%%%
! 35: ansG {fw_symbol} map /ansG0 set
! 36: ansG0 {fw_psi} map /ansH set
! 37: %%%% ansH generates an ideal in Q[s,x,y,z]<Dx,Dy,Dz> %%%%%
! 38: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 39: [(s,x,y,z) ring_of_differential_operators
! 40: [[(Dx) 1 (Dy) 1 (Dz) 1] ] weight_vector
! 41: 0
! 42: ] define_ring
! 43: ansH {mymap} map /ansH set
! 44: ansH {[[(h). (1).]] replace} map {homogenize} map /ansH set
! 45: (Eliminating Dx, Dy, Dz ) message
! 46: [ansH] groebner 0 get /ansH set
! 47: ( ) message
! 48: ansH (Dx) eliminate0
! 49: (Dy) eliminate0
! 50: (Dz) eliminate0
! 51: /ansH0 set
! 52: ansH0 {[[(h). (1).]] replace} map /ansH01 set
! 53: ansH0 {[[(s). (-s-1).]] replace} map /ansH0 set
! 54: ansH0 minimal /ansH0 set
! 55: %%%% ansH0 generates an ideal in Q[s,x,y,z] %%%%
! 56: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 57: [(s,x,y,z) ring_of_polynomials
! 58: (x,y,z) elimination_order 0] define_ring
! 59: ansH0 {mymap} map /ansH0 set
! 60: ansH0 {[[(x). (0).] [(y). (0).] [(z). (0).]] replace} map /ansH00 set
! 61: %%% ansH00 is the restriction of ansH0 to x=y=z=0 %%%
! 62: ansH0 {[[(h). (1).]] replace} map {homogenize} map /ansH0 set
! 63: (Eliminating x,y,z ) message
! 64: [ansH0] groebner 0 get /ansH0 set
! 65: ansH0 (x) eliminate0
! 66: (y) eliminate0
! 67: (z) eliminate0
! 68: /ansbff set
! 69: ansbff minimal /ansbff set
! 70: ansbff 0 get /ansbf set
! 71: (the global b-function b_f(s) [ansbf] is ) message
! 72: ansbf ::
! 73: %%%%%% restriction to x=y=z=0 %%%%%%%%%%%%%%%%%
! 74: ansH00 remove0 /ansH00 set
! 75: [(s) ring_of_polynomials
! 76: ( ) elimination_order 0] define_ring
! 77: ansH00 {mymap} map /ansH00 set
! 78: ansH00 {[[(h). (1).]] replace} map {homogenize} map /ansH00 set
! 79: [ansH00] groebner 0 get /ansbff0 set
! 80: ansbff0 minimal /ansbff0 set
! 81: ansbff0 0 get /ansbf0 set
! 82: (a divisor of the local b-function b_f(s) [ansbf0] is ) message
! 83: ( ) message
! 84: ansbf0 ::
! 85: } def
! 86:
! 87: %%%%%%%%%%%%% finding a P s.t. Pf^{s+1} = b_f(s)f^s %%%%%%%%%%%%%%%%%%%%%%%
! 88:
! 89: /bf0 {
! 90: %%% s is used both for F-homogenization and for tDt %%%%%%%
! 91: [(s,t,x,y,z) ring_of_differential_operators
! 92: [[(s) 1] [(Dx) 1 (Dy) 1 (Dz) 1 (x) 1 (y) 1 (z) 1]]
! 93: weight_vector 0 ] define_ring
! 94: %%% Give the polynomial f(x,y,z) here %%%%%%%%%%%%%%%%%%%%%
! 95: ( x^5-y^2*z^2 ). /f set
! 96: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 97: f fw_delta /ff set
! 98: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 99: (Computing the b-function of) message
! 100: f ::
! 101: (The generators are) message
! 102: ff ::
! 103: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 104: (Computing FW-groebner basis in Q[t,x,y,z]<Dt,Dx,Dy,Dz> ) message
! 105: [ff] groebner 0 get /ansG set
! 106: ansG {fw_order} map /ansGford set
! 107: ansG {[[(h). (1).]] replace} map /ansG set
! 108: ansG (Dx) eliminatepsi0
! 109: (Dy) eliminatepsi0
! 110: (Dz) eliminatepsi0
! 111: (x) eliminatepsi0
! 112: (y) eliminatepsi0
! 113: (z) eliminatepsi0
! 114: /ansbft set
! 115: ansbft 0 get fw_rhorest /ansP set
! 116: (Completed: P is [ansP]) ansP ::
! 117: (F) f toa
! 118: (P) ansP toa
! 119: ansbft
! 120: } def
! 121:
! 122: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 123: % 2nd algorithm for b-function
! 124: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 125: (Type in bf2 for the b-function via saturation.) message
! 126: ( ) message
! 127: /bf2 {
! 128: %%% s is used both for F-homogenization and for t*Dt.
! 129: %%% u is used for the computation of saturation.
! 130: [(s,t,u,x,y,z) ring_of_differential_operators
! 131: [[(s) 1 (u) 1]] weight_vector
! 132: 0 ] define_ring
! 133: %%% Write f(x) here.%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 134: ( y*(x^5- y^2*z^2) ). /f set
! 135: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 136: (Computing the b-function of ) message
! 137: f ::
! 138: f fw_deltasat /ff set
! 139: ff print
! 140: ( are generators.) message ( ) message
! 141: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 142: (Computing the saturation...) message
! 143: [ff] groebner 0 get /ansS set
! 144: ( ) message
! 145: ansS {[[(h). (1). ]] replace} map /ansS set
! 146: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 147: ansS (s) eliminate0
! 148: (u) eliminate0
! 149: /ansS0 set
! 150: ansS0 {fw_psi} map /ansS1 set
! 151: ansS1 {[[(s). (-s-1).]] replace} map /ansS1 set
! 152: ansS1 [f] concat /ansS1 set
! 153: %%%% ansS1 generates an ideal in Q[s,x,y,z]<Dx,Dy,Dz> %%%%%
! 154: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 155: [(s,x,y,z) ring_of_differential_operators
! 156: [[(Dx) 1 (Dy) 1 (Dz) 1] [(x) 1 (y) 1 (z) 1]] weight_vector
! 157: 0
! 158: ] define_ring
! 159: ansS1 {mymap} map /ansS1 set
! 160: ansS1 {[[(h). (1).]] replace} map {homogenize} map /ansS1 set
! 161: (Eliminating Dx, Dy, Dz ) message
! 162: [ansS1] groebner 0 get /ansS1 set
! 163: ( ) message
! 164: ansS1 (Dx) eliminate0
! 165: (Dy) eliminate0
! 166: (Dz) eliminate0
! 167: /ansJ set
! 168: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 169: [(s,x,y,z) ring_of_polynomials
! 170: (x,y,z) elimination_order 0] define_ring
! 171: ansJ {mymap} map /ansJ set
! 172: ansJ {[[(x). (0).] [(y). (0).] [(z). (0).]] replace} map /ansJ0 set
! 173: %%% ansJ0 is the restriction of ansJ to x=y=z=0 %%%
! 174: ansJ {[[(h). (1).]] replace} map {homogenize} map /ansJ set
! 175: (Eliminating x,y,z ) message
! 176: [ansJ] groebner 0 get /ansJ set
! 177: ansJ (x) eliminate0
! 178: (y) eliminate0
! 179: (z) eliminate0
! 180: /ansbffS set
! 181: ansbffS minimal /ansbffS set
! 182: ansbffS 0 get /ansbfS set
! 183: (the global b-function b_f(s) [ansbfS] is ) message
! 184: ansbfS ::
! 185: %%%%%% restriction to x=y=z=0 %%%%%%%%%%%%%%%%%
! 186: ansJ0 remove0 /ansJ0 set
! 187: [(s) ring_of_polynomials
! 188: ( ) elimination_order 0] define_ring
! 189: ansJ0 {mymap} map /ansJ0 set
! 190: ansJ0 {[[(h). (1).]] replace} map {homogenize} map /ansJ0 set
! 191: [ansJ0] groebner 0 get /ansbffS0 set
! 192: ansbffS0 minimal /ansbffS0 set
! 193: ansbffS0 0 get /ansbfS0 set
! 194: (a divisor of the local b-function b_f(s) [ansbfS0] is ) message
! 195: ( ) message
! 196: ansbfS0 ::
! 197: } def
! 198:
! 199: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 200: (Type in fs for the annihilators of f^s.) message
! 201: ( ) message
! 202: %%%%%%%%%%%%%% Computing the annihilators of f^s %%%%%%%%%%%%%%%%%%%%
! 203: /fs {
! 204: %%% s is used both for F-homogenization and for t*Dt.
! 205: %%% u is used for the computation of saturation.
! 206: [(s,t,u,x,y,z) ring_of_differential_operators
! 207: [[(s) 1 (u) 1]] weight_vector
! 208: 0 ] define_ring
! 209: %%% Write f(x) here.%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 210: ( y*(x^5-y^2*z^2) ). /f set
! 211: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 212: (Computing involutory generators for f^s with f = ) message
! 213: f ::
! 214: f fw_deltasat /ff set
! 215: ff print
! 216: ( are generators.) message ( ) message
! 217: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 218: (Computing groebner basis) message
! 219: [ff] groebner 0 get /ans set
! 220: ( ) message
! 221: ans {[[(h). (1).]] replace} map /ans0 set
! 222: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 223: ans0 (s) eliminate0
! 224: (u) eliminate0
! 225: /ans1 set
! 226: ans1 {fw_psi} map /ans1 set
! 227: ans1 {[[(s). (-s-1).]] replace} map /ans1 set
! 228: ans1 involutory /ans2 set
! 229: ans2 minimal /ansfs set
! 230: (The answer [ansfs] is ) message
! 231: ansfs print ( ) message
! 232: (F) f toa
! 233: (FS) ansfs toa_l
! 234: } def
! 235:
! 236: %% Computing the D-module for f^s as D-module (not as D[s]-module)
! 237: /fs0 {
! 238: %%% s is used both for F-homogenization and for t*Dt.
! 239: %%% u is used for the computation of saturation.
! 240: [(s,t,u,x,y,z) ring_of_differential_operators
! 241: [[(s) 1 (u) 1]] weight_vector
! 242: 0 ] define_ring
! 243: %%% Write f(x) here.%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 244: ( y*(x^5-y^2*z^2) ). /f set
! 245: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 246: (Computing involutory generators for f^s with f = ) message
! 247: f ::
! 248: f fw_deltasat /ff set
! 249: ff print
! 250: ( are generators.) message ( ) message
! 251: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 252: (Computing groebner basis) message
! 253: [ff] groebner 0 get /ans set
! 254: ( ) message
! 255: ans {[[(h). (1).]] replace} map /ans0 set
! 256: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 257: ans0 (s) eliminate0
! 258: (u) eliminate0
! 259: /ans1 set
! 260: ans1 {fw_psi} map /ans1 set
! 261: ans1 {[[(s). (-s-1).]] replace} map /ans1 set
! 262:
! 263: ans1 {[[(h). (1).]] replace} map /ans1 set
! 264: ans1 {homogenize} map /ans1 set
! 265: [ans1] groebner 0 get /ans1 set
! 266: ans1 {[[(h). (1).]] replace} map /ans1 set
! 267: ans1 (s) eliminate0 /ans1 set
! 268: ans1 involutory /ans2 set
! 269: ans2 minimal /ansfs set
! 270: (The answer [ansfs] is ) message
! 271: ansfs print ( ) message
! 272: (F) f toa
! 273: (FS) ansfs toa_l
! 274: } def
! 275:
! 276: %%%% algebraic local cohomology %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 277: (Type in alc for the 1st algebraic local cohomology group.) message
! 278: ((Make sure for alc that b_f(s) has no integer roots other than -1.)) message
! 279: ( ) message
! 280: /alc {
! 281: %%% s is used for FW-filtration.
! 282: [(s,t,x,y,z) ring_of_differential_operators
! 283: [[(s) 1]] weight_vector 0 ] define_ring
! 284: %%% give the polynomial f(x,y,z) here %%%%%%%%%%%%%%%%%%%%%%%%
! 285: ( x^3 + y^3 + z^3 ). /f set
! 286: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 287: f fw_delta /ff set
! 288: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 289: (Computing the algebraic local cohomology for) message
! 290: f ::
! 291: ff {[[(h). (1).]] replace} map {homogenize} map /ff set
! 292: (Computing an FW-groebner basis) message
! 293: [ff] groebner 0 get /ansfw set
! 294: ( ) message
! 295: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 296: % selecting the elements of F-order 0
! 297: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 298: /gb ansfw def
! 299: gb {fw_order} map /gbford set
! 300:
! 301: /ansind0 [
! 302: 0 1 << gb length 1 sub >> {
! 303: /n set
! 304: gb n get /ff set
! 305: ff fw_order (integer) data_conversion /m set
! 306: << m 2 lt >>
! 307: { << m 1 1 >> {pop ff (Dt). ff mul /ff set } for
! 308: }
! 309: { } ifelse
! 310: } for
! 311: ] def
! 312: ansind0 {[[(h). (1).]] replace} map /ansind0 set
! 313: ansind0 {[[(s). (1).]] replace} map /ansind0 set
! 314: ansind0 {[[(t). (0).]] replace} map /ansind1 set
! 315: ansind1 remove0 /ansind1 set
! 316: ansind1 involutory /ansind2 set
! 317: ansind2 minimal /ansind set
! 318: (The answer [ansind] is ) message
! 319: ansind ::
! 320: (F) f toa
! 321: (ALC) ansind toa_l
! 322: } def
! 323:
! 324: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 325: %%%% involutory base in K(s)[x,y,z]<Dx,Dy,Dz>
! 326: /involutory {
! 327: /ansff0 set
! 328: [/ansff1 /ansff2 /ansff3 ] pushVariables
! 329: [
! 330: [(s,t,x,y,z) ring_of_differential_operators
! 331: [[(Dx) 1 (Dy) 1 (Dz) 1] [ (x) 1 (y) 1 (z) 1 ]] weight_vector
! 332: 0
! 333: ] define_ring
! 334: ansff0 {mymap} map /ansff1 set
! 335: ansff1 {[[(h). (1).]] replace} map {homogenize} map /ansff2 set
! 336: (Computing an involutory base ) message
! 337: [ansff2] groebner 0 get /ansff3 set
! 338: ( ) message
! 339: ansff3 {[[(h). (1).]] replace} map /ansff3 set
! 340: ansff3 /ansinv set
! 341: ] pop
! 342: popVariables
! 343: ansinv
! 344: } def
! 345:
! 346: %%%%%% for FW-filtration, etc. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 347: % F-order
! 348: /fw_order {
! 349: fw_symbol /fws set
! 350: fws [[(s). (1).]] replace /fws set
! 351: fws (Dt). coefficients 0 get 0 get /m set
! 352: fws (Dt). coefficients 1 get 0 get /fwsDt set
! 353: fwsDt (t). coefficients 0 get 0 get /k set
! 354: m k sub
! 355: } def
! 356:
! 357: % remove 0 elements from a list
! 358: /remove0 {
! 359: /arg1 set
! 360: [/gb /ans /n] pushVariables
! 361: [
! 362: /gb arg1 def
! 363: /ans [
! 364: 0 1 << gb length 1 sub >> {
! 365: /n set
! 366: gb n get /ff set
! 367: ff (0). eq
! 368: { }
! 369: { ff } ifelse
! 370: } for
! 371: ] def
! 372: /arg1 ans def
! 373: ] pop
! 374: popVariables
! 375: arg1
! 376: } def
! 377:
! 378: % dehomogenize and obtain a minimal base
! 379: % in variables s,t,x,y,z,Dt,Dx,Dy,Dz
! 380: (Note that the current ring changes once you get a minimal base.) message
! 381: /minimal {
! 382: /arg1 set
! 383: [/gb /inits /ans /n /syzlist /cc /nin /aa /j /cj] pushVariables
! 384: [
! 385: /gb arg1 def
! 386: /inits gb {init} map def
! 387: gb {[[(h). (1).]] replace} map /gb set
! 388: [(Dx,Dy,Dz,Dt,t,x,y,z,s) ring_of_polynomials
! 389: ( ) elimination_order 0] define_ring
! 390: inits {mymap} map /inits set
! 391: gb {mymap} map /gb set
! 392: inits {[[(h). (1).]] replace} map /inits set
! 393: inits length /nin set
! 394: [inits [(needBack)]] groebner 1 get /syzlist set
! 395: syzlist length ::
! 396: /ans [
! 397: 0 1 << syzlist length 1 sub >> {
! 398: /n set
! 399: syzlist n get /cc set
! 400: (0). /gg set
! 401: 0 1 << nin 1 sub >> {
! 402: /j set
! 403: gb j get /aa set
! 404: cc j get /cj set
! 405: << cj aa mul >> gg add /gg set
! 406: } for
! 407: gg
! 408: } for
! 409: ] def
! 410: /ansmin ans def
! 411: ] pop
! 412: popVariables
! 413: ansmin
! 414: } def
! 415:
! 416: %%%%% The formal symbol %%%%%%%%%%%%%%%%%%%%%%
! 417: /fw_symbol {
! 418: [[(h). (1).]] replace (s). coefficients 1 get 0 get
! 419: } def
! 420:
! 421: %%%%% psi(P)(s) %%%%%%
! 422: /fw_psi {
! 423: fw_symbol /P set
! 424: P fw_order (integer) data_conversion /k set
! 425: << 1 1 k >>
! 426: {(t). P mul /P set pop}
! 427: for
! 428: << -1 -1 k >>
! 429: {(Dt). P mul /P set pop}
! 430: for
! 431: (0). /Q set
! 432: P (Dt). coefficients 0 get length /m set
! 433: 0 /i set
! 434: 1 1 m
! 435: {
! 436: P (Dt). coefficients 0 get i get /kk set
! 437: P (Dt). coefficients 1 get i get /PPt set
! 438: PPt (t). coefficients 1 get 0 get /PPC set
! 439: kk (integer) data_conversion /kk set
! 440: (s). /Ss set
! 441: 0 1 << kk 1 sub >> {
! 442: PPC Ss mul /PPC set
! 443: Ss (1). sub /Ss set
! 444: pop
! 445: } for
! 446: Q PPC add /Q set
! 447: i 1 add /i set
! 448: pop
! 449: } for
! 450: Q
! 451: } def
! 452:
! 453: /fw_psi0 {
! 454: fw_symbol /P set
! 455: P fw_order (integer) data_conversion /k set
! 456: << 1 1 k >>
! 457: {(t). P mul /P set pop}
! 458: for
! 459: (0). /Q set
! 460: P (Dt). coefficients 0 get length /m set
! 461: 0 /i set
! 462: 1 1 m
! 463: {
! 464: P (Dt). coefficients 0 get i get /kk set
! 465: P (Dt). coefficients 1 get i get /PPt set
! 466: PPt (t). coefficients 1 get 0 get /PPC set
! 467: kk (integer) data_conversion /kk set
! 468: (s). /Ss set
! 469: 0 1 << kk 1 sub >> {
! 470: PPC Ss mul /PPC set
! 471: Ss (1). sub /Ss set
! 472: pop
! 473: } for
! 474: Q PPC add /Q set
! 475: i 1 add /i set
! 476: pop
! 477: } for
! 478: Q
! 479: } def
! 480:
! 481: %%%%% rho(P)(s) %%%%%%
! 482: /fw_rho {
! 483: /P0 set
! 484: P0 fw_order (integer) data_conversion /k set
! 485: << 1 1 k >>
! 486: {(t). P0 mul /P0 set}
! 487: for
! 488: << -1 -1 k >>
! 489: {(Dt). P0 mul /P0 set}
! 490: for
! 491: P0 (s). coefficients 0 get /sdegs set
! 492: sdegs length /n set
! 493: sdegs 0 get (integer) data_conversion /k0 set
! 494: (0). /PP set
! 495: 0 /jj set
! 496: 0 1 << n 1 sub >>
! 497: {
! 498: sdegs jj get (integer) data_conversion /kkp set
! 499: P0 (s). coefficients 1 get jj get /Pj set
! 500: Pj fw_psi0 /Pj set
! 501: << 1 1 << k0 kkp sub >> >>
! 502: {Pj f mul /Pj set pop} for
! 503: k0 kkp sub /l set
! 504: Pj [[(s). << (-s-1). l . sub >> ]] replace /Pj set
! 505: PP Pj add /PP set
! 506: jj 1 add /jj set
! 507: pop
! 508: } for
! 509: PP [[(h). (1).]] replace /PP set
! 510: pop
! 511: PP
! 512: } def
! 513:
! 514: /fw_rhorest {
! 515: /P0 set
! 516: P0 fw_order (integer) data_conversion /k set
! 517: << 1 1 k >>
! 518: {(t). P0 mul /P0 set}
! 519: for
! 520: << -1 -1 k >>
! 521: {(Dt). P0 mul /P0 set}
! 522: for
! 523: P0 (s). coefficients 0 get /sdegs set
! 524: sdegs length /n set
! 525: sdegs 0 get (integer) data_conversion /k0 set
! 526: (0). /PP set
! 527: 1 /jj set
! 528: 1 1 << n 1 sub >>
! 529: {
! 530: sdegs jj get (integer) data_conversion /kkp set
! 531: P0 (s). coefficients 1 get jj get /Pj set
! 532: Pj fw_psi0 /Pj set
! 533: << 2 1 << k0 kkp sub >> >>
! 534: {Pj f mul /Pj set } for
! 535: k0 kkp sub /l set
! 536: Pj [[(s). << (-s-1). l . sub >> ]] replace /Pj set
! 537: PP Pj add /PP set
! 538: jj 1 add /jj set
! 539: } for
! 540: PP [[(h). (1).]] replace /PP set
! 541: (-1). PP mul /PP set
! 542: pop
! 543: PP
! 544: } def
! 545:
! 546: /fw_rhotest {
! 547: [(s,t,x,y,z) ring_of_differential_operators
! 548: [[(s) 1] ]
! 549: weight_vector 0 ] define_ring
! 550: (x^2-y^3). /f set
! 551: (t*Dt^2*s + t*Dt). /Pex set
! 552: Pex fw_rho /PPex set
! 553: PPex ::
! 554: } def
! 555:
! 556: %%%%%%%%%%%% [t - s*f, Dx + f_xDt, ...] %%%%%%%%%%%%%%%
! 557: /fw_delta {
! 558: /F set
! 559: << (Dx). F mul >> << F (Dx). mul >> sub [[(h). (1).]] replace /Fx set
! 560: << (Dy). F mul >> << F (Dy). mul >> sub [[(h). (1).]] replace /Fy set
! 561: << (Dz). F mul >> << F (Dz). mul >> sub [[(h). (1).]] replace /Fz set
! 562: (t). << (s). F mul >> sub /F0 set
! 563: (Dx). << (s*Dt). Fx mul >> add /Fx set
! 564: (Dy). << (s*Dt). Fy mul >> add /Fy set
! 565: (Dz). << (s*Dt). Fz mul >> add /Fz set
! 566: [ F0 Fx Fy Fz ]
! 567: } def
! 568:
! 569: %%%%%%%%%%%% [1-s*u,t - s*f, Dx + f_xDt, ...] %%%%%%%%%%%%%%%
! 570: /fw_deltasat {
! 571: /F set
! 572: << (Dx). F mul >> << F (Dx). mul >> sub [[(h). (1).]] replace /Fx set
! 573: << (Dy). F mul >> << F (Dy). mul >> sub [[(h). (1).]] replace /Fy set
! 574: << (Dz). F mul >> << F (Dz). mul >> sub [[(h). (1).]] replace /Fz set
! 575: (t). << (s). F mul >> sub /F0 set
! 576: (Dx). << (s*Dt). Fx mul >> add /Fx set
! 577: (Dy). << (s*Dt). Fy mul >> add /Fy set
! 578: (Dz). << (s*Dt). Fz mul >> add /Fz set
! 579: [ F0 Fx Fy Fz (1-s*u). ]
! 580: } def
! 581:
! 582: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 583: % convert to a Risa/Asir input file %
! 584: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 585: % (Varriable name) expression toa
! 586: /toa {
! 587: /expr set /Varname set
! 588: expr (string) data_conversion /expr set
! 589: (toa.t) (a) file /fd set
! 590: fd (Dx = dx$ Dy = dy$ Dz = dz$ Dt = dt$) writestring
! 591: fd Varname writestring
! 592: fd ( = ) writestring
! 593: fd expr writestring
! 594: fd ($) writestring
! 595: fd ( ) writestring
! 596: fd closefile
! 597: } def
! 598:
! 599: % (Varriable name) expression(list) toa_l
! 600: /toa_l {
! 601: /expr set /Varname set
! 602: (toa.t) (a) file /fd set
! 603: fd (Dx = dx$ Dy = dy$ Dz = dz$ Dt = dt$) writestring
! 604: fd 10 (string) data_conversion writestring
! 605: fd Varname writestring
! 606: fd ( = [ ) writestring
! 607: fd 10 (string) data_conversion writestring
! 608: expr length /n set
! 609: 0 1 << n 1 sub >> {
! 610: /k set
! 611: expr k get /expr1 set
! 612: expr1 (string) data_conversion /expr1 set
! 613: fd expr1 writestring
! 614: k << n 1 sub >> eq
! 615: {fd (]$ ) writestring }
! 616: {fd ( , ) writestring }
! 617: ifelse
! 618: fd 10 (string) data_conversion writestring
! 619: } for
! 620: fd closefile
! 621: } def
! 622:
! 623: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 624:
! 625: /mymap {
! 626: (string) data_conversion .
! 627: } def
! 628:
! 629: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 630: %% [ ] {outputans1} map ;
! 631: /outputans1 {
! 632: (t.t) (a) file /fd set
! 633: (string) data_conversion /tmp0 set
! 634: fd tmp0 writestring
! 635: fd ( ,) writestring
! 636: fd 10 (string) data_conversion writestring
! 637: fd closefile
! 638: } def
! 639:
! 640: %%%%%%%% Do not touch the below. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 641: [(position)
! 642: [(set element position number)
! 643: (Example: [(cat) (dog) (hot chocolate)] (cat) position ===> 0.)
! 644: ]
! 645: ] putUsages
! 646: /position {
! 647: /arg2 set /arg1 set
! 648: [/univ /elem /num /flag] pushVariables
! 649: [
! 650: /univ arg1 def
! 651: /elem arg2 def
! 652: /num -1 def /flag -1 def
! 653: 0 1 << univ length 1 sub >>
! 654: {
! 655: /num set
! 656: univ num get elem eq
! 657: { /flag 0 def exit }
! 658: { }
! 659: ifelse
! 660: } for
! 661: flag -1 eq
! 662: {/num -1 def}
! 663: { }
! 664: ifelse
! 665: ] pop
! 666: /arg1 num def
! 667: popVariables
! 668: arg1
! 669: } def
! 670:
! 671:
! 672: [(evecw)
! 673: [(size position weight evecw [0 0 ... 0 weight 0 ... 0] )
! 674: (Example: 3 0 113 evecw ===> [113 0 0])
! 675: ]
! 676: ] putUsages
! 677: /evecw {
! 678: /arg3 set /arg2 set /arg1 set
! 679: [/size /iii /www] pushVariables
! 680: /size arg1 def /iii arg2 def /www arg3 def
! 681: [
! 682: 0 1 << size 1 sub >>
! 683: {
! 684: iii eq
! 685: { www }
! 686: { 0 }
! 687: ifelse
! 688: } for
! 689: ] /arg1 set
! 690: popVariables
! 691: arg1
! 692: } def
! 693:
! 694: [(weight_vector)
! 695: [ ([x-list d-list params] [[(name) weight ...] [...] ...] weight_vector)
! 696: ([x-list d-list params order])
! 697: (Example:)
! 698: ( [(x,y,z) ring_of_polynomials [[(x) 100 (y) 10]] weight_vector 0] )
! 699: ( define_ring )
! 700: ]
! 701: ] putUsages
! 702: /weight_vector {
! 703: /arg2 set /arg1 set
! 704: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
! 705: /vars arg1 def /w-vectors arg2 def
! 706: [
! 707: /univ vars 0 get reverse
! 708: vars 1 get reverse join
! 709: def
! 710: [
! 711: 0 1 << w-vectors length 1 sub >>
! 712: {
! 713: /k set
! 714: univ w-vectors k get w_to_vec
! 715: } for
! 716: ] /order1 set
! 717: %% order1 ::
! 718:
! 719: vars ( ) elimination_order 3 get /order2 set
! 720: vars [ << order1 order2 join >> ] join /arg1 set
! 721: ] pop
! 722: popVariables
! 723: arg1
! 724: } def
! 725:
! 726: %% [(e) (x) (y) (h)] [(x) 100 (y) 10] w_to_vec [0 100 10 0]
! 727: %% univ www
! 728: /w_to_vec {
! 729: /arg2 set /arg1 set
! 730: [/univ /www /k /vname /vweight /ans] pushVariables
! 731: /univ arg1 def /www arg2 def
! 732: [
! 733: /ans << univ length >> -1 0 evecw def
! 734: 0 2 << www length 2 sub >>
! 735: {
! 736: %% ans ::
! 737: /k set
! 738: www k get /vname set
! 739: www << k 1 add >> get /vweight set
! 740: << univ length >>
! 741: << univ vname position >>
! 742: vweight evecw
! 743: ans add /ans set
! 744: } for
! 745: /arg1 ans def
! 746: ] pop
! 747: popVariables
! 748: arg1
! 749: } def
! 750:
! 751:
! 752: /fw_principal {
! 753: {[[(h). (1).]] replace} map {(s). coefficients 1 get 0 get} map
! 754: } def
! 755:
! 756:
! 757: %%%%%%%%%%%%%%%%%%%%%
! 758: % [g1 g2 g3 ...] var eliminate0
! 759: /eliminate0 {
! 760: /arg2 set /arg1 set
! 761: [/gb /degs /ans /n /var] pushVariables
! 762: [
! 763: /gb arg1 def
! 764: /var arg2 def
! 765: /degs gb {var . degree} map def
! 766: /ans [
! 767: 0 1 << gb length 1 sub >> {
! 768: /n set
! 769: << degs n get >> 0 eq
! 770: { gb n get /ff set
! 771: ff (0). eq
! 772: { }
! 773: { ff } ifelse
! 774: }
! 775: { } ifelse
! 776: } for
! 777: ] def
! 778: /arg1 ans def
! 779: ] pop
! 780: popVariables
! 781: arg1
! 782: } def
! 783:
! 784: % [g1 g2 g3 ...] var eliminate0
! 785: /eliminatepsi0 {
! 786: /arg2 set /arg1 set
! 787: [/gb /degs /ans /n /var] pushVariables
! 788: [
! 789: /gb arg1 def
! 790: /var arg2 def
! 791: /degs gb {fw_symbol} map {var . degree} map def
! 792: /ans [
! 793: 0 1 << gb length 1 sub >> {
! 794: /n set
! 795: << degs n get >> 0 eq
! 796: { gb n get /ff set
! 797: ff (0). eq
! 798: { }
! 799: { ff } ifelse
! 800: }
! 801: { } ifelse
! 802: } for
! 803: ] def
! 804: /arg1 ans def
! 805: ] pop
! 806: popVariables
! 807: arg1
! 808: } def
! 809:
! 810: %%%%%%%%% concatenate two lists %%%%%%%
! 811: /concat {
! 812: /listB set /listA set
! 813: listA length /NA set
! 814: listB length /NB set
! 815: /listAB [
! 816: 0 1 << NA 1 sub >> {
! 817: /n set
! 818: listA n get
! 819: } for
! 820: 0 1 << NB 1 sub >> {
! 821: /n set
! 822: listB n get
! 823: } for
! 824: ] def
! 825: listAB
! 826: } def
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to bfunc.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc / Old