Annotation of OpenXM/src/kan96xx/Kan/dr.sm1.old1, Revision 1.1
1.1 ! maekawa 1: %% dr.sm1 (Define Ring) 1994/9/25, 26
! 2:
! 3: (dr.sm1 Version 10/8/1994. ) message
! 4: %% n evenQ bool
! 5: /evenQ {
! 6: /arg1 set
! 7: arg1 2 idiv 2 mul arg1 sub 0 eq
! 8: { true }
! 9: { false } ifelse
! 10: } def
! 11:
! 12: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
! 13: /ring_of_polynomials {
! 14: /arg1 set
! 15: [/vars /n /i /xList /dList /param] pushVariables
! 16: %dup print (-----) message
! 17: [
! 18: (mmLarger) (matrix) switch_function
! 19: (mpMult) (poly) switch_function
! 20: (red@) (module1) switch_function
! 21: (groebner) (standard) switch_function
! 22:
! 23: [arg1 to_records pop] /vars set
! 24: vars length evenQ
! 25: { }
! 26: { vars [(PAD)] join /vars set }
! 27: ifelse
! 28: vars length 2 idiv /n set
! 29: [ << n 1 sub >> -1 0
! 30: { /i set
! 31: vars i get
! 32: } for
! 33: ] /xList set
! 34: [ << n 1 sub >> -1 0
! 35: { /i set
! 36: vars << i n add >> get
! 37: } for
! 38: ] /dList set
! 39:
! 40: [(H)] xList join [(e)] join /xList set
! 41: [(h)] dList join [(E)] join /dList set
! 42: [0 %% dummy characteristic
! 43: << xList length >> << xList length >> << xList length >>
! 44: << xList length >>
! 45: << xList length 1 sub >> << xList length >> << xList length >>
! 46: << xList length >>
! 47: ] /param set
! 48:
! 49: [xList dList param] /arg1 set
! 50: ] pop
! 51: popVariables
! 52: arg1
! 53: } def
! 54:
! 55: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
! 56: %% with no graduation and homogenization variables.
! 57: /ring_of_polynomials2 {
! 58: /arg1 set
! 59: [/vars /n /i /xList /dList /param] pushVariables
! 60: %dup print (-----) message
! 61: [
! 62: (mmLarger) (matrix) switch_function
! 63: (mpMult) (poly) switch_function
! 64: (red@) (module1) switch_function
! 65: (groebner) (standard) switch_function
! 66:
! 67: [arg1 to_records pop] /vars set
! 68: vars length evenQ
! 69: { }
! 70: { vars [(PAD)] join /vars set }
! 71: ifelse
! 72: vars length 2 idiv /n set
! 73: [ << n 1 sub >> -1 0
! 74: { /i set
! 75: vars i get
! 76: } for
! 77: ] /xList set
! 78: [ << n 1 sub >> -1 0
! 79: { /i set
! 80: vars << i n add >> get
! 81: } for
! 82: ] /dList set
! 83:
! 84: [0 %% dummy characteristic
! 85: << xList length >> << xList length >> << xList length >>
! 86: << xList length >>
! 87: << xList length >> << xList length >> << xList length >>
! 88: << xList length >>
! 89: ] /param set
! 90:
! 91: [xList dList param] /arg1 set
! 92: ] pop
! 93: popVariables
! 94: arg1
! 95: } def
! 96:
! 97: /ring_of_differential_operators {
! 98: /arg1 set
! 99: [/vars /n /i /xList /dList /param] pushVariables
! 100: [
! 101: (mmLarger) (matrix) switch_function
! 102: (mpMult) (diff) switch_function
! 103: (red@) (module1) switch_function
! 104: (groebner) (standard) switch_function
! 105:
! 106: [arg1 to_records pop] /vars set %[x y z]
! 107: vars reverse /xList set %[z y x]
! 108: vars {(D) 2 1 roll 2 cat_n} map
! 109: reverse /dList set %[Dz Dy Dx]
! 110: [(H)] xList join [(e)] join /xList set
! 111: [(h)] dList join [(E)] join /dList set
! 112: [0 1 1 1 << xList length >>
! 113: 1 1 1 << xList length 1 sub >> ] /param set
! 114: [ xList dList param ] /arg1 set
! 115: ] pop
! 116: popVariables
! 117: arg1
! 118: } def
! 119:
! 120: /ring_of_differential_operators3 {
! 121: %% with no homogenization variables.
! 122: /arg1 set
! 123: [/vars /n /i /xList /dList /param] pushVariables
! 124: [
! 125: (mmLarger) (matrix) switch_function
! 126: (mpMult) (diff) switch_function
! 127: (red@) (module1) switch_function
! 128: (groebner) (standard) switch_function
! 129:
! 130: [arg1 to_records pop] /vars set %[x y z]
! 131: vars reverse /xList set %[z y x]
! 132: vars {(D) 2 1 roll 2 cat_n} map
! 133: reverse /dList set %[Dz Dy Dx]
! 134: xList [(e)] join /xList set
! 135: dList [(E)] join /dList set
! 136: [0 0 0 0 << xList length >>
! 137: 0 0 0 << xList length 1 sub >> ] /param set
! 138: [ xList dList param ] /arg1 set
! 139: ] pop
! 140: popVariables
! 141: arg1
! 142: } def
! 143:
! 144: /ring_of_q_difference_operators {
! 145: /arg1 set
! 146: [/vars /n /i /xList /dList /param] pushVariables
! 147: [
! 148: (mmLarger) (qmatrix) switch_function
! 149: (mpMult) (diff) switch_function
! 150: (red@) (qmodule1) switch_function
! 151: (groebner) (standard) switch_function
! 152:
! 153: [arg1 to_records pop] /vars set %[x y z]
! 154: vars reverse /xList set %[z y x]
! 155: vars {(Q) 2 1 roll 2 cat_n} map
! 156: reverse /dList set %[Dz Dy Dx]
! 157: [(q)] xList join [(e)] join /xList set
! 158: [(h)] dList join [(E)] join /dList set
! 159: [0 1 << xList length >> << xList length >> << xList length >>
! 160: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
! 161: /param set
! 162: [ xList dList param ] /arg1 set
! 163: ] pop
! 164: popVariables
! 165: arg1
! 166: } def
! 167:
! 168: /ring_of_q_difference_operators3 {
! 169: %% with no homogenization and q variables.
! 170: /arg1 set
! 171: [/vars /n /i /xList /dList /param] pushVariables
! 172: [
! 173: (mmLarger) (qmatrix) switch_function
! 174: (mpMult) (diff) switch_function
! 175: (red@) (qmodule1) switch_function
! 176: (groebner) (standard) switch_function
! 177:
! 178: [arg1 to_records pop] /vars set %[x y z]
! 179: vars reverse /xList set %[z y x]
! 180: vars {(Q) 2 1 roll 2 cat_n} map
! 181: reverse /dList set %[Dz Dy Dx]
! 182: xList [(e)] join /xList set
! 183: dList [(E)] join /dList set
! 184: [0 0 << xList length >> << xList length >> << xList length >>
! 185: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
! 186: /param set
! 187: [ xList dList param ] /arg1 set
! 188: ] pop
! 189: popVariables
! 190: arg1
! 191: } def
! 192:
! 193: /reverse {
! 194: /arg1 set
! 195: arg1 length 1 lt
! 196: { [ ] }
! 197: {
! 198: [
! 199: << arg1 length 1 sub >> -1 0
! 200: {
! 201: arg1 2 1 roll get
! 202: } for
! 203: ]
! 204: } ifelse
! 205: } def
! 206:
! 207: /memberQ {
! 208: %% a set0 memberQ bool
! 209: /arg2 set /arg1 set
! 210: [/a /set0 /flag /i ] pushVariables
! 211: [
! 212: /a arg1 def /set0 arg2 def
! 213: /flag 0 def
! 214: 0 1 << set0 length 1 sub >>
! 215: {
! 216: /i set
! 217: << set0 i get >> a eq
! 218: {
! 219: /flag 1 def
! 220: }
! 221: { }
! 222: ifelse
! 223: } for
! 224: ] pop
! 225: /arg1 flag def
! 226: popVariables
! 227: arg1
! 228: } def
! 229:
! 230: /transpose {
! 231: %% mat transpose mat2
! 232: /arg1 set
! 233: [/i /j /m /n /flat /mat] pushVariables
! 234: [
! 235: /mat arg1 def
! 236: /n mat length def
! 237: /m mat 0 get length def
! 238:
! 239: [
! 240: 0 1 << n 1 sub >>
! 241: {
! 242: /i set
! 243: mat i get aload pop
! 244: } for
! 245: ] /flat set
! 246: %% [[1 2] [3 4]] ---> flat == [1 2 3 4]
! 247:
! 248: [
! 249: 0 1 << m 1 sub >>
! 250: {
! 251: /i set
! 252: [
! 253: 0 1 << n 1 sub >>
! 254: {
! 255: /j set
! 256: flat
! 257: << j m mul >> i add
! 258: get
! 259: } for
! 260: ]
! 261: } for
! 262: ] /arg1 set
! 263: ] pop
! 264: popVariables
! 265: arg1
! 266: } def
! 267:
! 268:
! 269: /getPerm {
! 270: %% old new getPerm perm
! 271: /arg2 set /arg1 set
! 272: [/old /new /i /j /p] pushVariables
! 273: [
! 274: /old arg1 def
! 275: /new arg2 def
! 276: [
! 277: /p old length def
! 278: 0 1 << p 1 sub >>
! 279: {
! 280: /i set
! 281: 0 1 << p 1 sub >>
! 282: {
! 283: /j set
! 284: old i get
! 285: new j get
! 286: eq
! 287: { j }
! 288: { } ifelse
! 289: } for
! 290: } for
! 291: ] /arg1 set
! 292: ] pop
! 293: popVariables
! 294: arg1
! 295: } def
! 296:
! 297: /permuteOrderMatrix {
! 298: %% order perm puermuteOrderMatrix newOrder
! 299: /arg2 set /arg1 set
! 300: [/order /perm /newOrder /k ] pushVariables
! 301: [
! 302: /order arg1 def
! 303: /perm arg2 def
! 304: order transpose /order set
! 305: order 1 copy /newOrder set pop
! 306:
! 307: 0 1 << perm length 1 sub >>
! 308: {
! 309: /k set
! 310: newOrder << perm k get >> << order k get >> put
! 311: } for
! 312: newOrder transpose /newOrder set
! 313: ] pop
! 314: /arg1 newOrder def
! 315: popVariables
! 316: arg1
! 317: } def
! 318:
! 319:
! 320:
! 321: /complement {
! 322: %% set0 universe complement compl
! 323: /arg2 set /arg1 set
! 324: [/set0 /universe /compl /i] pushVariables
! 325: /set0 arg1 def /universe arg2 def
! 326: [
! 327: 0 1 << universe length 1 sub >>
! 328: {
! 329: /i set
! 330: << universe i get >> set0 memberQ
! 331: { }
! 332: { universe i get }
! 333: ifelse
! 334: } for
! 335: ] /arg1 set
! 336: popVariables
! 337: arg1
! 338: } def
! 339:
! 340:
! 341: %%% from order.sm1
! 342:
! 343: %% size i evec [0 0 ... 0 1 0 ... 0]
! 344: /evec {
! 345: /arg2 set /arg1 set
! 346: [/size /iii] pushVariables
! 347: /size arg1 def /iii arg2 def
! 348: [
! 349: 0 1 << size 1 sub >>
! 350: {
! 351: iii eq
! 352: { 1 }
! 353: { 0 }
! 354: ifelse
! 355: } for
! 356: ] /arg1 set
! 357: popVariables
! 358: arg1
! 359: } def
! 360:
! 361: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
! 362: /evec_neg {
! 363: /arg2 set /arg1 set
! 364: [/size /iii] pushVariables
! 365: /size arg1 def /iii arg2 def
! 366: [
! 367: 0 1 << size 1 sub >>
! 368: {
! 369: iii eq
! 370: { -1 }
! 371: { 0 }
! 372: ifelse
! 373: } for
! 374: ] /arg1 set
! 375: popVariables
! 376: arg1
! 377: } def
! 378:
! 379:
! 380: %% size i j e_ij << matrix e(i,j) >>
! 381: /e_ij {
! 382: /arg3 set /arg2 set /arg1 set
! 383: [/size /k /i /j] pushVariables
! 384: [
! 385: /size arg1 def /i arg2 def /j arg3 def
! 386: [ 0 1 << size 1 sub >>
! 387: {
! 388: /k set
! 389: k i eq
! 390: { size j evec }
! 391: {
! 392: k j eq
! 393: { size i evec }
! 394: { size k evec }
! 395: ifelse
! 396: } ifelse
! 397: } for
! 398: ] /arg1 set
! 399: ] pop
! 400: popVariables
! 401: arg1
! 402: } def
! 403:
! 404:
! 405: %% m1 m2 oplus
! 406: /oplus {
! 407: /arg2 set /arg1 set
! 408: [/m1 /m2 /n /m /k ] pushVariables
! 409: [
! 410: /m1 arg1 def /m2 arg2 def
! 411: m1 length /n set
! 412: m2 length /m set
! 413: [
! 414: 0 1 << n m add 1 sub >>
! 415: {
! 416: /k set
! 417: k n lt
! 418: {
! 419: << m1 k get >> << m -1 evec >> join
! 420: }
! 421: {
! 422: << n -1 evec >> << m2 << k n sub >> get >> join
! 423: } ifelse
! 424: } for
! 425: ] /arg1 set
! 426: ] pop
! 427: popVariables
! 428: arg1
! 429: } def
! 430:
! 431: %%%%%%%%%%%%%%%%%%%%%%%
! 432:
! 433: /eliminationOrderTemplate { %% esize >= 1
! 434: %% if esize == 0, it returns reverse lexicographic order.
! 435: %% m esize eliminationOrderTemplate mat
! 436: /arg2 set /arg1 set
! 437: [/m /esize /m1 /m2 /k ] pushVariables
! 438: [
! 439: /m arg1 def /esize arg2 def
! 440: /m1 m esize sub 1 sub def
! 441: /m2 esize 1 sub def
! 442: [esize 0 gt
! 443: {
! 444: [1 1 esize
! 445: { pop 1 } for
! 446: esize 1 << m 1 sub >>
! 447: { pop 0 } for
! 448: ] %% 1st vector
! 449: }
! 450: { } ifelse
! 451:
! 452: m esize gt
! 453: {
! 454: [1 1 esize
! 455: { pop 0 } for
! 456: esize 1 << m 1 sub >>
! 457: { pop 1 } for
! 458: ] %% 2nd vector
! 459: }
! 460: { } ifelse
! 461:
! 462: m1 0 gt
! 463: {
! 464: m 1 sub -1 << m m1 sub >>
! 465: {
! 466: /k set
! 467: m k evec_neg
! 468: } for
! 469: }
! 470: { } ifelse
! 471:
! 472: m2 0 gt
! 473: {
! 474: << esize 1 sub >> -1 1
! 475: {
! 476: /k set
! 477: m k evec_neg
! 478: } for
! 479: }
! 480: { } ifelse
! 481:
! 482: ] /arg1 set
! 483: ] pop
! 484: popVariables
! 485: arg1
! 486: } def
! 487:
! 488:
! 489: /elimination_order {
! 490: %% [x-list d-list params] (x,y,z) elimination_order
! 491: %% vars evars
! 492: %% [x-list d-list params order]
! 493: /arg2 set /arg1 set
! 494: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 495: /vars arg1 def /evars [arg2 to_records pop] def
! 496: [
! 497: /univ vars 0 get reverse
! 498: vars 1 get reverse join
! 499: def
! 500:
! 501: << univ length 2 sub >>
! 502: << evars length >>
! 503: eliminationOrderTemplate /order set
! 504:
! 505: [[1]] order oplus [[1]] oplus /order set
! 506:
! 507: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
! 508:
! 509: /compl
! 510: [univ 0 get] evars join evars univ0 complement join
! 511: def
! 512: compl univ
! 513: getPerm /perm set
! 514: %%perm :: univ :: compl ::
! 515:
! 516: order perm permuteOrderMatrix /order set
! 517:
! 518: vars [order] join /arg1 set
! 519: ] pop
! 520: popVariables
! 521: arg1
! 522: } def
! 523:
! 524: /elimination_order2 {
! 525: %% [x-list d-list params] (x,y,z) elimination_order
! 526: %% vars evars
! 527: %% [x-list d-list params order]
! 528: %% with no graduation and homogenization variables.
! 529: /arg2 set /arg1 set
! 530: [/vars /evars /univ /order /perm /compl] pushVariables
! 531: /vars arg1 def /evars [arg2 to_records pop] def
! 532: [
! 533: /univ vars 0 get reverse
! 534: vars 1 get reverse join
! 535: def
! 536:
! 537: << univ length >>
! 538: << evars length >>
! 539: eliminationOrderTemplate /order set
! 540: /compl
! 541: evars << evars univ complement >> join
! 542: def
! 543: compl univ
! 544: getPerm /perm set
! 545: %%perm :: univ :: compl ::
! 546:
! 547: order perm permuteOrderMatrix /order set
! 548:
! 549: vars [order] join /arg1 set
! 550: ] pop
! 551: popVariables
! 552: arg1
! 553: } def
! 554:
! 555:
! 556: /elimination_order3 {
! 557: %% [x-list d-list params] (x,y,z) elimination_order
! 558: %% vars evars
! 559: %% [x-list d-list params order]
! 560: /arg2 set /arg1 set
! 561: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 562: /vars arg1 def /evars [arg2 to_records pop] def
! 563: [
! 564: /univ vars 0 get reverse
! 565: vars 1 get reverse join
! 566: def
! 567:
! 568: << univ length 1 sub >>
! 569: << evars length >>
! 570: eliminationOrderTemplate /order set
! 571:
! 572: [[1]] order oplus /order set
! 573:
! 574: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
! 575:
! 576: /compl
! 577: [univ 0 get] evars join evars univ0 complement join
! 578: def
! 579: compl univ
! 580: getPerm /perm set
! 581: %%perm :: univ :: compl ::
! 582:
! 583: order perm permuteOrderMatrix /order set
! 584:
! 585: vars [order] join /arg1 set
! 586: ] pop
! 587: popVariables
! 588: arg1
! 589: } def
! 590:
! 591:
! 592: /define_ring {
! 593: %[ (x,y,z) ring_of_polynominals
! 594: % (x,y) elimination_order
! 595: % 17
! 596: %] define_ring
! 597: /arg1 set
! 598: [/rp /param /foo] pushVariables
! 599: [/rp arg1 def
! 600: [
! 601: rp 0 get 0 get
! 602: rp 0 get 1 get
! 603: rp 0 get 2 get /param set
! 604: param 0 << rp 1 get >> put
! 605: param
! 606: rp 0 get 3 get
! 607: ] /foo set
! 608: foo aload pop set_up_ring@
! 609: ] pop
! 610: popVariables
! 611: } def
! 612:
! 613: /defineTests1 {
! 614: /test {
! 615: [[1 2 3]
! 616: [0 1 0]
! 617: [0 1 2]]
! 618: [0 2 1] permuteOrderMatrix ::
! 619: } def
! 620:
! 621: /test2 { (x,y,z) ring_of_polynomials (z,y) elimination_order /ans set } def
! 622:
! 623: /test3 {
! 624: [ (x,y,z) ring_of_polynomials
! 625: (x,y) elimination_order
! 626: 17
! 627: ] define_ring
! 628: } def
! 629:
! 630: /test4 {
! 631: [ (x,y,z) ring_of_polynomials
! 632: ( ) elimination_order
! 633: 17
! 634: ] define_ring
! 635: } def
! 636:
! 637: } def
! 638:
! 639: %% misterious bug (x,y) miss
! 640: /miss {
! 641: /arg1 set
! 642: %[/vars /n /i /xList /dList /param] pushVariables
! 643: [/vars /i] pushVariables
! 644: [ arg1 print
! 645: [arg1 to_records pop] /vars set
! 646:
! 647: ] pop
! 648: dup print
! 649: popVariables
! 650: arg1
! 651: } def
! 652:
! 653:
! 654: /lexicographicOrderTemplate {
! 655: % size lexicographicOrderTemplate matrix
! 656: /arg1 set
! 657: [/k /size] pushVariables
! 658: [
! 659: /size arg1 def
! 660: [ 0 1 << size 1 sub >>
! 661: {
! 662: /k set
! 663: size k evec
! 664: } for
! 665: ] /arg1 set
! 666: ] pop
! 667: popVariables
! 668: arg1
! 669: } def
! 670:
! 671: /lexicographic_order {
! 672: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 673: %% vars evars
! 674: %% [x-list d-list params order]
! 675: /arg2 set /arg1 set
! 676: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 677: /vars arg1 def /evars [arg2 to_records pop] def
! 678: [
! 679: /univ vars 0 get reverse
! 680: vars 1 get reverse join
! 681: def
! 682:
! 683: << univ length 2 sub >>
! 684: lexicographicOrderTemplate /order set
! 685:
! 686: [[1]] order oplus [[1]] oplus /order set
! 687:
! 688: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
! 689:
! 690: /compl
! 691: [univ 0 get] evars join evars univ0 complement join
! 692: def
! 693: compl univ
! 694: getPerm /perm set
! 695: %%perm :: univ :: compl ::
! 696:
! 697: order perm permuteOrderMatrix /order set
! 698:
! 699: vars [order] join /arg1 set
! 700: ] pop
! 701: popVariables
! 702: arg1
! 703: } def
! 704:
! 705: /lexicographic_order2 {
! 706: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 707: %% vars evars
! 708: %% [x-list d-list params order]
! 709: %% with no graduation and homogenization variables
! 710: /arg2 set /arg1 set
! 711: [/vars /evars /univ /order /perm /compl] pushVariables
! 712: /vars arg1 def /evars [arg2 to_records pop] def
! 713: [
! 714: /univ vars 0 get reverse
! 715: vars 1 get reverse join
! 716: def
! 717:
! 718: << univ length >>
! 719: lexicographicOrderTemplate /order set
! 720:
! 721: /compl
! 722: evars << evars univ complement >> join
! 723: def
! 724: compl univ
! 725: getPerm /perm set
! 726:
! 727: order perm permuteOrderMatrix /order set
! 728:
! 729: vars [order] join /arg1 set
! 730: ] pop
! 731: popVariables
! 732: arg1
! 733: } def
! 734:
! 735: /lexicographic_order3 {
! 736: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 737: %% vars evars
! 738: %% [x-list d-list params order]
! 739: %% with no homogenization variable.
! 740: /arg2 set /arg1 set
! 741: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 742: /vars arg1 def /evars [arg2 to_records pop] def
! 743: [
! 744: /univ vars 0 get reverse
! 745: vars 1 get reverse join
! 746: def
! 747:
! 748: << univ length 1 sub >>
! 749: lexicographicOrderTemplate /order set
! 750:
! 751: [[1]] order oplus /order set
! 752:
! 753: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
! 754:
! 755: /compl
! 756: [univ 0 get] evars join evars univ0 complement join
! 757: def
! 758: compl univ
! 759: getPerm /perm set
! 760: %%perm :: univ :: compl ::
! 761:
! 762: order perm permuteOrderMatrix /order set
! 763:
! 764: vars [order] join /arg1 set
! 765: ] pop
! 766: popVariables
! 767: arg1
! 768: } def
! 769:
! 770: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
! 771:
! 772:
! 773: /getX {
! 774: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
! 775: /arg2 set /arg1 set
! 776: [/k /param /func /low /top] pushVariables
! 777: [
! 778: /param arg1 def /func arg2 def
! 779: func 1 eq
! 780: {
! 781: /low 0 def
! 782: }
! 783: {
! 784: /low << param 2 get >> << func 1 sub >> get def
! 785: } ifelse
! 786: /top << param 2 get >> << func 4 add >> get 1 sub def
! 787: [
! 788: low 1 top
! 789: {
! 790: /k set
! 791: param 0 get k get
! 792: } for
! 793: ] /arg1 set
! 794: ] pop
! 795: popVariables
! 796: arg1
! 797: } def
! 798:
! 799: /getD {
! 800: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
! 801: /arg2 set /arg1 set
! 802: [/k /param /func /low /top] pushVariables
! 803: [
! 804: /param arg1 def /func arg2 def
! 805: func 1 eq
! 806: {
! 807: /low 0 def
! 808: }
! 809: {
! 810: /low << param 2 get >> << func 1 sub >> get def
! 811: } ifelse
! 812: /top << param 2 get >> << func 4 add >> get 1 sub def
! 813: [
! 814: low 1 top
! 815: {
! 816: /k set
! 817: param 1 get k get
! 818: } for
! 819: ] /arg1 set
! 820: ] pop
! 821: popVariables
! 822: arg1
! 823: } def
! 824:
! 825: /getXV {
! 826: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
! 827: /arg2 set /arg1 set
! 828: [/k /param /func /low /top] pushVariables
! 829: [
! 830: /param arg1 def /func arg2 def
! 831: /low << param 2 get >> << func 4 add >> get def
! 832: /top << param 2 get >> func get 1 sub def
! 833: [
! 834: low 1 top
! 835: {
! 836: /k set
! 837: param 0 get k get
! 838: } for
! 839: ] /arg1 set
! 840: ] pop
! 841: popVariables
! 842: arg1
! 843: } def
! 844:
! 845: /getDV {
! 846: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
! 847: /arg2 set /arg1 set
! 848: [/k /param /func /low /top] pushVariables
! 849: [
! 850: /param arg1 def /func arg2 def
! 851: /low << param 2 get >> << func 4 add >> get def
! 852: /top << param 2 get >> func get 1 sub def
! 853: [
! 854: low 1 top
! 855: {
! 856: /k set
! 857: param 1 get k get
! 858: } for
! 859: ] /arg1 set
! 860: ] pop
! 861: popVariables
! 862: arg1
! 863: } def
! 864:
! 865: /reNaming {
! 866: %% It also changes oldx2 and oldd2, which are globals.
! 867: /arg1 set
! 868: [/i /j /new /count /ostr /k] pushVariables
! 869: [
! 870: /new arg1 def
! 871: /count 0 def
! 872: 0 1 << new length 1 sub >> {
! 873: /i set
! 874: << i 1 add >> 1 << new length 1 sub >> {
! 875: /j set
! 876: << new i get >> << new j get >> eq
! 877: {
! 878: new j get /ostr set
! 879: (The two rings have the same name :) messagen
! 880: new i get messagen (.) message
! 881: (The name ) messagen
! 882: new i get messagen ( is changed into ) messagen
! 883: new j << new i get << 48 count add $string$ data_conversion >>
! 884: 2 cat_n >> put
! 885: new j get messagen (.) message
! 886: /oldx2 ostr << new j get >> reNaming2
! 887: /oldd2 ostr << new j get >> reNaming2
! 888: /count count 1 add def
! 889: }
! 890: { }
! 891: ifelse
! 892: } for
! 893: } for
! 894: /arg1 new def
! 895: ] pop
! 896: popVariables
! 897: arg1
! 898: } def
! 899:
! 900: /reNaming2 {
! 901: %% array oldString newString reNaming2
! 902: %% /aa (x) (y) reNaming2
! 903: /arg3 set /arg2 set /arg1 set
! 904: [/array /oldString /newString /k] pushVariables
! 905: [
! 906: /array arg1 def /oldString arg2 def /newString arg3 def
! 907: 0 1 << array load length 1 sub >>
! 908: {
! 909: /k set
! 910: << array load k get >> oldString eq
! 911: {
! 912: array load k newString put
! 913: }
! 914: { } ifelse
! 915: } for
! 916: ] pop
! 917: popVariables
! 918: } def
! 919:
! 920: /add_rings {
! 921: /arg2 set /arg1 set
! 922: [/param1 /param2
! 923: /newx /newd /newv
! 924: /k /const /od1 /od2 /od
! 925: /oldx2 /oldd2 % these will be changed in reNaming.
! 926: /oldv
! 927: ] pushVariables
! 928: [
! 929: /param1 arg1 def /param2 arg2 def
! 930: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 931: /newx
! 932: [ ]
! 933: param2 1 getX join param1 1 getX join
! 934: param2 1 getXV join param1 1 getXV join
! 935:
! 936: param2 2 getX join param1 2 getX join
! 937: param2 2 getXV join param1 2 getXV join
! 938:
! 939: param2 3 getX join param1 3 getX join
! 940: param2 3 getXV join param1 3 getXV join
! 941:
! 942: param2 4 getX join param1 4 getX join
! 943: param2 4 getXV join param1 4 getXV join
! 944: def
! 945: /newd
! 946: [ ]
! 947: param2 1 getD join param1 1 getD join
! 948: param2 1 getDV join param1 1 getDV join
! 949:
! 950: param2 2 getD join param1 2 getD join
! 951: param2 2 getDV join param1 2 getDV join
! 952:
! 953: param2 3 getD join param1 3 getD join
! 954: param2 3 getDV join param1 3 getDV join
! 955:
! 956: param2 4 getD join param1 4 getD join
! 957: param2 4 getDV join param1 4 getDV join
! 958: def
! 959:
! 960: /newv newx newd join def
! 961: /oldx2 param2 0 get def /oldd2 param2 1 get def
! 962: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
! 963: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
! 964: /newv newv reNaming def
! 965:
! 966: /newx [
! 967: 0 1 << newv length 2 idiv 1 sub >>
! 968: {
! 969: /k set
! 970: newv k get
! 971: } for
! 972: ] def
! 973: /newd [
! 974: 0 1 << newv length 2 idiv 1 sub >>
! 975: {
! 976: /k set
! 977: newv << newv length 2 idiv k add >> get
! 978: } for
! 979: ] def
! 980: /const [
! 981: << param1 2 get 0 get >>
! 982: << param1 2 get 1 get param2 2 get 1 get add >>
! 983: << param1 2 get 2 get param2 2 get 2 get add >>
! 984: << param1 2 get 3 get param2 2 get 3 get add >>
! 985: << param1 2 get 4 get param2 2 get 4 get add >>
! 986: << param1 2 get 5 get param2 2 get 5 get add >>
! 987: << param1 2 get 6 get param2 2 get 6 get add >>
! 988: << param1 2 get 7 get param2 2 get 7 get add >>
! 989: << param1 2 get 8 get param2 2 get 8 get add >>
! 990: ] def
! 991:
! 992: /od1 param1 3 get def /od2 param2 3 get def
! 993: od1 od2 oplus /od set
! 994:
! 995: %%oldx2 :: oldd2 ::
! 996: << param1 0 get reverse >> << param1 1 get reverse >> join
! 997: << oldx2 reverse >> << oldd2 reverse >> join
! 998: join /oldv set
! 999:
! 1000:
! 1001: od << oldv << newx reverse newd reverse join >> getPerm >>
! 1002: permuteOrderMatrix /od set
! 1003:
! 1004: /arg1 [newx newd const od] def
! 1005: ] pop
! 1006: popVariables
! 1007: arg1
! 1008: } def
! 1009:
! 1010:
! 1011: /test5 {
! 1012: (t) ring_of_polynomials ( ) elimination_order /r1 set
! 1013: (x) ring_of_differential_operators (Dx) elimination_order /r2 set
! 1014: r2 r1 add_rings
! 1015: } def
! 1016:
! 1017: /test6 {
! 1018: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
! 1019: (x,y,z) ring_of_polynomials2 (x,y) elimination_order2 /r1 set
! 1020: (t) ring_of_differential_operators3 (Dt) elimination_order3 /r2 set
! 1021: [r2 r1 add_rings r0 add_rings 0] define_ring
! 1022: } def
! 1023:
! 1024: /test7 {
! 1025: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
! 1026: (a,b,c,cp) ring_of_polynomials2 ( ) elimination_order2 /r1 set
! 1027: (x,y) ring_of_differential_operators3 (Dx,Dy) elimination_order3 /r2 set
! 1028: [r2 r1 add_rings r0 add_rings 0] define_ring
! 1029: [(Dx (x Dx + c-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).
! 1030: (Dy (y Dy + cp-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).] /ff set
! 1031: ff {[[$h$. $1$.]] replace} map homogenize /ff set
! 1032: } def
! 1033: %%%% end of add_rings
! 1034:
! 1035: ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to dr.sm1.old1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Kan