Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.1
1.1 ! maekawa 1: %% dr.sm1 (Define Ring) 1994/9/25, 26
! 2: %% This file is error clean.
! 3:
! 4: @@@.quiet { }
! 5: { (macro package : dr.sm1, 9/26,1995 --- Version 9/8, 1999. ) message } ifelse
! 6:
! 7: /ctrlC-hook {
! 8: %%% define your own routing in case of error.
! 9: } def
! 10: [(ctrlC-hook)
! 11: [(When ctrl-C is pressed, this function is executed.)
! 12: (User can define one's own ctrlC-hook function.)
! 13: ]] putUsages
! 14:
! 15: %% n evenQ bool
! 16: /evenQ {
! 17: /arg1 set
! 18: arg1 2 idiv 2 mul arg1 sub 0 eq
! 19: { true }
! 20: { false } ifelse
! 21: } def
! 22:
! 23: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
! 24: /ring_of_polynomials {
! 25: /arg1 set
! 26: [/vars /n /i /xList /dList /param] pushVariables
! 27: %dup print (-----) message
! 28: [
! 29: (mmLarger) (matrix) switch_function
! 30: (mpMult) (poly) switch_function
! 31: (red@) (module1) switch_function
! 32: (groebner) (standard) switch_function
! 33: (isSameComponent) (x) switch_function
! 34:
! 35: [arg1 to_records pop] /vars set
! 36: vars length evenQ
! 37: { }
! 38: { vars [(PAD)] join /vars set }
! 39: ifelse
! 40: vars length 2 idiv /n set
! 41: [ << n 1 sub >> -1 0
! 42: { /i set
! 43: vars i get
! 44: } for
! 45: ] /xList set
! 46: [ << n 1 sub >> -1 0
! 47: { /i set
! 48: vars << i n add >> get
! 49: } for
! 50: ] /dList set
! 51:
! 52: [(H)] xList join [@@@.esymbol] join /xList set
! 53: [(h)] dList join [@@@.Esymbol] join /dList set
! 54: [0 %% dummy characteristic
! 55: << xList length >> << xList length >> << xList length >>
! 56: << xList length >>
! 57: << xList length 1 sub >> << xList length >> << xList length >>
! 58: << xList length >>
! 59: ] /param set
! 60:
! 61: [xList dList param] /arg1 set
! 62: ] pop
! 63: popVariables
! 64: arg1
! 65: } def
! 66:
! 67: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
! 68: %% with no graduation and homogenization variables.
! 69: /ring_of_polynomials2 {
! 70: /arg1 set
! 71: [/vars /n /i /xList /dList /param] pushVariables
! 72: %dup print (-----) message
! 73: [
! 74: (mmLarger) (matrix) switch_function
! 75: (mpMult) (poly) switch_function
! 76: (red@) (module1) switch_function
! 77: (groebner) (standard) switch_function
! 78: (isSameComponent) (x) switch_function
! 79:
! 80: [arg1 to_records pop] /vars set
! 81: vars length evenQ
! 82: { }
! 83: { vars [(PAD)] join /vars set }
! 84: ifelse
! 85: vars length 2 idiv /n set
! 86: [ << n 1 sub >> -1 0
! 87: { /i set
! 88: vars i get
! 89: } for
! 90: ] /xList set
! 91: [ << n 1 sub >> -1 0
! 92: { /i set
! 93: vars << i n add >> get
! 94: } for
! 95: ] /dList set
! 96:
! 97: [0 %% dummy characteristic
! 98: << xList length >> << xList length >> << xList length >>
! 99: << xList length >>
! 100: << xList length >> << xList length >> << xList length >>
! 101: << xList length >>
! 102: ] /param set
! 103:
! 104: [xList dList param] /arg1 set
! 105: ] pop
! 106: popVariables
! 107: arg1
! 108: } def
! 109:
! 110: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
! 111: %% with no homogenization variables.
! 112: /ring_of_polynomials3 {
! 113: /arg1 set
! 114: [/vars /n /i /xList /dList /param] pushVariables
! 115: %dup print (-----) message
! 116: [
! 117: (mmLarger) (matrix) switch_function
! 118: (mpMult) (poly) switch_function
! 119: (red@) (module1) switch_function
! 120: (groebner) (standard) switch_function
! 121: (isSameComponent) (x) switch_function
! 122:
! 123: [arg1 to_records pop] /vars set
! 124: vars length evenQ
! 125: { }
! 126: { vars [(PAD)] join /vars set }
! 127: ifelse
! 128: vars length 2 idiv /n set
! 129: [ << n 1 sub >> -1 0
! 130: { /i set
! 131: vars i get
! 132: } for
! 133: ] /xList set
! 134: xList [@@@.esymbol] join /xList set
! 135: [ << n 1 sub >> -1 0
! 136: { /i set
! 137: vars << i n add >> get
! 138: } for
! 139: ] /dList set
! 140: dList [@@@.Esymbol] join /dList set
! 141:
! 142: [0 %% dummy characteristic
! 143: << xList length >> << xList length >> << xList length >>
! 144: << xList length >>
! 145: << xList length >> << xList length >> << xList length >>
! 146: << xList length >>
! 147: ] /param set
! 148:
! 149: [xList dList param] /arg1 set
! 150: ] pop
! 151: popVariables
! 152: arg1
! 153: } def
! 154:
! 155: /ring_of_differential_operators {
! 156: /arg1 set
! 157: [/vars /n /i /xList /dList /param] pushVariables
! 158: [
! 159: (mmLarger) (matrix) switch_function
! 160: (mpMult) (diff) switch_function
! 161: (red@) (module1) switch_function
! 162: (groebner) (standard) switch_function
! 163: (isSameComponent) (x) switch_function
! 164:
! 165: [arg1 to_records pop] /vars set %[x y z]
! 166: vars reverse /xList set %[z y x]
! 167: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
! 168: reverse /dList set %[Dz Dy Dx]
! 169: [(H)] xList join [@@@.esymbol] join /xList set
! 170: [(h)] dList join [@@@.Esymbol] join /dList set
! 171: [0 1 1 1 << xList length >>
! 172: 1 1 1 << xList length 1 sub >> ] /param set
! 173: [ xList dList param ] /arg1 set
! 174: ] pop
! 175: popVariables
! 176: arg1
! 177: } def
! 178:
! 179: /ring_of_differential_operators3 {
! 180: %% with no homogenization variables.
! 181: /arg1 set
! 182: [/vars /n /i /xList /dList /param] pushVariables
! 183: [
! 184: (mmLarger) (matrix) switch_function
! 185: (mpMult) (diff) switch_function
! 186: (red@) (module1) switch_function
! 187: (groebner) (standard) switch_function
! 188: (isSameComponent) (x) switch_function
! 189:
! 190: [arg1 to_records pop] /vars set %[x y z]
! 191: vars reverse /xList set %[z y x]
! 192: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
! 193: reverse /dList set %[Dz Dy Dx]
! 194: xList [@@@.esymbol] join /xList set
! 195: dList [@@@.Esymbol] join /dList set
! 196: [0 0 0 0 << xList length >>
! 197: 0 0 0 << xList length 1 sub >> ] /param set
! 198: [ xList dList param ] /arg1 set
! 199: ] pop
! 200: popVariables
! 201: arg1
! 202: } def
! 203:
! 204: /ring_of_q_difference_operators {
! 205: /arg1 set
! 206: [/vars /n /i /xList /dList /param] pushVariables
! 207: [
! 208: (mmLarger) (matrix) switch_function
! 209: (mpMult) (diff) switch_function
! 210: (red@) (module1) switch_function
! 211: (groebner) (standard) switch_function
! 212: (isSameComponent) (x) switch_function
! 213:
! 214: [arg1 to_records pop] /vars set %[x y z]
! 215: vars reverse /xList set %[z y x]
! 216: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
! 217: reverse /dList set %[Dz Dy Dx]
! 218: [(q)] xList join [@@@.esymbol] join /xList set
! 219: [(h)] dList join [@@@.Esymbol] join /dList set
! 220: [0 1 << xList length >> << xList length >> << xList length >>
! 221: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
! 222: /param set
! 223: [ xList dList param ] /arg1 set
! 224: ] pop
! 225: popVariables
! 226: arg1
! 227: } def
! 228:
! 229: /ring_of_q_difference_operators3 {
! 230: %% with no homogenization and q variables.
! 231: /arg1 set
! 232: [/vars /n /i /xList /dList /param] pushVariables
! 233: [
! 234: (mmLarger) (matrix) switch_function
! 235: (mpMult) (diff) switch_function
! 236: (red@) (module1) switch_function
! 237: (groebner) (standard) switch_function
! 238: (isSameComponent) (x) switch_function
! 239:
! 240: [arg1 to_records pop] /vars set %[x y z]
! 241: vars reverse /xList set %[z y x]
! 242: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
! 243: reverse /dList set %[Dz Dy Dx]
! 244: xList [@@@.esymbol] join /xList set
! 245: dList [@@@.Esymbol] join /dList set
! 246: [0 0 << xList length >> << xList length >> << xList length >>
! 247: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
! 248: /param set
! 249: [ xList dList param ] /arg1 set
! 250: ] pop
! 251: popVariables
! 252: arg1
! 253: } def
! 254:
! 255: /ring_of_difference_operators {
! 256: /arg1 set
! 257: [/vars /n /i /xList /dList /param] pushVariables
! 258: [
! 259: (mmLarger) (matrix) switch_function
! 260: (mpMult) (difference) switch_function
! 261: (red@) (module1) switch_function
! 262: (groebner) (standard) switch_function
! 263: (isSameComponent) (x) switch_function
! 264:
! 265: [arg1 to_records pop] /vars set %[x y z]
! 266: vars reverse /xList set %[z y x]
! 267: vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
! 268: reverse /dList set %[Dz Dy Dx]
! 269: [(H)] xList join [@@@.esymbol] join /xList set
! 270: [(h)] dList join [@@@.Esymbol] join /dList set
! 271: [0 1 1 << xList length >> << xList length >>
! 272: 1 1 << xList length 1 sub >> << xList length >> ] /param set
! 273: [ xList dList param ] /arg1 set
! 274: ] pop
! 275: popVariables
! 276: arg1
! 277: } def
! 278:
! 279:
! 280:
! 281: /reverse {
! 282: /arg1 set
! 283: arg1 length 1 lt
! 284: { [ ] }
! 285: {
! 286: [
! 287: << arg1 length 1 sub >> -1 0
! 288: {
! 289: arg1 2 1 roll get
! 290: } for
! 291: ]
! 292: } ifelse
! 293: } def
! 294:
! 295: /memberQ {
! 296: %% a set0 memberQ bool
! 297: /arg2 set /arg1 set
! 298: [/a /set0 /flag /i ] pushVariables
! 299: [
! 300: /a arg1 def /set0 arg2 def
! 301: /flag 0 def
! 302: 0 1 << set0 length 1 sub >>
! 303: {
! 304: /i set
! 305: << set0 i get >> a eq
! 306: {
! 307: /flag 1 def
! 308: }
! 309: { }
! 310: ifelse
! 311: } for
! 312: ] pop
! 313: /arg1 flag def
! 314: popVariables
! 315: arg1
! 316: } def
! 317:
! 318: /transpose {
! 319: /arg1 set
! 320: [/mat /m /n /ans /i /j] pushVariables
! 321: [
! 322: /mat arg1 def
! 323: /m mat length def
! 324: mat 0 get isArray
! 325: { }
! 326: { (transpose: Argument must be an array of arrays.) error }
! 327: ifelse
! 328: /n mat 0 get length def
! 329: /ans [ 1 1 n { pop [ 1 1 m { pop 0 } for ]} for ] def
! 330: 0 1 << m 1 sub >> {
! 331: /i set
! 332: 0 1 << n 1 sub >> {
! 333: /j set
! 334: ans [ j i ] << mat i get j get >> put
! 335: } for
! 336: } for
! 337: /arg1 ans def
! 338: ] pop
! 339: popVariables
! 340: arg1
! 341: } def
! 342:
! 343:
! 344: /getPerm {
! 345: %% old new getPerm perm
! 346: /arg2 set /arg1 set
! 347: [/old /new /i /j /p] pushVariables
! 348: [
! 349: /old arg1 def
! 350: /new arg2 def
! 351: [
! 352: /p old length def
! 353: 0 1 << p 1 sub >>
! 354: {
! 355: /i set
! 356: 0 1 << p 1 sub >>
! 357: {
! 358: /j set
! 359: old i get
! 360: new j get
! 361: eq
! 362: { j }
! 363: { } ifelse
! 364: } for
! 365: } for
! 366: ] /arg1 set
! 367: ] pop
! 368: popVariables
! 369: arg1
! 370: } def
! 371:
! 372: /permuteOrderMatrix {
! 373: %% order perm puermuteOrderMatrix newOrder
! 374: /arg2 set /arg1 set
! 375: [/order /perm /newOrder /k ] pushVariables
! 376: [
! 377: /order arg1 def
! 378: /perm arg2 def
! 379: order transpose /order set
! 380: order 1 copy /newOrder set pop
! 381:
! 382: 0 1 << perm length 1 sub >>
! 383: {
! 384: /k set
! 385: newOrder << perm k get >> << order k get >> put
! 386: } for
! 387: newOrder transpose /newOrder set
! 388: ] pop
! 389: /arg1 newOrder def
! 390: popVariables
! 391: arg1
! 392: } def
! 393:
! 394:
! 395:
! 396: /complement {
! 397: %% set0 universe complement compl
! 398: /arg2 set /arg1 set
! 399: [/set0 /universe /compl /i] pushVariables
! 400: /set0 arg1 def /universe arg2 def
! 401: [
! 402: 0 1 << universe length 1 sub >>
! 403: {
! 404: /i set
! 405: << universe i get >> set0 memberQ
! 406: { }
! 407: { universe i get }
! 408: ifelse
! 409: } for
! 410: ] /arg1 set
! 411: popVariables
! 412: arg1
! 413: } def
! 414:
! 415:
! 416: %%% from order.sm1
! 417:
! 418: %% size i evec [0 0 ... 0 1 0 ... 0]
! 419: /evec {
! 420: /arg2 set /arg1 set
! 421: [/size /iii] pushVariables
! 422: /size arg1 def /iii arg2 def
! 423: [
! 424: 0 1 << size 1 sub >>
! 425: {
! 426: iii eq
! 427: { 1 }
! 428: { 0 }
! 429: ifelse
! 430: } for
! 431: ] /arg1 set
! 432: popVariables
! 433: arg1
! 434: } def
! 435:
! 436: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
! 437: /evec_neg {
! 438: /arg2 set /arg1 set
! 439: [/size /iii] pushVariables
! 440: /size arg1 def /iii arg2 def
! 441: [
! 442: 0 1 << size 1 sub >>
! 443: {
! 444: iii eq
! 445: { -1 }
! 446: { 0 }
! 447: ifelse
! 448: } for
! 449: ] /arg1 set
! 450: popVariables
! 451: arg1
! 452: } def
! 453:
! 454:
! 455: %% size i j e_ij << matrix e(i,j) >>
! 456: /e_ij {
! 457: /arg3 set /arg2 set /arg1 set
! 458: [/size /k /i /j] pushVariables
! 459: [
! 460: /size arg1 def /i arg2 def /j arg3 def
! 461: [ 0 1 << size 1 sub >>
! 462: {
! 463: /k set
! 464: k i eq
! 465: { size j evec }
! 466: {
! 467: k j eq
! 468: { size i evec }
! 469: { size k evec }
! 470: ifelse
! 471: } ifelse
! 472: } for
! 473: ] /arg1 set
! 474: ] pop
! 475: popVariables
! 476: arg1
! 477: } def
! 478:
! 479:
! 480: %% size i j d_ij << matrix E_{ij} >>
! 481: /d_ij {
! 482: /arg3 set /arg2 set /arg1 set
! 483: [/size /k /i /j] pushVariables
! 484: [
! 485: /size arg1 def /i arg2 def /j arg3 def
! 486: [ 0 1 << size 1 sub >>
! 487: {
! 488: /k set
! 489: k i eq
! 490: { size j evec }
! 491: {
! 492: [ 0 1 << size 1 sub >> { pop 0} for ]
! 493: } ifelse
! 494: } for
! 495: ] /arg1 set
! 496: ] pop
! 497: popVariables
! 498: arg1
! 499: } def
! 500:
! 501: %% size matid << id matrix >>
! 502: /matid {
! 503: /arg1 set
! 504: [/size /k ] pushVariables
! 505: [
! 506: /size arg1 def
! 507: [ 0 1 << size 1 sub >>
! 508: {
! 509: /k set
! 510: size k evec
! 511: } for
! 512: ] /arg1 set
! 513: ] pop
! 514: popVariables
! 515: arg1
! 516: } def
! 517:
! 518:
! 519: %% m1 m2 oplus
! 520: /oplus {
! 521: /arg2 set /arg1 set
! 522: [/m1 /m2 /n /m /k ] pushVariables
! 523: [
! 524: /m1 arg1 def /m2 arg2 def
! 525: m1 length /n set
! 526: m2 length /m set
! 527: [
! 528: 0 1 << n m add 1 sub >>
! 529: {
! 530: /k set
! 531: k n lt
! 532: {
! 533: << m1 k get >> << m -1 evec >> join
! 534: }
! 535: {
! 536: << n -1 evec >> << m2 << k n sub >> get >> join
! 537: } ifelse
! 538: } for
! 539: ] /arg1 set
! 540: ] pop
! 541: popVariables
! 542: arg1
! 543: } def
! 544:
! 545: %%%%%%%%%%%%%%%%%%%%%%%
! 546:
! 547: /eliminationOrderTemplate { %% esize >= 1
! 548: %% if esize == 0, it returns reverse lexicographic order.
! 549: %% m esize eliminationOrderTemplate mat
! 550: /arg2 set /arg1 set
! 551: [/m /esize /m1 /m2 /k ] pushVariables
! 552: [
! 553: /m arg1 def /esize arg2 def
! 554: /m1 m esize sub 1 sub def
! 555: /m2 esize 1 sub def
! 556: [esize 0 gt
! 557: {
! 558: [1 1 esize
! 559: { pop 1 } for
! 560: esize 1 << m 1 sub >>
! 561: { pop 0 } for
! 562: ] %% 1st vector
! 563: }
! 564: { } ifelse
! 565:
! 566: m esize gt
! 567: {
! 568: [1 1 esize
! 569: { pop 0 } for
! 570: esize 1 << m 1 sub >>
! 571: { pop 1 } for
! 572: ] %% 2nd vector
! 573: }
! 574: { } ifelse
! 575:
! 576: m1 0 gt
! 577: {
! 578: m 1 sub -1 << m m1 sub >>
! 579: {
! 580: /k set
! 581: m k evec_neg
! 582: } for
! 583: }
! 584: { } ifelse
! 585:
! 586: m2 0 gt
! 587: {
! 588: << esize 1 sub >> -1 1
! 589: {
! 590: /k set
! 591: m k evec_neg
! 592: } for
! 593: }
! 594: { } ifelse
! 595:
! 596: ] /arg1 set
! 597: ] pop
! 598: popVariables
! 599: arg1
! 600: } def
! 601:
! 602: /elimination_order {
! 603: %% [x-list d-list params] (x,y,z) elimination_order
! 604: %% vars evars
! 605: %% [x-list d-list params order]
! 606: /arg2 set /arg1 set
! 607: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 608: /vars arg1 def /evars [arg2 to_records pop] def
! 609: [
! 610: /univ vars 0 get reverse
! 611: vars 1 get reverse join
! 612: def
! 613:
! 614: << univ length 2 sub >>
! 615: << evars length >>
! 616: eliminationOrderTemplate /order set
! 617:
! 618: [[1]] order oplus [[1]] oplus /order set
! 619:
! 620: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
! 621:
! 622: /compl
! 623: [univ 0 get] evars join evars univ0 complement join
! 624: def
! 625: compl univ
! 626: getPerm /perm set
! 627: %%perm :: univ :: compl ::
! 628:
! 629: order perm permuteOrderMatrix /order set
! 630:
! 631:
! 632: vars [order] join /arg1 set
! 633: ] pop
! 634: popVariables
! 635: arg1
! 636: } def
! 637:
! 638: /elimination_order2 {
! 639: %% [x-list d-list params] (x,y,z) elimination_order
! 640: %% vars evars
! 641: %% [x-list d-list params order]
! 642: %% with no graduation and homogenization variables.
! 643: /arg2 set /arg1 set
! 644: [/vars /evars /univ /order /perm /compl] pushVariables
! 645: /vars arg1 def /evars [arg2 to_records pop] def
! 646: [
! 647: /univ vars 0 get reverse
! 648: vars 1 get reverse join
! 649: def
! 650:
! 651: << univ length >>
! 652: << evars length >>
! 653: eliminationOrderTemplate /order set
! 654: /compl
! 655: evars << evars univ complement >> join
! 656: def
! 657: compl univ
! 658: getPerm /perm set
! 659: %%perm :: univ :: compl ::
! 660:
! 661: order perm permuteOrderMatrix /order set
! 662:
! 663: vars [order] join /arg1 set
! 664: ] pop
! 665: popVariables
! 666: arg1
! 667: } def
! 668:
! 669:
! 670: /elimination_order3 {
! 671: %% [x-list d-list params] (x,y,z) elimination_order
! 672: %% vars evars
! 673: %% [x-list d-list params order]
! 674: /arg2 set /arg1 set
! 675: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 676: /vars arg1 def /evars [arg2 to_records pop] def
! 677: [
! 678: /univ vars 0 get reverse
! 679: vars 1 get reverse join
! 680: def
! 681:
! 682: << univ length 1 sub >>
! 683: << evars length >>
! 684: eliminationOrderTemplate /order set
! 685:
! 686: [[1]] order oplus /order set
! 687:
! 688: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
! 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:
! 706: /define_ring {
! 707: %[ (x,y,z) ring_of_polynominals
! 708: % (x,y) elimination_order
! 709: % 17
! 710: %] define_ring
! 711: % or
! 712: %[ (x,y,z) ring_of_polynominals
! 713: % (x,y) elimination_order
! 714: % 17
! 715: % [(keyword) value (keyword) value ...]
! 716: %] define_ring
! 717: /arg1 set
! 718: [/rp /param /foo] pushVariables
! 719: [/rp arg1 def
! 720:
! 721: rp 0 get length 3 eq {
! 722: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
! 723: ( ) elimination_order put
! 724: } { } ifelse
! 725:
! 726: [
! 727: rp 0 get 0 get %% x-list
! 728: rp 0 get 1 get %% d-list
! 729: rp 0 get 2 get /param set
! 730: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
! 731: param %% parameters.
! 732: rp 0 get 3 get %% order matrix.
! 733: rp length 2 eq
! 734: { [ ] } %% null optional argument.
! 735: { rp 2 get }
! 736: ifelse
! 737: ] /foo set
! 738: foo aload pop set_up_ring@
! 739: ] pop
! 740: popVariables
! 741: [(CurrentRingp)] system_variable
! 742: } def
! 743:
! 744:
! 745: [(define_qring)
! 746: [( [varlist ring_of_q_difference_operators order characteristic] define_qring)
! 747: ( Pointer to the ring. )
! 748: (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)
! 749: ( 0] define_qring )
! 750: (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << ,, >>)
! 751: ]
! 752: ] putUsages
! 753: /define_qring {
! 754: %[ (x,y,z) ring_of_q_difference_operators
! 755: % (Qx,Qy) elimination_order
! 756: % 17
! 757: %] define_qring
! 758: /arg1 set
! 759: [/rp /param /foo /cring /ppp] pushVariables
! 760: [/rp arg1 def
! 761: /ppp rp 1 get def
! 762: %% define coefficient ring.
! 763: [(q) @@@.esymbol] [(h) @@@.Esymbol]
! 764: [ppp 2 2 2 2 1 2 2 2]
! 765: [[1 0 0 0] [0 1 0 0] [0 0 1 0] [0 0 0 1]]
! 766: [(mpMult) (poly)] set_up_ring@
! 767: /cring [(CurrentRingp)] system_variable def
! 768:
! 769: rp 0 get length 3 eq {
! 770: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
! 771: ( ) elimination_order put
! 772: } { } ifelse
! 773:
! 774: [
! 775: rp 0 get 0 get %% x-list
! 776: rp 0 get 1 get %% d-list
! 777: rp 0 get 2 get /param set
! 778: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
! 779: param %% parameters.
! 780: rp 0 get 3 get %% order matrix.
! 781: rp length 2 eq
! 782: { [(mpMult) (diff) (coefficient ring) cring] } %% optional argument.
! 783: { [(mpMult) (diff) (coefficient ring) cring] rp 2 get join }
! 784: ifelse
! 785: ] /foo set
! 786: foo aload pop set_up_ring@
! 787: ] pop
! 788: popVariables
! 789: [(CurrentRingp)] system_variable
! 790: } def
! 791:
! 792: [(ring_def)
! 793: [(ring ring_def)
! 794: (Set the current ring to the <<ring>>)
! 795: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 0 ] define_ring)
! 796: ( /R set)
! 797: ( R ring_def)
! 798: (In order to get the ring object R to which a given polynomial f belongs,)
! 799: (one may use the command )
! 800: ( f (ring) data_conversion /R set)
! 801: (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)
! 802: (cf. << ,, >>)
! 803: ]
! 804: ] putUsages
! 805:
! 806: /ring_def {
! 807: /arg1 set
! 808: [(CurrentRingp) arg1] system_variable
! 809: } def
! 810:
! 811:
! 812:
! 813: /lexicographicOrderTemplate {
! 814: % size lexicographicOrderTemplate matrix
! 815: /arg1 set
! 816: [/k /size] pushVariables
! 817: [
! 818: /size arg1 def
! 819: [ 0 1 << size 1 sub >>
! 820: {
! 821: /k set
! 822: size k evec
! 823: } for
! 824: ] /arg1 set
! 825: ] pop
! 826: popVariables
! 827: arg1
! 828: } def
! 829:
! 830: /lexicographic_order {
! 831: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 832: %% vars evars
! 833: %% [x-list d-list params order]
! 834: /arg2 set /arg1 set
! 835: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 836: /vars arg1 def /evars [arg2 to_records pop] def
! 837: [
! 838: /univ vars 0 get reverse
! 839: vars 1 get reverse join
! 840: def
! 841:
! 842: << univ length 2 sub >>
! 843: lexicographicOrderTemplate /order set
! 844:
! 845: [[1]] order oplus [[1]] oplus /order set
! 846:
! 847: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
! 848:
! 849: /compl
! 850: [univ 0 get] evars join evars univ0 complement join
! 851: def
! 852: compl univ
! 853: getPerm /perm set
! 854: %%perm :: univ :: compl ::
! 855:
! 856: order perm permuteOrderMatrix /order set
! 857:
! 858: vars [order] join /arg1 set
! 859: ] pop
! 860: popVariables
! 861: arg1
! 862: } def
! 863:
! 864: /lexicographic_order2 {
! 865: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 866: %% vars evars
! 867: %% [x-list d-list params order]
! 868: %% with no graduation and homogenization variables
! 869: /arg2 set /arg1 set
! 870: [/vars /evars /univ /order /perm /compl] pushVariables
! 871: /vars arg1 def /evars [arg2 to_records pop] def
! 872: [
! 873: /univ vars 0 get reverse
! 874: vars 1 get reverse join
! 875: def
! 876:
! 877: << univ length >>
! 878: lexicographicOrderTemplate /order set
! 879:
! 880: /compl
! 881: evars << evars univ complement >> join
! 882: def
! 883: compl univ
! 884: getPerm /perm set
! 885:
! 886: order perm permuteOrderMatrix /order set
! 887:
! 888: vars [order] join /arg1 set
! 889: ] pop
! 890: popVariables
! 891: arg1
! 892: } def
! 893:
! 894: /lexicographic_order3 {
! 895: %% [x-list d-list params] (x,y,z) lexicograhic_order
! 896: %% vars evars
! 897: %% [x-list d-list params order]
! 898: %% with no homogenization variable.
! 899: /arg2 set /arg1 set
! 900: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
! 901: /vars arg1 def /evars [arg2 to_records pop] def
! 902: [
! 903: /univ vars 0 get reverse
! 904: vars 1 get reverse join
! 905: def
! 906:
! 907: << univ length 1 sub >>
! 908: lexicographicOrderTemplate /order set
! 909:
! 910: [[1]] order oplus /order set
! 911:
! 912: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
! 913:
! 914: /compl
! 915: [univ 0 get] evars join evars univ0 complement join
! 916: def
! 917: compl univ
! 918: getPerm /perm set
! 919: %%perm :: univ :: compl ::
! 920:
! 921: order perm permuteOrderMatrix /order set
! 922:
! 923: vars [order] join /arg1 set
! 924: ] pop
! 925: popVariables
! 926: arg1
! 927: } def
! 928:
! 929: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
! 930:
! 931: /graded_reverse_lexicographic_order {
! 932: ( ) elimination_order
! 933: } def
! 934:
! 935:
! 936: /getX {
! 937: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
! 938: /arg2 set /arg1 set
! 939: [/k /param /func /low /top] pushVariables
! 940: [
! 941: /param arg1 def /func arg2 def
! 942: func 1 eq
! 943: {
! 944: /low 0 def
! 945: }
! 946: {
! 947: /low << param 2 get >> << func 1 sub >> get def
! 948: } ifelse
! 949: /top << param 2 get >> << func 4 add >> get 1 sub def
! 950: [
! 951: low 1 top
! 952: {
! 953: /k set
! 954: param 0 get k get
! 955: } for
! 956: ] /arg1 set
! 957: ] pop
! 958: popVariables
! 959: arg1
! 960: } def
! 961:
! 962: /getD {
! 963: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
! 964: /arg2 set /arg1 set
! 965: [/k /param /func /low /top] pushVariables
! 966: [
! 967: /param arg1 def /func arg2 def
! 968: func 1 eq
! 969: {
! 970: /low 0 def
! 971: }
! 972: {
! 973: /low << param 2 get >> << func 1 sub >> get def
! 974: } ifelse
! 975: /top << param 2 get >> << func 4 add >> get 1 sub def
! 976: [
! 977: low 1 top
! 978: {
! 979: /k set
! 980: param 1 get k get
! 981: } for
! 982: ] /arg1 set
! 983: ] pop
! 984: popVariables
! 985: arg1
! 986: } def
! 987:
! 988: /getXV {
! 989: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
! 990: /arg2 set /arg1 set
! 991: [/k /param /func /low /top] pushVariables
! 992: [
! 993: /param arg1 def /func arg2 def
! 994: /low << param 2 get >> << func 4 add >> get def
! 995: /top << param 2 get >> func get 1 sub def
! 996: [
! 997: low 1 top
! 998: {
! 999: /k set
! 1000: param 0 get k get
! 1001: } for
! 1002: ] /arg1 set
! 1003: ] pop
! 1004: popVariables
! 1005: arg1
! 1006: } def
! 1007:
! 1008: /getDV {
! 1009: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
! 1010: /arg2 set /arg1 set
! 1011: [/k /param /func /low /top] pushVariables
! 1012: [
! 1013: /param arg1 def /func arg2 def
! 1014: /low << param 2 get >> << func 4 add >> get def
! 1015: /top << param 2 get >> func get 1 sub def
! 1016: [
! 1017: low 1 top
! 1018: {
! 1019: /k set
! 1020: param 1 get k get
! 1021: } for
! 1022: ] /arg1 set
! 1023: ] pop
! 1024: popVariables
! 1025: arg1
! 1026: } def
! 1027:
! 1028: /reNaming {
! 1029: %% It also changes oldx2 and oldd2, which are globals.
! 1030: /arg1 set
! 1031: [/i /j /new /count /ostr /k] pushVariables
! 1032: [
! 1033: /new arg1 def
! 1034: /count 0 def
! 1035: 0 1 << new length 1 sub >> {
! 1036: /i set
! 1037: << i 1 add >> 1 << new length 1 sub >> {
! 1038: /j set
! 1039: << new i get >> << new j get >> eq
! 1040: {
! 1041: new j get /ostr set
! 1042: (The two rings have the same name :) messagen
! 1043: new i get messagen (.) message
! 1044: (The name ) messagen
! 1045: new i get messagen ( is changed into ) messagen
! 1046: new j << new i get << 48 count add $string$ data_conversion >>
! 1047: 2 cat_n >> put
! 1048: new j get messagen (.) message
! 1049: /oldx2 ostr << new j get >> reNaming2
! 1050: /oldd2 ostr << new j get >> reNaming2
! 1051: /count count 1 add def
! 1052: }
! 1053: { }
! 1054: ifelse
! 1055: } for
! 1056: } for
! 1057: /arg1 new def
! 1058: ] pop
! 1059: popVariables
! 1060: arg1
! 1061: } def
! 1062:
! 1063: /reNaming2 {
! 1064: %% array oldString newString reNaming2
! 1065: %% /aa (x) (y) reNaming2
! 1066: /arg3 set /arg2 set /arg1 set
! 1067: [/array /oldString /newString /k] pushVariables
! 1068: [
! 1069: /array arg1 def /oldString arg2 def /newString arg3 def
! 1070: 0 1 << array load length 1 sub >>
! 1071: {
! 1072: /k set
! 1073: << array load k get >> oldString eq
! 1074: {
! 1075: array load k newString put
! 1076: }
! 1077: { } ifelse
! 1078: } for
! 1079: ] pop
! 1080: popVariables
! 1081: } def
! 1082:
! 1083: /add_rings {
! 1084: /arg2 set /arg1 set
! 1085: [/param1 /param2
! 1086: /newx /newd /newv
! 1087: /k /const /od1 /od2 /od
! 1088: /oldx2 /oldd2 % these will be changed in reNaming.
! 1089: /oldv
! 1090: ] pushVariables
! 1091: [
! 1092: /param1 arg1 def /param2 arg2 def
! 1093: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 1094: /newx
! 1095: [ ]
! 1096: param2 1 getX join param1 1 getX join
! 1097: param2 1 getXV join param1 1 getXV join
! 1098:
! 1099: param2 2 getX join param1 2 getX join
! 1100: param2 2 getXV join param1 2 getXV join
! 1101:
! 1102: param2 3 getX join param1 3 getX join
! 1103: param2 3 getXV join param1 3 getXV join
! 1104:
! 1105: param2 4 getX join param1 4 getX join
! 1106: param2 4 getXV join param1 4 getXV join
! 1107: def
! 1108: /newd
! 1109: [ ]
! 1110: param2 1 getD join param1 1 getD join
! 1111: param2 1 getDV join param1 1 getDV join
! 1112:
! 1113: param2 2 getD join param1 2 getD join
! 1114: param2 2 getDV join param1 2 getDV join
! 1115:
! 1116: param2 3 getD join param1 3 getD join
! 1117: param2 3 getDV join param1 3 getDV join
! 1118:
! 1119: param2 4 getD join param1 4 getD join
! 1120: param2 4 getDV join param1 4 getDV join
! 1121: def
! 1122:
! 1123: /newv newx newd join def
! 1124: /oldx2 param2 0 get def /oldd2 param2 1 get def
! 1125: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
! 1126: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
! 1127: /newv newv reNaming def
! 1128:
! 1129: /newx [
! 1130: 0 1 << newv length 2 idiv 1 sub >>
! 1131: {
! 1132: /k set
! 1133: newv k get
! 1134: } for
! 1135: ] def
! 1136: /newd [
! 1137: 0 1 << newv length 2 idiv 1 sub >>
! 1138: {
! 1139: /k set
! 1140: newv << newv length 2 idiv k add >> get
! 1141: } for
! 1142: ] def
! 1143: /const [
! 1144: << param1 2 get 0 get >>
! 1145: << param1 2 get 1 get param2 2 get 1 get add >>
! 1146: << param1 2 get 2 get param2 2 get 2 get add >>
! 1147: << param1 2 get 3 get param2 2 get 3 get add >>
! 1148: << param1 2 get 4 get param2 2 get 4 get add >>
! 1149: << param1 2 get 5 get param2 2 get 5 get add >>
! 1150: << param1 2 get 6 get param2 2 get 6 get add >>
! 1151: << param1 2 get 7 get param2 2 get 7 get add >>
! 1152: << param1 2 get 8 get param2 2 get 8 get add >>
! 1153: ] def
! 1154:
! 1155: /od1 param1 3 get def /od2 param2 3 get def
! 1156: od1 od2 oplus /od set
! 1157:
! 1158: %%oldx2 :: oldd2 ::
! 1159: << param1 0 get reverse >> << param1 1 get reverse >> join
! 1160: << oldx2 reverse >> << oldd2 reverse >> join
! 1161: join /oldv set
! 1162:
! 1163:
! 1164: od << oldv << newx reverse newd reverse join >> getPerm >>
! 1165: permuteOrderMatrix /od set
! 1166:
! 1167: /arg1 [newx newd const od] def
! 1168: ] pop
! 1169: popVariables
! 1170: arg1
! 1171: } def
! 1172:
! 1173:
! 1174: %%%% end of add_rings
! 1175:
! 1176:
! 1177:
! 1178: [(swap01) [
! 1179: $[ .... ] swap01 [....]$
! 1180: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
! 1181: $ define_ring$
! 1182: ]] putUsages
! 1183: %
! 1184: /swap01 {
! 1185: /arg1 set
! 1186: [/rg /ch ] pushVariables
! 1187: [
! 1188: arg1 0 get /rg set % ring
! 1189: arg1 1 get /ch set % characteristics
! 1190: [rg 0 get , rg 1 get , rg 2 get ,
! 1191: << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
! 1192: /arg1 [ rg ch ] def
! 1193: ] pop
! 1194: popVariables
! 1195: arg1
! 1196: } def
! 1197:
! 1198: [(swap0k) [
! 1199: $[ .... ] k swap0k [....]$
! 1200: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
! 1201: $ define_ring$
! 1202: $swap01 == 1 swap0k$
! 1203: ]] putUsages
! 1204: %
! 1205: /swap0k {
! 1206: /arg2 set
! 1207: /arg1 set
! 1208: [/rg /ch /kk] pushVariables
! 1209: [
! 1210: arg2 /kk set
! 1211: arg1 0 get /rg set % ring
! 1212: arg1 1 get /ch set % characteristics
! 1213: [rg 0 get , rg 1 get , rg 2 get ,
! 1214: << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
! 1215: /arg1 [ rg ch ] def
! 1216: ] pop
! 1217: popVariables
! 1218: arg1
! 1219: } def
! 1220:
! 1221: %%%%%%%%%%%%% weight vector
! 1222: [(position)
! 1223: [(set element position number)
! 1224: (Example: [(cat) (dog) (hot chocolate)] (cat) position ===> 0.)
! 1225: ]
! 1226: ] putUsages
! 1227: /position {
! 1228: /arg2 set /arg1 set
! 1229: [/univ /elem /num /flag] pushVariables
! 1230: [
! 1231: /univ arg1 def
! 1232: /elem arg2 def
! 1233: /num -1 def /flag -1 def
! 1234: 0 1 << univ length 1 sub >>
! 1235: {
! 1236: /num set
! 1237: univ num get elem eq
! 1238: { /flag 0 def exit }
! 1239: { }
! 1240: ifelse
! 1241: } for
! 1242: flag -1 eq
! 1243: {/num -1 def}
! 1244: { }
! 1245: ifelse
! 1246: ] pop
! 1247: /arg1 num def
! 1248: popVariables
! 1249: arg1
! 1250: } def
! 1251:
! 1252:
! 1253: [(evecw)
! 1254: [(size position weight evecw [0 0 ... 0 weight 0 ... 0] )
! 1255: (Example: 3 0 113 evecw ===> [113 0 0])
! 1256: ]
! 1257: ] putUsages
! 1258: /evecw {
! 1259: /arg3 set /arg2 set /arg1 set
! 1260: [/size /iii /www] pushVariables
! 1261: /size arg1 def /iii arg2 def /www arg3 def
! 1262: [
! 1263: 0 1 << size 1 sub >>
! 1264: {
! 1265: iii eq
! 1266: { www }
! 1267: { 0 }
! 1268: ifelse
! 1269: } for
! 1270: ] /arg1 set
! 1271: popVariables
! 1272: arg1
! 1273: } def
! 1274:
! 1275: [(weight_vector)
! 1276: [ ([x-list d-list params] [[(name) weight ...] [...] ...] weight_vector)
! 1277: ([x-list d-list params order])
! 1278: (Example:)
! 1279: ( [(x,y,z) ring_of_polynomials [[(x) 100 (y) 10]] weight_vector 0] )
! 1280: ( define_ring )
! 1281: ]
! 1282: ] putUsages
! 1283: /weight_vector {
! 1284: /arg2 set /arg1 set
! 1285: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
! 1286: /vars arg1 def /w-vectors arg2 def
! 1287: [
! 1288: /univ vars 0 get reverse
! 1289: vars 1 get reverse join
! 1290: def
! 1291: [
! 1292: 0 1 << w-vectors length 1 sub >>
! 1293: {
! 1294: /k set
! 1295: univ w-vectors k get w_to_vec
! 1296: } for
! 1297: ] /order1 set
! 1298: %% order1 ::
! 1299:
! 1300: vars ( ) elimination_order 3 get /order2 set
! 1301: vars [ << order1 order2 join >> ] join /arg1 set
! 1302: ] pop
! 1303: popVariables
! 1304: arg1
! 1305: } def
! 1306:
! 1307: %% [@@@.esymbol (x) (y) (h)] [(x) 100 (y) 10] w_to_vec [0 100 10 0]
! 1308: %% univ www
! 1309: /w_to_vec {
! 1310: /arg2 set /arg1 set
! 1311: [/univ /www /k /vname /vweight /ans] pushVariables
! 1312: /univ arg1 def /www arg2 def
! 1313: [
! 1314: /ans << univ length >> -1 0 evecw def
! 1315: 0 2 << www length 2 sub >>
! 1316: {
! 1317: %% ans ::
! 1318: /k set
! 1319: www k get /vname set
! 1320: www << k 1 add >> get /vweight set
! 1321: << univ length >>
! 1322: << univ vname position >>
! 1323: vweight evecw
! 1324: ans add /ans set
! 1325: } for
! 1326: /arg1 ans def
! 1327: ] pop
! 1328: popVariables
! 1329: arg1
! 1330: } def
! 1331:
! 1332: %%%%%%%%%% end of weight_vector macro
! 1333:
! 1334: %%%%%%%% eliminatev macro
! 1335: [(eliminatev)
! 1336: [([g1 g2 g3 ...gm] [list of variables] eliminatev [r1 ... rp])
! 1337: (Example: [(x y z - 1). (z-1). (y-1).] [(x) (y)] eliminatev [ z-1 ])
! 1338: ]
! 1339: ] putUsages
! 1340: /eliminatev {
! 1341: /arg2 set /arg1 set
! 1342: [/gb /var /vars /ans /k] pushVariables
! 1343: [
! 1344: /gb arg1 def
! 1345: /vars arg2 def
! 1346: /ans gb def
! 1347: 0 1 << vars length 1 sub >> {
! 1348: /k set
! 1349: ans << vars k get >> eliminatev.tmp
! 1350: /ans set
! 1351: } for
! 1352: /arg1 ans def
! 1353: ] pop
! 1354: popVariables
! 1355: arg1
! 1356: } def
! 1357: /eliminatev.tmp {
! 1358: /arg2 set /arg1 set
! 1359: [/gb /degs /ans /n /var /ff /rr /gg] pushVariables
! 1360: [
! 1361: /gb arg1 def
! 1362: /var arg2 def
! 1363: /degs gb {
! 1364: /gg set
! 1365: gg (0). eq
! 1366: { 0 }
! 1367: { gg (ring) data_conversion /rr set
! 1368: gg << var rr ,, >> degree
! 1369: } ifelse
! 1370: } map def
! 1371: %%degs message
! 1372: /ans [
! 1373: 0 1 << gb length 1 sub >> {
! 1374: /n set
! 1375: << degs n get >> 0 eq
! 1376: { gb n get /ff set
! 1377: ff (0). eq
! 1378: { }
! 1379: { ff } ifelse
! 1380: }
! 1381: { } ifelse
! 1382: } for
! 1383: ] def
! 1384: /arg1 ans def
! 1385: ] pop
! 1386: popVariables
! 1387: arg1
! 1388: } def
! 1389:
! 1390: /eliminatev.tmp.org {
! 1391: /arg2 set /arg1 set
! 1392: [/gb /degs /ans /n /var /ff] pushVariables
! 1393: [
! 1394: /gb arg1 def
! 1395: /var arg2 def
! 1396: /degs gb {var . degree} map def
! 1397: /ans [
! 1398: 0 1 << gb length 1 sub >> {
! 1399: /n set
! 1400: << degs n get >> 0 eq
! 1401: { gb n get /ff set
! 1402: ff (0). eq
! 1403: { }
! 1404: { ff } ifelse
! 1405: }
! 1406: { } ifelse
! 1407: } for
! 1408: ] def
! 1409: /arg1 ans def
! 1410: ] pop
! 1411: popVariables
! 1412: arg1
! 1413: } def
! 1414: %%% end of eliminatev macro
! 1415:
! 1416: %%% macro for output
! 1417:
! 1418: [(isInteger)
! 1419: [(obj isInteger bool) ]
! 1420: ] putUsages
! 1421: /isInteger {
! 1422: (type?) data_conversion << 0 (type?) data_conversion >> eq
! 1423: } def
! 1424:
! 1425: [(isArray)
! 1426: [(obj isArray bool) ]
! 1427: ] putUsages
! 1428: /isArray {
! 1429: (type?) data_conversion << [ ] (type?) data_conversion >> eq
! 1430: } def
! 1431:
! 1432: [(isPolynomial)
! 1433: [(obj isPolynomial bool) ]
! 1434: ] putUsages
! 1435: /isPolynomial {
! 1436: (type?) data_conversion
! 1437: << [(x) (var) 0] system_variable . (type?) data_conversion >> eq
! 1438: } def
! 1439:
! 1440: [(isString)
! 1441: [(obj isString bool) ]
! 1442: ] putUsages
! 1443: /isString {
! 1444: (type?) data_conversion
! 1445: << (Hi) (type?) data_conversion >> eq
! 1446: } def
! 1447:
! 1448: [(isClass)
! 1449: [(obj isClass bool) ]
! 1450: ] putUsages
! 1451: /isClass {
! 1452: (type?) data_conversion ClassP eq
! 1453: } def
! 1454:
! 1455: [(isUniversalNumber)
! 1456: [(obj isUniversalNumber bool) ]
! 1457: ] putUsages
! 1458: /isUniversalNumber {
! 1459: (type?) data_conversion UniversalNumberP eq
! 1460: } def
! 1461:
! 1462: [(isDouble)
! 1463: [(obj isDouble bool) ]
! 1464: ] putUsages
! 1465: /isDouble {
! 1466: (type?) data_conversion DoubleP eq
! 1467: } def
! 1468:
! 1469: [(isRational)
! 1470: [(obj isRational bool) ]
! 1471: ] putUsages
! 1472: /isRational {
! 1473: (type?) data_conversion RationalFunctionP eq
! 1474: } def
! 1475:
! 1476: /toString.tmp {
! 1477: /arg1 set
! 1478: [/obj /fname] pushVariables
! 1479: /obj arg1 def
! 1480: [
! 1481: obj isArray
! 1482: {
! 1483: obj {toString.tmp} map
! 1484: }
! 1485: { } ifelse
! 1486: obj isInteger
! 1487: {
! 1488: obj (dollar) data_conversion %% not string. It returns the ascii code.
! 1489: }
! 1490: { } ifelse
! 1491: obj isPolynomial
! 1492: {
! 1493: obj (string) data_conversion
! 1494: }
! 1495: { } ifelse
! 1496: obj isString
! 1497: { obj }
! 1498: { } ifelse
! 1499: obj isUniversalNumber
! 1500: { obj (string) data_conversion } { } ifelse
! 1501: obj isDouble
! 1502: { obj (string) data_conversion } { } ifelse
! 1503: obj isRational
! 1504: { obj (string) data_conversion } { } ifelse
! 1505: obj tag 0 eq
! 1506: { (null) } { } ifelse
! 1507:
! 1508: %%% New code that uses a file.
! 1509: obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
! 1510: { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
! 1511: [(outputObjectToFile) fname obj] extension pop
! 1512: fname pushfile
! 1513: [(/bin/rm -rf ) fname] cat system
! 1514: } { } ifelse
! 1515: ] /arg1 set
! 1516: popVariables
! 1517: arg1 aload pop
! 1518: } def
! 1519:
! 1520:
! 1521:
! 1522: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
! 1523: /toString.tmp2 {
! 1524: /arg1 set
! 1525: [/obj /i /n /r] pushVariables
! 1526: [
! 1527: /obj arg1 def
! 1528: obj isArray
! 1529: {
! 1530: ( [ )
! 1531: obj {toString.tmp2} map /r set
! 1532: /n r length 1 sub def
! 1533: [0 1 n {
! 1534: /i set
! 1535: i n eq {
! 1536: r i get
! 1537: }
! 1538: { r i get ( , ) 2 cat_n }
! 1539: ifelse
! 1540: } for
! 1541: ] aload length cat_n
! 1542: ( ] )
! 1543: 3 cat_n
! 1544: }
! 1545: {
! 1546: obj
! 1547: } ifelse
! 1548: ] /arg1 set
! 1549: popVariables
! 1550: arg1 aload pop
! 1551: } def
! 1552:
! 1553:
! 1554: [(toString)
! 1555: [(obj toString)
! 1556: (Convert obj to a string.)
! 1557: (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ] ]$)
! 1558: ]
! 1559: ] putUsages
! 1560: /toString {
! 1561: /arg1 set
! 1562: [/obj ] pushVariables
! 1563: [
! 1564: /obj arg1 def
! 1565: obj isString
! 1566: { obj }
! 1567: { obj toString.tmp toString.tmp2 }
! 1568: ifelse /arg1 set
! 1569: ] pop
! 1570: popVariables
! 1571: arg1
! 1572: } def
! 1573:
! 1574: [(output)
! 1575: [(obj output) (Output the object to the standard file sm1out.txt)]
! 1576: ] putUsages
! 1577: /output {
! 1578: /arg1 set
! 1579: [/obj /fd ] pushVariables
! 1580: [
! 1581: /obj arg1 def
! 1582: (sm1out.txt) (a) file /fd set
! 1583: (Writing to sm1out.txt ...) messagen
! 1584: [ fd << obj toString >> writestring ] pop
! 1585: [ fd << 10 (string) data_conversion >> writestring ] pop
! 1586: ( Done.) message
! 1587: fd closefile
! 1588: ] pop
! 1589: popVariables
! 1590: } def
! 1591: %%%% end of macro for output.
! 1592: [(tag)
! 1593: [(obj tag integer)
! 1594: (tag returns datatype.)
! 1595: (cf. data_conversion)
! 1596: (Example: 2 tag IntegerP eq ---> 1)
! 1597: ]
! 1598: ] putUsages
! 1599: /etag {(type??) data_conversion} def
! 1600: [(etag)
! 1601: [(obj etag integer)
! 1602: (etag returns extended object tag. cf. kclass.c)
! 1603: ]
! 1604: ] putUsages
! 1605: /tag {(type?) data_conversion} def
! 1606: %% datatype constants
! 1607: /IntegerP 1 (type?) data_conversion def
! 1608: /LiteralP /arg1 (type?) data_conversion def %Sstring
! 1609: /StringP (?) (type?) data_conversion def %Sdollar
! 1610: /ExecutableArrayP { 1 } (type?) data_conversion def
! 1611: /ArrayP [ 0 ] (type?) data_conversion def
! 1612: /PolyP (1). (type?) data_conversion def
! 1613: /FileP 13 def
! 1614: /RingP 14 def
! 1615: /UniversalNumberP 15 def
! 1616: /RationalFunctionP 16 def
! 1617: /ClassP 17 def
! 1618: /DoubleP 18 def
! 1619: /@.datatypeConstant.usage [
! 1620: (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
! 1621: (UniversalNumberP, RationalFunctionP, ClassP, DoubleP)
! 1622: ( return data type identifiers.)
! 1623: (Example: 7 tag IntegerP eq ---> 1)
! 1624: ] def
! 1625: [(IntegerP) @.datatypeConstant.usage ] putUsages
! 1626: [(LiteralP) @.datatypeConstant.usage ] putUsages
! 1627: [(StringP) @.datatypeConstant.usage ] putUsages
! 1628: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
! 1629: [(ArrayP) @.datatypeConstant.usage ] putUsages
! 1630: [(PolyP) @.datatypeConstant.usage ] putUsages
! 1631: [(RingP) @.datatypeConstant.usage ] putUsages
! 1632: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
! 1633: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
! 1634: [(ClassP) @.datatypeConstant.usage ] putUsages
! 1635: [(DoubleP) @.datatypeConstant.usage ] putUsages
! 1636:
! 1637: [(,,)
! 1638: [( string ring ,, polynomial)
! 1639: (Parse the <<string>> as an element in the <<ring>> and returns)
! 1640: (the polynomial.)
! 1641: (cf. define_ring, define_qring, ring_def)
! 1642: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
! 1643: ( /myring set)
! 1644: ( ((x+y)^4) myring ,, /f set)
! 1645: ]] putUsages
! 1646:
! 1647: /,, {
! 1648: /arg2 set /arg1 set
! 1649: [/rrr] pushVariables
! 1650: [ arg1 tag StringP eq
! 1651: arg2 tag RingP eq and
! 1652: { [(CurrentRingp)] system_variable /rrr set
! 1653: [(CurrentRingp) arg2] system_variable
! 1654: /arg1 arg1 expand def
! 1655: [(CurrentRingp) rrr] system_variable
! 1656: }
! 1657: {(Argument Error for ,, ) error }
! 1658: ifelse
! 1659: ] pop
! 1660: popVariables
! 1661: arg1
! 1662: } def
! 1663:
! 1664: [(..)
! 1665: [( string .. universalNumber)
! 1666: (Parse the << string >> as a universalNumber.)
! 1667: (Example: (123431232123123).. /n set)
! 1668: ]] putUsages
! 1669: /.. { (universalNumber) data_conversion } def
! 1670:
! 1671: [(dc)
! 1672: [(Abbreviation of data_conversion.)
! 1673: ]] putUsages
! 1674: /dc { data_conversion } def
! 1675:
! 1676:
! 1677: %%% start of shell sort macro.
! 1678: [(and) [(obj1 obj2 and bool)]] putUsages
! 1679: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
! 1680:
! 1681: [(or) [(obj1 obj2 or bool)]] putUsages
! 1682: /or { add 1 copy 2 eq {pop 1} { } ifelse} def
! 1683:
! 1684: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
! 1685: %% 2 copy is equivalent to dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
! 1686: /ge { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
! 1687: eq {pop pop 1}
! 1688: { gt {1}
! 1689: {0}
! 1690: ifelse}
! 1691: ifelse} def
! 1692:
! 1693: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
! 1694: /le { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
! 1695: eq {pop pop 1}
! 1696: { lt {1}
! 1697: {0}
! 1698: ifelse}
! 1699: ifelse} def
! 1700:
! 1701: [(break)
! 1702: [(bool break)]
! 1703: ] putUsages
! 1704: /break { {exit} { } ifelse } def
! 1705:
! 1706: /not { 0 eq {1} {0} ifelse} def
! 1707: /append { /arg2 set [arg2] join } def
! 1708:
! 1709: [(power)
! 1710: [(obj1 obj2 power obj3)
! 1711: $obj3 is (obj1)^(obj2). cf. npower$
! 1712: $Example: (2). 8 power :: ===> 256 $
! 1713: ]
! 1714: ] putUsages
! 1715: %% From SSWork/yacc/incmac.sm1
! 1716: %% f k power f^k
! 1717: /power {
! 1718: /arg2 set
! 1719: /arg1 set
! 1720: [/f /k /i /ans] pushVariables
! 1721: [
! 1722: /ans (1).. def
! 1723: /f arg1 def /k arg2 ..int def
! 1724: k 0 lt {
! 1725: 1 1 << 0 k sub >> {
! 1726: /ans f ans {mul} sendmsg2 def
! 1727: } for
! 1728: /ans (1).. ans {div} sendmsg2 def
! 1729: }
! 1730: {
! 1731: 1 1 k {
! 1732: /ans f ans {mul} sendmsg2 def
! 1733: } for
! 1734: } ifelse
! 1735: /arg1 ans def
! 1736: ] pop
! 1737: popVariables
! 1738: arg1
! 1739: } def
! 1740: [(..int)
! 1741: [ (universalNumber ..int int)]] putUsages
! 1742: /..int { %% universal number to int
! 1743: (integer) data_conversion
! 1744: } def
! 1745: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
! 1746: /SmallRing [(CurrentRingp)] system_variable def
! 1747:
! 1748: %%% From SSWork/yacc/lib/printSVector.modified.sm1
! 1749: %%% supporting code for printSVector.
! 1750: /greaterThanOrEqual {
! 1751: /arg2 set /arg1 set
! 1752: arg1 arg2 gt { 1 }
! 1753: { arg1 arg2 eq {1} {0} ifelse} ifelse
! 1754: } def
! 1755:
! 1756: /lengthUniv {
! 1757: length (universalNumber) dc
! 1758: } def
! 1759:
! 1760: /getUniv {
! 1761: (integer) dc get
! 1762: } def %% Do not forget to thow away /.
! 1763:
! 1764: %%[(@@@.printSVector)
! 1765: %% [( vector @@@.printSVector outputs the <<vector>> in a pretty way.)
! 1766: %% ( The elements of the vector must be strings.)
! 1767: %% ]
! 1768: %%] putUsages
! 1769:
! 1770: %%% compiled code by d0, 1996, 8/17.
! 1771: /@@@.printSVector {
! 1772: /arg1 set
! 1773: [ %%start of local variables
! 1774: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
! 1775: /keys arg1 def
! 1776: /n
! 1777: keys lengthUniv
! 1778: def
! 1779: /max (0).. def
! 1780: /i (0).. def
! 1781: %%for init.
! 1782: %%for
! 1783: { i n lt
! 1784: { } {exit} ifelse
! 1785: [ {%%increment
! 1786: /i i (1).. add def
! 1787: } %%end of increment{A}
! 1788: {%%start of B part{B}
! 1789: keys i getUniv lengthUniv
! 1790: max gt
! 1791: %% if-condition
! 1792: { %%ifbody
! 1793: /max
! 1794: keys i getUniv lengthUniv
! 1795: def
! 1796: }%%end if if body
! 1797: { %%if- else part
! 1798: } ifelse
! 1799: } %% end of B part. {B}
! 1800: 2 1 roll] {exec} map
! 1801: } loop %%end of for
! 1802: /max max (3).. add
! 1803: def
! 1804: /width (80).. def
! 1805: /m (0).. def
! 1806:
! 1807: %%while
! 1808: { m max mul
! 1809: (80).. lt
! 1810: { } {exit} ifelse
! 1811: /m m (1).. add
! 1812: def
! 1813: } loop
! 1814: /k (0).. def
! 1815: /kk (0).. def
! 1816: /i (0).. def
! 1817: %%for init.
! 1818: %%for
! 1819: { i n lt
! 1820: { } {exit} ifelse
! 1821: [ {%%increment
! 1822: /i i (1).. add def
! 1823: } %%end of increment{A}
! 1824: {%%start of B part{B}
! 1825: keys i getUniv messagen
! 1826: /kk kk (1).. add
! 1827: def
! 1828: /k k
! 1829: keys i getUniv lengthUniv
! 1830: add
! 1831: def
! 1832: /tmp0 max
! 1833: keys i getUniv lengthUniv
! 1834: sub
! 1835: def
! 1836: /j (0).. def
! 1837: %%for init.
! 1838: %%for
! 1839: { j tmp0 lt
! 1840: { } {exit} ifelse
! 1841: [ {%%increment
! 1842: /j j (1).. add def
! 1843: } %%end of increment{A}
! 1844: {%%start of B part{B}
! 1845: /k k (1).. add
! 1846: def
! 1847: kk m lt
! 1848: %% if-condition
! 1849: { %%ifbody
! 1850: ( ) messagen
! 1851: }%%end if if body
! 1852: { %%if- else part
! 1853: } ifelse
! 1854: } %% end of B part. {B}
! 1855: 2 1 roll] {exec} map
! 1856: } loop %%end of for
! 1857: kk m greaterThanOrEqual
! 1858: %% if-condition
! 1859: { %%ifbody
! 1860: /kk (0).. def
! 1861: /k (0).. def
! 1862: newline
! 1863: }%%end if if body
! 1864: { %%if- else part
! 1865: } ifelse
! 1866: } %% end of B part. {B}
! 1867: 2 1 roll] {exec} map
! 1868: } loop %%end of for
! 1869: newline
! 1870: /ExitPoint ]pop popVariables %%pop the local variables
! 1871: } def
! 1872: %%end of function
! 1873:
! 1874: /rest { % returns remainder of a given list
! 1875: [ 2 1 roll aload length -1 roll pop ]
! 1876: } def
! 1877: [(rest)
! 1878: [(array rest the-rest-of-the-array)
! 1879: (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
! 1880: ]
! 1881: ] putUsages
! 1882:
! 1883: %% from SSkan/develop/minbase.sm1
! 1884: /reducedBase {
! 1885: /arg1 set
! 1886: [/base /minbase /n /i /j /myring /zero /f] pushVariables
! 1887: [
! 1888: /base arg1 def
! 1889: base isArray { }
! 1890: { (The argument of reducedBase must be an array of polynomials)
! 1891: error
! 1892: } ifelse
! 1893: base 0 get isPolynomial { }
! 1894: { (The element of the argument of reducedBase must be polynomials)
! 1895: error
! 1896: } ifelse
! 1897: /myring base 0 get (ring) dc def
! 1898: /zero (0) myring ,, def
! 1899: base length 1 sub /n set
! 1900: /minbase [ 0 1 n { /i set base i get } for ] def
! 1901: 0 1 n {
! 1902: /i set
! 1903: minbase i get /f set
! 1904: f zero eq {
! 1905: }
! 1906: {
! 1907: 0 1 n {
! 1908: /j set
! 1909: << minbase j get zero eq >> << i j eq >> or {
! 1910: }
! 1911: {
! 1912: [(isReducible) << minbase j get >> f] gbext
! 1913: {
! 1914: minbase j zero put
! 1915: }
! 1916: { } ifelse
! 1917: } ifelse
! 1918: } for
! 1919: } ifelse
! 1920: } for
! 1921: minbase { minbase.iszero } map /arg1 set
! 1922: ] pop
! 1923: popVariables
! 1924: arg1
! 1925: } def
! 1926:
! 1927: [(reducedBase)
! 1928: [(base reducedBase reducedBase)
! 1929: (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
! 1930: (returns <<reducedBase>>.)
! 1931: (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
! 1932: ]
! 1933: ] putUsages
! 1934:
! 1935: %% package functions
! 1936: /minbase.iszero {
! 1937: dup (0). eq {
! 1938: pop
! 1939: }
! 1940: { } ifelse
! 1941: } def
! 1942:
! 1943: /== {
! 1944: message
! 1945: } def
! 1946: [(==)
! 1947: [(obj ==)
! 1948: (Print obj)
! 1949: ]
! 1950: ] putUsages
! 1951:
! 1952: /@@@.all_variables {
! 1953: [/n /i] pushVariables
! 1954: [
! 1955: /n [(N)] system_variable def
! 1956: [
! 1957: 0 1 n 1 sub {
! 1958: /i set
! 1959: [(x) (var) i] system_variable
! 1960: } for
! 1961: 0 1 n 1 sub {
! 1962: /i set
! 1963: [(D) (var) i] system_variable
! 1964: } for
! 1965: ] /arg1 set
! 1966: ] pop
! 1967: popVariables
! 1968: arg1
! 1969: } def
! 1970:
! 1971: /weightv {
! 1972: @@@.all_variables
! 1973: 2 1 roll w_to_vec
! 1974: } def
! 1975:
! 1976: [(weightv)
! 1977: [(array weightv weight_vector_for_init)
! 1978: (cf. init)
! 1979: (Example: /w [(x) 10 (h) 2] weightv def)
! 1980: ( ((x-h)^10). w init ::)
! 1981: ]
! 1982: ] putUsages
! 1983:
! 1984: /output_order {
! 1985: /arg1 set
! 1986: [/vars /vlist /perm /total /ans] pushVariables
! 1987: [
! 1988: /vlist arg1 def
! 1989: /vars @@@.all_variables def
! 1990: vlist { vars 2 1 roll position } map /perm set
! 1991: perm ==
! 1992: /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
! 1993: perm perm total complement join /ans set
! 1994: [(outputOrder) ans] system_variable
! 1995: ] pop
! 1996: popVariables
! 1997: } def
! 1998:
! 1999: [(output_order)
! 2000: [$ [(v1) (v2) ...] output_order $
! 2001: (Set the order of variables to print for the current ring.)
! 2002: (cf. system_variable)
! 2003: (Example: [(y) (x)] output_order)
! 2004: $ (x*y). :: ===> y*x $
! 2005: ]
! 2006: ] putUsages
! 2007:
! 2008: %% destraction. SSkan/Kan/debug/des.sm1, 1998, 2/27 , 3/1
! 2009: %% should be included in dr.sm1
! 2010:
! 2011: /factorial {
! 2012: /arg2 set
! 2013: /arg1 set
! 2014: [ /f /n ] pushVariables
! 2015: [
! 2016: /f arg1 def
! 2017: /n arg2 def
! 2018: /ans (1).. def
! 2019: n 0 lt { (f n factorial : n must be a non-negative integer)
! 2020: error } { } ifelse
! 2021: 0 1 n 1 sub {
! 2022: (universalNumber) dc /i set
! 2023: ans << f i sub >> mul /ans set
! 2024: } for
! 2025: /arg1 ans def
! 2026: ] pop
! 2027: popVariables
! 2028: arg1
! 2029: } def
! 2030:
! 2031: [(factorial)
! 2032: [(f n factorial g)
! 2033: $integer n, g is f (f-1) ... (f-n+1)$
! 2034: ]
! 2035: ] putUsages
! 2036:
! 2037:
! 2038: /destraction1 {
! 2039: /arg4 set
! 2040: /arg3 set
! 2041: /arg2 set
! 2042: /arg1 set
! 2043: [/ww /f /dx /ss /xx /coeff0 /expvec
! 2044: /coeffvec /expvec2 /ans /one] pushVariables
! 2045: [
! 2046: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
! 2047: /one (1). def %%
! 2048: /ww [ xx toString -1 dx toString 1 ] weightv def
! 2049: f ww init f sub (0). eq { }
! 2050: { [(destraction1 : inhomogeneous with respect to )
! 2051: xx ( and ) dx ] cat error } ifelse
! 2052: f [[xx one]] replace dx coefficients /coeff0 set
! 2053: /expvec coeff0 0 get { (integer) dc } map def
! 2054: /coeffvec coeff0 1 get def
! 2055: expvec { ss 2 -1 roll factorial } map /expvec2 set
! 2056: expvec2 coeffvec mul /ans set
! 2057: /arg1 ans def
! 2058: ] pop
! 2059: popVariables
! 2060: arg1
! 2061: } def
! 2062:
! 2063:
! 2064: /distraction {
! 2065: /arg4 set
! 2066: /arg3 set
! 2067: /arg2 set
! 2068: /arg1 set
! 2069: [/f /dx /ss /xx /ans /n /i] pushVariables
! 2070: [(CurrentRingp)] pushEnv
! 2071: [
! 2072: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
! 2073: f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
! 2074: /n xx length def
! 2075: 0 1 n 1 sub {
! 2076: /i set
! 2077: /f f xx i get dx i get ss i get destraction1 /f set
! 2078: } for
! 2079: /dist1.L
! 2080: /arg1 f def
! 2081: ]pop
! 2082: popEnv
! 2083: popVariables
! 2084: arg1
! 2085: } def
! 2086: [(distraction)
! 2087: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
! 2088: ( distraction result )
! 2089: $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
! 2090: ]
! 2091: ] putUsages
! 2092: /destraction { distraction } def
! 2093:
! 2094:
! 2095:
! 2096:
! 2097: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 2098: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 2099: %%%%%%%%%%%%%%%% sorting
! 2100: %/N 1000 def
! 2101: %/a.shell [N -1 0 { } for ] def
! 2102: %a.shell 0 -1000 put
! 2103: %% You need gate keeper.
! 2104: [(shell)
! 2105: [([gate-keeper f1 f2 ... fm] shell result)
! 2106: (Sort the list. Gate-keeper should be the smallest element)]
! 2107: ] putUsages
! 2108: /shell {
! 2109: /arg1 set
! 2110: [/N /a.shell /h /i /v /j] pushVariables
! 2111: [
! 2112: /a.shell arg1 def
! 2113: /N a.shell length 1 sub def
! 2114:
! 2115: /h 1 def
! 2116: {/h h 3 mul 1 add def
! 2117: << h N ge >> break
! 2118: } loop
! 2119: {
! 2120: /h << h 3 idiv >> def
! 2121: << h 1 add >> 1 N {
! 2122: /i set
! 2123: /v a.shell i get def
! 2124: /j i def
! 2125: {
! 2126: %% a.shell print newline
! 2127: << a.shell << j h sub >> get >> v le break
! 2128: a.shell j << a.shell << j h sub >> get >> put
! 2129: /j j h sub def
! 2130: j h le break
! 2131: } loop
! 2132: a.shell j v put
! 2133: } for
! 2134: h 1 lt break
! 2135: } loop
! 2136: /arg1 a.shell def
! 2137: ] pop
! 2138: popVariables
! 2139: arg1
! 2140: } def
! 2141: %%%% end of shell sort macro
! 2142:
! 2143: /variableNames {
! 2144: /arg1 set
! 2145: [/in-variableNames /rrr /nnn /i /cp] pushVariables
! 2146: [
! 2147: /rrr arg1 def
! 2148: [(CurrentRingp)] system_variable /cp set
! 2149: [(CurrentRingp) rrr] system_variable
! 2150: [(N)] system_variable /nnn set
! 2151: [ 0 1 nnn 1 sub {
! 2152: /i set [(x) (var) i] system_variable } for ]
! 2153: [ 0 1 nnn 1 sub {
! 2154: /i set [(D) (var) i] system_variable } for ]
! 2155: join /arg1 set
! 2156: [(CurrentRingp) cp] system_variable
! 2157: ] pop
! 2158: popVariables
! 2159: arg1
! 2160: } def
! 2161:
! 2162:
! 2163: /makeRingMap {
! 2164: /arg3 set /arg2 set /arg1 set
! 2165: [/in-makeRingMap /corres /M /N /corresM /corresN
! 2166: /vars /vars-org /i /p /ans /cp] pushVariables
! 2167: [
! 2168: /corres arg1 def /M arg2 def /N arg3 def
! 2169: /corresM corres 0 get def
! 2170: /corresN corres 1 get def
! 2171: [(CurrentRingp)] system_variable /cp set
! 2172: [(CurrentRingp) M] system_variable
! 2173: M variableNames /vars set vars 1 copy /vars-org set
! 2174: 0 1 corresM length 1 sub {
! 2175: /i set
! 2176: vars corresM i get position /p set
! 2177: p -1 gt {
! 2178: vars p $($ corresN i get $)$ 3 cat_n put
! 2179: } { } ifelse
! 2180: } for
! 2181: /arg1 [vars M N vars-org] def
! 2182: [(CurrentRingp) cp] system_variable
! 2183: ] pop
! 2184: popVariables
! 2185: arg1
! 2186: } def
! 2187:
! 2188:
! 2189:
! 2190: /ringmap {
! 2191: /arg2 set /arg1 set
! 2192: [/in-ringmap /f /M2N /cp /f2] pushVariables
! 2193: [
! 2194: /f arg1 def /M2N arg2 def
! 2195: [(CurrentRingp)] system_variable /cp set
! 2196: f (0). eq { /f2 f def }
! 2197: {
! 2198: %f (ring) dc M2N 1 get eq
! 2199: %{ }
! 2200: %{ (The argument polynomial does not belong to the domain ring.) message
! 2201: % error
! 2202: % } ifelse
! 2203: [(CurrentRingp) M2N 1 get] system_variable
! 2204: [(variableNames) M2N 0 get] system_variable
! 2205: f toString /f2 set
! 2206: [(variableNames) M2N 3 get] system_variable
! 2207: f2 M2N 2 get ,, /f2 set
! 2208: } ifelse
! 2209: [(CurrentRingp) cp] system_variable
! 2210: /arg1 f2 def
! 2211: ] pop
! 2212: popVariables
! 2213: arg1
! 2214: } def
! 2215:
! 2216: [(makeRingMap)
! 2217: [( rule ring1 ring2 makeRingMap maptable )
! 2218: (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
! 2219: ]
! 2220: ] putUsages
! 2221: [(ringmap)
! 2222: [(f mapTable ringmap r)
! 2223: (f is mapped to r where the map is defined by the mapTable, which is generated)
! 2224: (by makeRingMap as follows:)
! 2225: ( rule ring1 ring2 makeRingMap maptable )
! 2226: $Example:$
! 2227: $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
! 2228: $/R1 set$
! 2229: $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
! 2230: $/R2 set$
! 2231: $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
! 2232: $r0 R1 R2 makeRingMap /maptable set$
! 2233: $(Dx-1) R1 ,, /ff set$
! 2234: $ ff maptable ringmap :: $
! 2235: ]
! 2236: ] putUsages
! 2237:
! 2238:
! 2239: /getVariableNames {
! 2240: [/in-getVariableNames /ans /i /n] pushVariables
! 2241: [
! 2242: /n [(N)] system_variable def
! 2243: [
! 2244: n 1 sub -1 0 {
! 2245: /i set
! 2246: [(x) (var) i] system_variable
! 2247: } for
! 2248: n 1 sub -1 0{
! 2249: /i set
! 2250: [(D) (var) i] system_variable
! 2251: } for
! 2252: ] /arg1 set
! 2253: ] pop
! 2254: popVariables
! 2255: arg1
! 2256: } def
! 2257: [(getVariableNames)
! 2258: [(getVariableNames list-of-variables)
! 2259: (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
! 2260: ]
! 2261: ] putUsages
! 2262:
! 2263: /tolower {
! 2264: /arg1 set
! 2265: [/in-tolower /s /sl] pushVariables
! 2266: [
! 2267: /s arg1 def
! 2268: s (array) dc /s set
! 2269: s { tolower.aux (string) dc } map /sl set
! 2270: sl aload length cat_n /arg1 set
! 2271: ] pop
! 2272: popVariables
! 2273: arg1
! 2274: } def
! 2275:
! 2276: /tolower.aux {
! 2277: /arg1 set
! 2278: arg1 64 gt arg1 96 lt and
! 2279: { arg1 32 add }
! 2280: { arg1 } ifelse
! 2281: } def
! 2282: [(tolower)
! 2283: [(string tolower string2)
! 2284: (Capital letters in string are converted to lower case letters.)
! 2285: $Example: (Hello World) tolower :: (hello world)$
! 2286: ]
! 2287: ] putUsages
! 2288:
! 2289: /hilbert {
! 2290: /arg2 set
! 2291: /arg1 set
! 2292: [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
! 2293: [
! 2294: /base arg1 def
! 2295: /vlist arg2 def
! 2296: [(CurrentRingp)] system_variable /rrrorg set
! 2297: /strf 0 def
! 2298: vlist isString
! 2299: { /vlist [ vlist to_records pop ] def }
! 2300: { } ifelse
! 2301: base isArray { }
! 2302: { (hilb : the first argument must be an array of polynomials.)
! 2303: error
! 2304: } ifelse
! 2305: vlist isArray { }
! 2306: { (hilb : the second argument must be an array of polynomials.)
! 2307: error
! 2308: } ifelse
! 2309:
! 2310: vlist 0 get isString{ /strf 1 def } { } ifelse
! 2311: base 0 get isPolynomial {
! 2312: base 0 get (ring) dc /rrr set
! 2313: }
! 2314: {
! 2315: [ vlist { (,) } map aload length cat_n ring_of_polynomials 0 ] define_ring
! 2316: /rrr set
! 2317: base { . } map /base set
! 2318: } ifelse
! 2319: vlist { dup isPolynomial { } { rrr ,, } ifelse } map /vlist set
! 2320:
! 2321: [(hilbert) base vlist] extension /ff set
! 2322: [(CurrentRingp) rrrorg] system_variable
! 2323: /arg1 ff def
! 2324: ] pop
! 2325: popVariables
! 2326: arg1
! 2327: } def
! 2328:
! 2329: /hilbReduce {
! 2330: /arg2 set
! 2331: /arg1 set
! 2332: [/hhh /f /d /vv /ans] pushVariables
! 2333: [
! 2334: /hhh arg1 def %% hilbert function
! 2335: /vv arg2 def
! 2336: /f hhh 1 get def
! 2337: f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
! 2338: f vv << f (ring) dc >> ,, degree /vv set
! 2339: hhh 0 get /d set
! 2340: d d (integer) dc factorial /d set
! 2341: d << vv (universalNumber) dc vv factorial >> idiv /d set
! 2342: [(divByN) f d] gbext /ans set
! 2343: ans 1 get (0). eq
! 2344: { }
! 2345: { (hilbReduce : Invalid hilbert function ) error } ifelse
! 2346: /hilbReduce.label
! 2347: ans 0 get /arg1 set
! 2348: ] pop
! 2349: popVariables
! 2350: arg1
! 2351: } def
! 2352:
! 2353:
! 2354: [(hilbReduce)
! 2355: [([f,g] v hilbReduce p)
! 2356: (output of hilbert [f,g]; string v; poly p)
! 2357: (p is (g/(f!))*deg(g)!)
! 2358: $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
! 2359: ]
! 2360: ] putUsages
! 2361: [(hilbert)
! 2362: [(base vlist hilbert [m f])
! 2363: (array of poly base; array of poly vlist; number m; poly f;)
! 2364: (array of string base; array of string vlist; number m; poly f;)
! 2365: (array of string base; string vlist; number m; poly f;)
! 2366: ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
! 2367: (The << base >> should be a reduced Grobner basis.)
! 2368: (Or, when the << base >> is an array of string,)
! 2369: (all entries should be monomials.)
! 2370: (Example: [(x^2) (x y )] (x,y) hilbert :: [2, 2 h + 4] )
! 2371: (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce :: 4)
! 2372: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce :: 3)
! 2373: (cf. hilb, hilbReduce)
! 2374: ]
! 2375: ] putUsages
! 2376:
! 2377: /hilb {
! 2378: hilbert (h) hilbReduce
! 2379: } def
! 2380: [(hilb)
! 2381: [(base vlist hilb f)
! 2382: (array of poly base; array of poly vlist; poly f;)
! 2383: (array of string base; array of string vlist; poly f;)
! 2384: (array of string base; string vlist; number m; poly f;)
! 2385: (f is the hilbert function (a_d x^d + ...)/m!)
! 2386: (The << base >> should be a reduced Grobner basis.)
! 2387: (Or, when the << base >> is an array of string,)
! 2388: (all entries should be monomials.)
! 2389: (Example: [(x^2) (x y )] (x,y) hilb :: h + 2 )
! 2390: (Example: [(x^2) (y^2)] (x,y) hilb 4)
! 2391: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb :: 3)
! 2392: (cf. hilbert, hilbReduce)
! 2393: ]
! 2394: ] putUsages
! 2395:
! 2396: [(diff0)
! 2397: [ (f v n diff0 fn)
! 2398: (<poly> fn, v ; <integer> n ; <poly> fn)
! 2399: (fn = v^n f where v^n is the operator to take the n-th differential.)
! 2400: (We can use diff0 only in the ring of differential operators.)
! 2401: (Example: [(x) ring_of_differential_operators 0] define_ring )
! 2402: ( (x^10-x). (Dx). 1 diff0 ::)
! 2403: ]
! 2404: ] putUsages
! 2405: /diff0 {
! 2406: /arg3 set /arg2 set /arg1 set
! 2407: [/in-diff /f /v /n /fn /rrr] pushVariables
! 2408: [
! 2409: /f arg1 def /v arg2 def /n arg3 def
! 2410: f (0). eq
! 2411: { /fn (0). def }
! 2412: {
! 2413: f (ring) dc /rrr set
! 2414: v toString (^) n toString 3 cat_n rrr ,,
! 2415: f mul
! 2416: [[v (0).] [(h) rrr ,, (1) rrr ,,]] replace /fn set
! 2417: } ifelse
! 2418: fn /arg1 set
! 2419: ] pop
! 2420: popVariables
! 2421: arg1
! 2422: } def
! 2423:
! 2424: [(action)
! 2425: [( f g action p )
! 2426: (<poly> f,g,p)
! 2427: (Act f on g. The result is p. The homogenization variable h is put to 1.)
! 2428: (We can use diff0 only in the ring of differential operators.)
! 2429: (Example: [(x) ring_of_differential_operators 0] define_ring )
! 2430: ( (Dx^2). (x^2). action ::)
! 2431: ]
! 2432: ] putUsages
! 2433: /action {
! 2434: /arg2 set /arg1 set
! 2435: [/in-action /f /g /h /rr /rr.org /rule] pushVariables
! 2436: [
! 2437: /f arg1 def /g arg2 def
! 2438: /rr.org [(CurrentRingp)] system_variable def
! 2439: f (0). eq
! 2440: { /h (0). def }
! 2441: {
! 2442: f (ring) dc /rr set
! 2443: [(CurrentRingp) rr] system_variable
! 2444: f g mul /h set
! 2445: /rule getVariableNames def
! 2446: 0 1 rule length 2 idiv { rule rest /rule set } for
! 2447: rule { . [ 2 1 roll (0). ] } map /rule set
! 2448: rule << rule length 1 sub >> [(h). (1).] put
! 2449: %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
! 2450: /h h rule replace def
! 2451: } ifelse
! 2452: [(CurrentRingp) rr.org ] system_variable
! 2453: /arg1 h def
! 2454: ] pop
! 2455: popVariables
! 2456: arg1
! 2457: } def
! 2458:
! 2459: [(ord_w)
! 2460: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
! 2461: (poly ff; string v1; integer w1; ...)
! 2462: (order of ff by the weight vector [w1 w2 ...])
! 2463: (Example: [(x,y) ring_of_polynomials 0] define_ring )
! 2464: ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
! 2465: ]
! 2466: ] putUsages
! 2467: /ord_w {
! 2468: /arg2 set /arg1 set
! 2469: [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
! 2470: [
! 2471: /fff arg1 def
! 2472: /www arg2 def
! 2473: fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
! 2474: fff (ring) dc /rrr set
! 2475: fff init /fff set
! 2476: /ddd 0 def
! 2477: 0 2 www length 1 sub {
! 2478: /iii set
! 2479: fff << www iii get rrr ,, >> degree
! 2480: << www iii 1 add get >> mul
! 2481: ddd add /ddd set
! 2482: } for
! 2483: /ord_w.LLL
! 2484: /arg1 ddd def
! 2485: ] pop
! 2486: popVariables
! 2487: arg1
! 2488: } def
! 2489:
! 2490: [(laplace0)
! 2491: [
! 2492: (f [v1 ... vn] laplace0 g)
! 2493: (poly f ; string v1 ... vn ; poly g;)
! 2494: (array of poly f ; string v1 ... vn ; array of poly g;)
! 2495: ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
! 2496: $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
! 2497: $ x --> -Dx, Dx --> x, y --> -Dy, Dy --> y. $
! 2498: ]
! 2499: ] putUsages
! 2500: /laplace0 {
! 2501: /arg2 set /arg1 set
! 2502: [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
! 2503: ] pushVariables
! 2504: [
! 2505: /ff arg1 def /vv arg2 def
! 2506: /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
! 2507: /rule [ ] def
! 2508: ff isPolynomial {
! 2509: ff (0). eq { /ans1 (0). def }
! 2510: {
! 2511: ff (ring) dc /rr set
! 2512: /nn vv length def
! 2513: 0 1 nn 1 sub {
! 2514: /ii set
! 2515: vv ii get (type?) dc 1 eq
! 2516: { } % skip, may be weight [(x) 2 ] is OK.
! 2517: {
! 2518: /v0 vv ii get (string) dc def
! 2519: v0 (array) dc 0 get Dascii eq %% If the first character is D?
! 2520: { rule %% Dx-->x
! 2521: [v0 rr ,,
! 2522: v0 (array) dc rest { (string) dc} map aload length cat_n rr ,,]
! 2523: append /rule set
! 2524: }
! 2525: { rule %% x --> -Dx
! 2526: [v0 rr ,,
! 2527: (0).
! 2528: [Dascii] v0 (array) dc join { (string) dc } map aload length
! 2529: cat_n rr ,, sub
! 2530: ]
! 2531: append /rule set
! 2532: } ifelse
! 2533: } ifelse
! 2534: } for
! 2535: % rule message
! 2536: ff rule replace [[(h) rr ,, (1) rr ,,]] replace /ans1 set
! 2537: } ifelse
! 2538: }
! 2539: {
! 2540: ff isArray { /ans1 ff {vv laplace0 } map def }
! 2541: {
! 2542: (laplace0 : the first argument must be a polynomial.) error
! 2543: }ifelse
! 2544: } ifelse
! 2545: /arg1 ans1 def
! 2546: ] pop
! 2547: popVariables
! 2548: arg1
! 2549: } def
! 2550:
! 2551: [(ip1)
! 2552: [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
! 2553: (<poly> v1 ... vn ; <integer> w1 ... wn m)
! 2554: (<poly> f1 ... fs )
! 2555: (Example: [(x,y) ring_of_differential_operators 0] define_ring )
! 2556: ( [(Dx). (Dy).] [2 1] 3 ip1 :: [(2 Dx Dy). (Dy^3).])
! 2557: ( Returns Dx^p Dy^q such that 2 p + 1 q = 3.)
! 2558: ]
! 2559: ] putUsages
! 2560: /ip1 {
! 2561: /arg3 set /arg2 set /arg1 set
! 2562: [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
! 2563: [
! 2564: /vv arg1 def /ww arg2 def /m arg3 def
! 2565: vv 0 get (ring) dc /rr set
! 2566: /rr.org [(CurrentRingp)] system_variable def
! 2567: [(CurrentRingp) rr] system_variable
! 2568: [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
! 2569: /ans [ ] def
! 2570: m 0 lt
! 2571: { }
! 2572: {
! 2573: vv
! 2574: ww { tt 2 1 roll power } map mul /tmp1 set
! 2575: %% (tmp1 = ) messagen tmp1 message
! 2576: 0 1 m {
! 2577: /k set
! 2578: k 0 eq {
! 2579: /ff (1). def
! 2580: }
! 2581: { tmp1 k power /ff set } ifelse
! 2582: ff [[(h). (1).]] replace /ff set
! 2583: %% ff message
! 2584: {
! 2585: ff init tt degree m eq {
! 2586: /ans ans [ ff init [[tt (1).]] replace ] join def
! 2587: } { } ifelse
! 2588: ff ff init sub /ff set
! 2589: ff (0). eq { exit } { } ifelse
! 2590: } loop
! 2591: } for
! 2592: } ifelse
! 2593: [(CurrentRingp) rr.org] system_variable
! 2594: /arg1 ans def
! 2595: ] pop
! 2596: popVariables
! 2597: arg1
! 2598: } def
! 2599:
! 2600: [(findIntegralRoots)
! 2601: [( f findIntegralRoots vlist)
! 2602: (poly f; list of integers vlist;)
! 2603: (string f; list of integers vlist;)
! 2604: (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
! 2605: (Example: (s^4-1) findIntegralRoots )
! 2606: ]
! 2607: ] putUsages
! 2608:
! 2609: /findIntegralRoots { findIntegralRoots.slow } def
! 2610:
! 2611: /findIntegralRoots.slow { %% by a stupid algorithm
! 2612: /arg1 set
! 2613: [/in-findIntegralRoots
! 2614: /ff /kk /roots /rrr /nn /k0 /d.find
! 2615: ] pushVariables
! 2616: [
! 2617: /ff arg1 def
! 2618: /roots [ ] def
! 2619: /rrr [(CurrentRingp)] system_variable def
! 2620: ff toString /ff set
! 2621: [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
! 2622: ff . /ff set
! 2623:
! 2624: %%ff message %% Cancel the common numerical factor of the polynomial ff.
! 2625: ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
! 2626: [(divByN) ff d.find] gbext 0 get /ff set
! 2627: %% d.find message
! 2628: %% ff message
! 2629:
! 2630: ff [[(s). (0).]] replace /k0 set
! 2631: k0 (universalNumber) dc /k0 set
! 2632: k0 (0).. eq { roots (0).. append /roots set } { } ifelse
! 2633:
! 2634: {
! 2635: ff [[(s). (0).]] replace /nn set
! 2636: nn (universalNumber) dc /nn set
! 2637: nn (0).. eq
! 2638: { (s^(-1)). ff mul /ff set }
! 2639: { exit }
! 2640: ifelse
! 2641: } loop
! 2642: ff [[(s). (0).]] replace /k0 set
! 2643: k0 (universalNumber) dc /k0 set
! 2644: k0 (-40000).. gt k0 (40000).. lt and not {
! 2645: [(Roots of b-function cannot be obtained by a stupid method.) nl
! 2646: (Use ox_asir for efficient factorizations, or restall and bfm manually.)
! 2647: nl
! 2648: (ox_asir server will be distributed from the asir ftp cite.) nl
! 2649: (See lib/ttt.tex for details.) nl
! 2650: ] cat
! 2651: error
! 2652: } { } ifelse
! 2653: nn (0).. lt { (0).. nn sub /nn set } { } ifelse
! 2654: /kk (0).. nn sub def
! 2655: /roots [ kk (1).. sub ] roots join def
! 2656: {
! 2657: kk nn gt { exit } { } ifelse
! 2658: ff [[(s). kk (poly) dc]] replace
! 2659: (0). eq
! 2660: { /roots roots kk append def }
! 2661: { } ifelse
! 2662: kk (1).. add /kk set
! 2663: } loop
! 2664: [(CurrentRingp) rrr] system_variable
! 2665: roots { (integer) dc } map /roots set %% ?? OK?
! 2666: roots shell rest /roots set
! 2667: /arg1 roots def
! 2668: ] pop
! 2669: popVariables
! 2670: arg1
! 2671: } def
! 2672:
! 2673: /ngcd {
! 2674: /arg1 set
! 2675: [/in-ngcd /nlist /g.ngcd /ans] pushVariables
! 2676: [
! 2677: /nlist arg1 def
! 2678: nlist length 2 lt
! 2679: { /ans nlist 0 get def /L.ngcd goto }
! 2680: {
! 2681: [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
! 2682: g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
! 2683: [g.ngcd] nlist rest rest join ngcd /ans set
! 2684: } ifelse
! 2685: /L.ngcd
! 2686: ans /arg1 set
! 2687: ] pop
! 2688: popVariables
! 2689: arg1
! 2690: } def
! 2691:
! 2692: [(ngcd)
! 2693: [(nlist ngcd d )
! 2694: (list of numbers nlist; number d;)
! 2695: (d is the gcd of the numbers in nlist.)
! 2696: (Example: [(12345).. (67890).. (98765)..] ngcd )
! 2697: ]] putUsages
! 2698:
! 2699: /dehomogenize {
! 2700: /arg1 set
! 2701: [/in-dehomogenize /f /rr /ans /cring] pushVariables
! 2702: [
! 2703: /f arg1 def
! 2704: f isPolynomial {
! 2705: f (0). eq
! 2706: { f /ans set }
! 2707: {
! 2708: f (ring) dc /rr set
! 2709: [(CurrentRingp)] system_variable /cring set
! 2710: [(CurrentRingp) rr] system_variable
! 2711: f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
! 2712: [(CurrentRingp) cring] system_variable
! 2713: } ifelse
! 2714: }
! 2715: {
! 2716: f isArray {
! 2717: f { dehomogenize } map /ans set
! 2718: }
! 2719: {(dehomogenize: argument should be a polynomial.) error }
! 2720: ifelse
! 2721: } ifelse
! 2722: /arg1 ans def
! 2723: ] pop
! 2724: popVariables
! 2725: arg1
! 2726: } def
! 2727:
! 2728: [(dehomogenize)
! 2729: [(obj dehomogenize obj2)
! 2730: (dehomogenize puts the homogenization variable to 1.)
! 2731: (Example: (x*h+h^2). dehomogenize :: x+1 )
! 2732: ]
! 2733: ] putUsages
! 2734:
! 2735:
! 2736: /from_records { { (,) } map aload length cat_n } def
! 2737: [(from_records)
! 2738: [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
! 2739: (Example : [(x) (y)] from_records :: (x,y,))
! 2740: (cf. to_records)
! 2741: ]
! 2742: ] putUsages
! 2743: /popEnv {
! 2744: { system_variable pop } map pop
! 2745: } def
! 2746:
! 2747: /pushEnv {
! 2748: %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
! 2749: { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
! 2750: } def
! 2751: [(pushEnv)
! 2752: [(keylist pushEnv envlist)
! 2753: (array of string keylist, array of [string object] envlist;)
! 2754: (Values <<envlist>> of the global system variables specified )
! 2755: (by the <<keylist>> is push on the stack.)
! 2756: (keylist is an array of keywords for system_variable.)
! 2757: (cf. system_variable, popEnv)
! 2758: (Example: [(CurrentRingp) (KanGBmessage)] pushEnv)
! 2759: ]
! 2760: ] putUsages
! 2761: [(popEnv)
! 2762: [(envlist popEnv)
! 2763: (cf. pushEnv)
! 2764: ]
! 2765: ] putUsages
! 2766:
! 2767: /npower {
! 2768: /arg2 set
! 2769: /arg1 set
! 2770: [/f /k /i /ans] pushVariables
! 2771: [
! 2772: /f arg1 def /k arg2 ..int def
! 2773: f tag PolyP eq {
! 2774: /ans (1). def
! 2775: } {
! 2776: /ans (1).. def
! 2777: } ifelse
! 2778: k 0 lt {
! 2779: 1 1 << 0 k sub >> {
! 2780: /ans f ans {mul} sendmsg2 def
! 2781: } for
! 2782: /ans (1).. ans {div} sendmsg2 def
! 2783: }
! 2784: {
! 2785: 1 1 k {
! 2786: /ans f ans {mul} sendmsg2 def
! 2787: } for
! 2788: } ifelse
! 2789: /arg1 ans def
! 2790: ] pop
! 2791: popVariables
! 2792: arg1
! 2793: } def
! 2794: [(npower)
! 2795: [(obj1 obj2 npower obj3)
! 2796: (npower returns obj1^obj2 as obj3)
! 2797: (The difference between power and npower occurs when we compute f^0)
! 2798: (where f is a polynomial.)
! 2799: $power returns number(universalNumber) 1, but npower returns 1$
! 2800: (in the current ring.)
! 2801: ]
! 2802: ] putUsages
! 2803:
! 2804: /gensym {
! 2805: (dollar) dc 2 cat_n
! 2806: } def
! 2807: [(gensym)
! 2808: [(x i gensym xi)
! 2809: (string x; integer i; string xi)
! 2810: (It generate a string x indexed with the number i.)
! 2811: $Example: (Dx) 12 gensym (Dx12)$
! 2812: ]
! 2813: ] putUsages
! 2814:
! 2815: /cat {
! 2816: { toString } map aload length cat_n
! 2817: } def
! 2818: [(cat)
! 2819: [(a cat s)
! 2820: (array a ; string s;)
! 2821: (cat converts each entry of << a >> to a string and concatenates them.)
! 2822: (Example: [ (x) 1 2] cat ==> (x12))
! 2823: ]
! 2824: ] putUsages
! 2825:
! 2826:
! 2827: %%%%%%%%%%%%%%%%%%% pmat-level
! 2828: /pmat-level {
! 2829: /arg2 set
! 2830: /arg1 set
! 2831: [/n /i /m /lev /flag] pushVariables
! 2832: [
! 2833: /m arg1 def
! 2834: /lev arg2 def
! 2835: m isArray {
! 2836: /n m length def
! 2837: n 0 eq { /flag 0 def }
! 2838: { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
! 2839: } { /flag 0 def } ifelse
! 2840:
! 2841: flag {
! 2842: 0 1 lev {
! 2843: pop ( ) messagen
! 2844: } for
! 2845: ([ ) message
! 2846: 0 1 n 1 sub {
! 2847: /i set
! 2848: m i get lev 1 add pmat-level
! 2849: } for
! 2850: 0 1 lev {
! 2851: pop ( ) messagen
! 2852: } for
! 2853: (]) message
! 2854: }
! 2855: {
! 2856: 0 1 lev {
! 2857: pop ( ) messagen
! 2858: } for
! 2859: ( ) messagen
! 2860: m message
! 2861: } ifelse
! 2862: ] pop
! 2863: popVariables
! 2864: } def
! 2865:
! 2866: /pmat { 0 pmat-level } def
! 2867:
! 2868: [(pmat)
! 2869: [(f pmat)
! 2870: (array f;)
! 2871: (f is pretty printed.)
! 2872: ]
! 2873: ] putUsages
! 2874:
! 2875:
! 2876: /adjoint1 {
! 2877: /arg2 set
! 2878: /arg1 set
! 2879: [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
! 2880: [
! 2881: /f arg1 def
! 2882: /xx arg2 def
! 2883: f isPolynomial { }
! 2884: { (adjoint1: the first argument must be a polynomial.) message
! 2885: pop popVariables
! 2886: (adjoint1: the first argument must be a polynomial.) error
! 2887: } ifelse
! 2888: /ans (0). def
! 2889: f (0). eq { }
! 2890: {
! 2891: /xx xx (string) dc def
! 2892: /dxx [@@@.Dsymbol xx] cat def
! 2893: /xx xx f (ring) dc ,, def
! 2894: /dxx dxx f (ring) dc ,, def
! 2895: /one (1) f (ring) dc ,, def
! 2896:
! 2897: {
! 2898: /g f init def
! 2899: /f f g sub def
! 2900: /p g xx degree def
! 2901: /q g dxx degree def
! 2902: g [[xx one] [dxx one]] replace /g set
! 2903: g
! 2904: << (0). dxx sub q npower xx p npower mul >>
! 2905: mul
! 2906: ans add /ans set
! 2907: f (0). eq { exit } { } ifelse
! 2908: } loop
! 2909: ans dehomogenize /ans set
! 2910: } ifelse
! 2911: /arg1 ans def
! 2912: ] pop
! 2913: popVariables
! 2914: arg1
! 2915: } def
! 2916:
! 2917: /adjoint {
! 2918: /arg2 set
! 2919: /arg1 set
! 2920: [/in-adjoint /f /xx /xx0] pushVariables
! 2921: [
! 2922: /f arg1 def /xx arg2 def
! 2923: xx toString /xx set
! 2924: [xx to_records pop] /xx set
! 2925: xx { /xx0 set f xx0 adjoint1 /f set } map
! 2926: /arg1 f def
! 2927: ]pop
! 2928: popVariables
! 2929: arg1
! 2930: } def
! 2931:
! 2932: [(adjoint)
! 2933: [(f xlist adjoint g)
! 2934: (poly f; string xlist; poly g;)
! 2935: (g is the adjoint operator of f.)
! 2936: (The variables to take adjoint are specified by xlist.)
! 2937: (Example: [(x,y) ring_of_differential_operators 0] define_ring)
! 2938: ( (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
! 2939: $ ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
! 2940: ]] putUsages
! 2941:
! 2942: %%%%% diagonal for tensor products
! 2943: %% 1998, 12/4 (Sat)
! 2944: %% s_i = x_i, t_i = x_i - y_i, Restrict to t_i = 0.
! 2945: %% x_i = x_i, y_i = s_i - t_i,
! 2946: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
! 2947: /diagonalx {
! 2948: /arg2 set
! 2949: /arg1 set
! 2950: [/in-diagonalx /f] pushVariables
! 2951: [
! 2952: (Not implemented yet.) message
! 2953: ] pop
! 2954: popVariables
! 2955: arg1
! 2956: } def
! 2957:
! 2958:
! 2959:
! 2960: %%%%%%%%%%% distraction2 for b-function
! 2961: /distraction2 {
! 2962: /arg4 set
! 2963: /arg3 set
! 2964: /arg2 set
! 2965: /arg1 set
! 2966: [/f /dx /ss /xx /ans /n /i /rr] pushVariables
! 2967: [
! 2968: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
! 2969: f (0). eq { }
! 2970: {
! 2971: /rr f (ring) dc def
! 2972: xx {toString rr ,, } map /xx set
! 2973: dx {toString rr ,, } map /dx set
! 2974: ss {toString rr ,, } map /ss set
! 2975: /n xx length def
! 2976: 0 1 n 1 sub {
! 2977: /i set
! 2978: /f f xx i get dx i get ss i get destraction2.1 /f set
! 2979: } for
! 2980: } ifelse
! 2981: /arg1 f def
! 2982: ]pop
! 2983: popVariables
! 2984: arg1
! 2985: } def
! 2986: [(distraction2)
! 2987: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
! 2988: ( distraction2 result )
! 2989: $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
! 2990: $ (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
! 2991: $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
! 2992: ]
! 2993: ] putUsages
! 2994: /destraction2.1 {
! 2995: /arg4 set
! 2996: /arg3 set
! 2997: /arg2 set
! 2998: /arg1 set
! 2999: [/ww /f /dx /ss /xx /coeff0 /expvec
! 3000: /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
! 3001: [
! 3002: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
! 3003: f (ring) dc /rr set
! 3004: /one (1) rr ,, def %%
! 3005: /ww [ xx toString -1 dx toString 1 ] weightv def
! 3006: f ww init f sub (0). eq { }
! 3007: { [(destraction2.1 : inhomogeneous with respect to )
! 3008: xx ( and ) dx nl
! 3009: (Your weight vector may not be generic.)
! 3010: ] cat error } ifelse
! 3011: /dd << f dx degree >> << f xx degree >> sub def
! 3012: f [[xx one]] replace dx coefficients /coeff0 set
! 3013: /expvec coeff0 0 get { (integer) dc } map def
! 3014: /coeffvec coeff0 1 get def
! 3015: expvec { ss 2 -1 roll factorial } map /expvec2 set
! 3016: expvec2 coeffvec mul /ans set
! 3017: %% x^p d^q, (p > q) case. x^2( x^2 Dx^2 + x Dx + 1)
! 3018: dd 0 lt {
! 3019: %% (ss+1) (ss+2) ... (ss+d)
! 3020: one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
! 3021: ans mul /ans set
! 3022: }
! 3023: { } ifelse
! 3024: /arg1 ans def
! 3025: ] pop
! 3026: popVariables
! 3027: arg1
! 3028: } def
! 3029:
! 3030: /message-quiet {
! 3031: @@@.quiet { pop } { message } ifelse
! 3032: } def
! 3033: [(message-quiet)
! 3034: [(s message-quiet )
! 3035: (string s;)
! 3036: (It outputs the message s when @@@.quiet is not equal to 1.)
! 3037: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
! 3038: ]] putUsages
! 3039: /messagen-quiet {
! 3040: @@@.quiet { pop } { messagen } ifelse
! 3041: } def
! 3042: [(messagen-quiet)
! 3043: [(s messagen-quiet )
! 3044: (string s;)
! 3045: (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
! 3046: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
! 3047: ]] putUsages
! 3048:
! 3049: /getvNames0 {
! 3050: /arg1 set
! 3051: [/in-getvNames0 /nlist /nn /i] pushVariables
! 3052: [
! 3053: /nlist arg1 def
! 3054: [(N)] system_variable /nn set
! 3055: nlist { /i set
! 3056: i nn lt {
! 3057: [(x) (var) i] system_variable
! 3058: } {
! 3059: [(D) (var) i nn sub] system_variable
! 3060: } ifelse
! 3061: } map
! 3062: /arg1 set
! 3063: ] pop
! 3064: popVariables
! 3065: arg1
! 3066: } def
! 3067:
! 3068: /getvNames {
! 3069: [/in-getvNames /nn] pushVariables
! 3070: [
! 3071: [(N)] system_variable /nn set
! 3072: [0 1 nn 2 mul 1 sub { } for] getvNames0 /arg1 set
! 3073: ] pop
! 3074: popVariables
! 3075: arg1
! 3076: } def
! 3077: [(getvNames)
! 3078: [(getvNames vlist)
! 3079: (list vlist)
! 3080: (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
! 3081: (Use with [(variableNames) vlist] system_variable.)
! 3082: (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
! 3083: ]] putUsages
! 3084:
! 3085: /getvNamesC {
! 3086: [/in-getvNamesC /nn /i] pushVariables
! 3087: [
! 3088: [(N)] system_variable /nn set
! 3089: [nn 1 sub -1 0 { } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
! 3090: ] pop
! 3091: popVariables
! 3092: arg1
! 3093: } def
! 3094: [(getvNamesC)
! 3095: [(getvNamesC vlist)
! 3096: (list vlist)
! 3097: $It returns of the list of the variables in the order 0, 1, 2, ... $
! 3098: $(cmo-order and output_order).$
! 3099: (cf. getvNames)
! 3100: ]] putUsages
! 3101:
! 3102: /getvNamesCR {
! 3103: /arg1 set
! 3104: [/in-getvNamesCR /rrr] pushVariables
! 3105: [(CurrentRingp)] pushEnv
! 3106: [
! 3107: /rrr arg1 def
! 3108: rrr isPolynomial {
! 3109: rrr (0). eq { (No name field for 0 polynomial.) error }
! 3110: { rrr (ring) dc /rrr set } ifelse
! 3111: } { } ifelse
! 3112: [(CurrentRingp) rrr] system_variable
! 3113: getvNamesC /arg1 set
! 3114: ] pop
! 3115: popEnv
! 3116: popVariables
! 3117: arg1
! 3118: } def
! 3119: [(getvNamesCR)
! 3120: [(obj getvNamesCR vlist)
! 3121: (obj ring | poly ; list vlist)
! 3122: $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
! 3123: (for <<obj>>.)
! 3124: (Example: ( (x-2)^3 ). /ff set )
! 3125: ( [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
! 3126: ]] putUsages
! 3127:
! 3128:
! 3129: /reduction-noH {
! 3130: /arg2 set
! 3131: /arg1 set
! 3132: [/in-reduction-noH /ff /gg] pushVariables
! 3133: [(Homogenize)] pushEnv
! 3134: [
! 3135: /ff arg1 def
! 3136: /gg arg2 def
! 3137: [(Homogenize) 0] system_variable
! 3138: ff gg reduction /arg1 set
! 3139: ] pop
! 3140: popEnv
! 3141: popVariables
! 3142: arg1
! 3143: } def
! 3144: [(reduction-noH)
! 3145: [(f g reduction-noH r)
! 3146: (poly f; array g; array r;)
! 3147: (Apply the normal form algorithm for f with the set g. All computations are)
! 3148: (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
! 3149: (specifications are the same with reduction. cf. reduction)
! 3150: (g should be dehomogenized.)
! 3151: ]] putUsages
! 3152:
! 3153: /-intInfinity -999999999 def
! 3154: /intInfinity 999999999 def
! 3155: [(intInfinity)
! 3156: [(intInfinity = 999999999)]
! 3157: ] putUsages
! 3158: [(-intInfinity)
! 3159: [(-intInfinity = -999999999)]
! 3160: ] putUsages
! 3161:
! 3162:
! 3163: /maxInArray {
! 3164: /arg1 set
! 3165: [/in-maxInArray /v /ans /i /n] pushVariables
! 3166: [
! 3167: /v arg1 def
! 3168: /n v length def
! 3169: /maxInArray.pos 0 def
! 3170: n 0 eq {
! 3171: /ans null def
! 3172: } {
! 3173: /ans v 0 get def
! 3174: 1 1 n 1 sub {
! 3175: /i set
! 3176: v i get ans gt {
! 3177: /ans v i get def
! 3178: /maxInArray.pos i def
! 3179: } { } ifelse
! 3180: } for
! 3181: } ifelse
! 3182: /arg1 ans def
! 3183: ] pop
! 3184: popVariables
! 3185: arg1
! 3186: } def
! 3187: [(maxInArray)
! 3188: [( [v1 v2 ....] maxInArray m )
! 3189: (m is the maximum in [v1 v2 ...].)
! 3190: (The position of m is stored in the global variable maxInArray.pos.)
! 3191: ]] putUsages
! 3192:
! 3193: /cancelCoeff {
! 3194: /arg1 set
! 3195: [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
! 3196: [ /ff arg1 def
! 3197: ff (0). eq {
! 3198: /label.cancelCoeff2 goto
! 3199: } { } ifelse
! 3200: /gg ff def
! 3201: /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
! 3202: {
! 3203: gg (0). eq { exit} { } ifelse
! 3204: [(lcoeff) gg init] gbext (universalNumber) dc /dd2 set
! 3205: [(gcd) dd dd2] mpzext /dd set
! 3206: dd (1).. eq {
! 3207: /label.cancelCoeff goto
! 3208: } { } ifelse
! 3209: /gg gg gg init sub def
! 3210: } loop
! 3211: [(divByN) ff dd] gbext 0 get /ff set
! 3212: /label.cancelCoeff
! 3213: [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
! 3214: { ff (-1).. mul /ff set } { } ifelse
! 3215: /label.cancelCoeff2
! 3216: /arg1 ff def
! 3217: ] pop
! 3218: popVariables
! 3219: arg1
! 3220: } def
! 3221: [(cancelCoeff)
! 3222: [(f cancelcoeff g)
! 3223: (poly f,g;)
! 3224: (Factor out the gcd of the coefficients.)
! 3225: (Example: (6 x^2 - 10 x). cancelCoeff)
! 3226: (See also gbext.)
! 3227: ]] putUsages
! 3228:
! 3229:
! 3230: /flatten {
! 3231: /arg1 set
! 3232: [/in-flatten /mylist] pushVariables
! 3233: [
! 3234: /mylist arg1 def
! 3235: mylist isArray {
! 3236: mylist { dup isArray { aload pop } { } ifelse } map /mylist set
! 3237: }{ } ifelse
! 3238: /arg1 mylist def
! 3239: ] pop
! 3240: popVariables
! 3241: arg1
! 3242: } def
! 3243: [(flatten)
! 3244: [(list flatten list2)
! 3245: (Flatten the list.)
! 3246: (Example 1: [ [1 2 3] 4 [2]] flatten ===> [1 2 3 4 2])
! 3247: ]] putUsages
! 3248:
! 3249: %% Take first N elements.
! 3250: /carN {
! 3251: /arg2 set
! 3252: /arg1 set
! 3253: [/in-res-getN /pp /nn /ans] pushVariables
! 3254: [
! 3255: /nn arg2 def
! 3256: /pp arg1 def
! 3257: pp isArray {
! 3258: pp length nn lt {
! 3259: /ans pp def
! 3260: } {
! 3261: [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
! 3262: } ifelse
! 3263: } {
! 3264: /ans pp def
! 3265: } ifelse
! 3266: /arg1 ans def
! 3267: ] pop
! 3268: popVariables
! 3269: arg1
! 3270: } def
! 3271: [(carN)
! 3272: [([f1 ... fm] n carN [f1 ... fn])
! 3273: (carN extracts the first n elements from the list.)
! 3274: ]] putUsages
! 3275:
! 3276: /getRing {
! 3277: /arg1 set
! 3278: [/in-getRing /aa /n /i /ans] pushVariables
! 3279: [
! 3280: /aa arg1 def
! 3281: /ans null def
! 3282: aa isPolynomial {
! 3283: aa (0). eq {
! 3284: } {
! 3285: /ans aa (ring) dc def
! 3286: } ifelse
! 3287: } {
! 3288: aa isArray {
! 3289: /n aa length 1 sub def
! 3290: 0 1 n { /i set aa i get getRing /ans set
! 3291: ans tag 0 eq { } { /getRing.LLL goto } ifelse
! 3292: } for
! 3293: }{ } ifelse
! 3294: } ifelse
! 3295: /getRing.LLL
! 3296: /arg1 ans def
! 3297: ] pop
! 3298: popVariables
! 3299: arg1
! 3300: } def
! 3301: [(getRing)
! 3302: [(obj getRing rr)
! 3303: (ring rr;)
! 3304: (getRing obtains the ring structure from obj.)
! 3305: (If obj is a polynomial, it returns the ring structure associated to)
! 3306: (the polynomial.)
! 3307: (If obj is an array, it recursively looks for the ring structure.)
! 3308: ]] putUsages
! 3309: /toVectors {
! 3310: /arg1 set
! 3311: [/in-toVectors /gg /n /ans] pushVariables
! 3312: [
! 3313: /gg arg1 def
! 3314: gg isArray {
! 3315: gg length 0 eq {
! 3316: /ans [ ] def
! 3317: /toVectors.LLL goto
! 3318: } {
! 3319: gg 0 get isInteger {
! 3320: gg @@@.toVectors2 /ans set
! 3321: } {
! 3322: gg @@@.toVectors /ans set
! 3323: } ifelse
! 3324: /toVectors.LLL goto
! 3325: } ifelse
! 3326: } {
! 3327: %% It is not array.
! 3328: gg (array) dc /ans set
! 3329: } ifelse
! 3330: /toVectors.LLL
! 3331: /arg1 ans def
! 3332: ] pop
! 3333: popVariables
! 3334: arg1
! 3335: } def
! 3336: /@@@.toVectors2 {
! 3337: /arg1 set
! 3338: [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
! 3339: [
! 3340: /gg arg1 def
! 3341: /ans gg 1 get @@@.toVectors def
! 3342: /n gg 0 get def
! 3343: gg 1 get isArray not {
! 3344: /ans [ans] def
! 3345: /notarray 1 def
! 3346: }{ /notarray 0 def} ifelse
! 3347: ans {
! 3348: /tmp set
! 3349: tmp length n lt {
! 3350: tmp
! 3351: [1 1 n tmp length sub { pop (0). } for ]
! 3352: join /tmp set
! 3353: } { } ifelse
! 3354: tmp
! 3355: } map
! 3356: /ans set
! 3357: notarray { ans 0 get /ans set } { } ifelse
! 3358: /arg1 ans def
! 3359: ] pop
! 3360: popVariables
! 3361: arg1
! 3362: } def
! 3363:
! 3364: /@@@.toVectors {
! 3365: /arg1 set
! 3366: [/in-@@@.toVectors /gg ] pushVariables
! 3367: [
! 3368: /gg arg1 def
! 3369: gg isArray {
! 3370: gg { $array$ data_conversion } map
! 3371: } {
! 3372: gg (array) data_conversion
! 3373: }ifelse
! 3374: /arg1 set
! 3375: ] pop
! 3376: popVariables
! 3377: arg1
! 3378: } def
! 3379:
! 3380: /toVectors2 { toVectors } def
! 3381:
! 3382: /fromVectors { { fromVectors.aux } map } def
! 3383: /fromVectors.aux {
! 3384: /arg1 set
! 3385: [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
! 3386: [(CurrentRingp)] pushEnv
! 3387: [
! 3388: /vv arg1 def
! 3389: /mm vv length def
! 3390: /ans (0). def
! 3391: /ee (0). def
! 3392: 0 1 mm 1 sub {
! 3393: /i set
! 3394: vv i get (0). eq {
! 3395: } {
! 3396: [(CurrentRingp) vv i get (ring) dc] system_variable
! 3397: [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
! 3398: /fromVector.LLL goto
! 3399: } ifelse
! 3400: } for
! 3401: /fromVector.LLL
! 3402: %% vv message
! 3403: 0 1 mm 1 sub {
! 3404: /i set
! 3405: vv i get (0). eq {
! 3406: } {
! 3407: /ans ans
! 3408: << vv i get >> << ee i npower >> mul
! 3409: add def
! 3410: } ifelse
! 3411: %% [i ans] message
! 3412: } for
! 3413: /arg1 ans def
! 3414: ] pop
! 3415: popEnv
! 3416: popVariables
! 3417: arg1
! 3418: } def
! 3419: [(fromVectors)
! 3420: [
! 3421: ([v1 v2 ...] fromVectors [s1 s2 ...])
! 3422: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
! 3423: (cf. toVectors. <<e_>> varaible is assumed to be the last )
! 3424: ( variable in x. @@@.esymbol)
! 3425: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
! 3426: $ [(x). (y).] /ff set $
! 3427: $ [ff ff] fromVectors :: $
! 3428: ]] putUsages
! 3429:
! 3430: /getOrderMatrix {
! 3431: /arg1 set
! 3432: [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
! 3433: [(CurrentRingp)] pushEnv
! 3434: [
! 3435: /obj arg1 def
! 3436: obj isArray {
! 3437: obj { getOrderMatrix } map /ans set
! 3438: ans length 0 {
! 3439: /ans null def
! 3440: } {
! 3441: /ans2 null def
! 3442: 0 1 ans length 1 sub {
! 3443: /i set
! 3444: ans i get tag 0 eq
! 3445: { }
! 3446: { /ans2 ans i get def } ifelse
! 3447: } for
! 3448: /ans ans2 def
! 3449: } ifelse
! 3450: /getOrderMatrix.LLL goto
! 3451: } { } ifelse
! 3452: obj tag 14 eq {
! 3453: [(CurrentRingp) obj] system_variable
! 3454: [(orderMatrix)] system_variable /ans set
! 3455: /getOrderMatrix.LLL goto
! 3456: } { } ifelse
! 3457: obj isPolynomial {
! 3458: obj (0). eq
! 3459: { /ans null def
! 3460: } { obj getRing /rr set
! 3461: [(CurrentRingp) rr] system_variable
! 3462: [(orderMatrix)] system_variable /ans set
! 3463: } ifelse
! 3464: /getOrderMatrix.LLL goto
! 3465: } { (getOrderMatrix: wrong argument.) error } ifelse
! 3466: /getOrderMatrix.LLL
! 3467: /arg1 ans def
! 3468: ] pop
! 3469: popEnv
! 3470: popVariables
! 3471: arg1
! 3472: } def
! 3473:
! 3474:
! 3475: [(getOrderMatrix)
! 3476: [(obj getOrderMatrix m)
! 3477: (array m)
! 3478: (getOrderMatrix obtains the order matrix from obj.)
! 3479: (If obj is a polynomial, it returns the order matrix associated to)
! 3480: (the polynomial.)
! 3481: (If obj is an array, it returns an order matrix of an element.)
! 3482: ]] putUsages
! 3483:
! 3484: /nl {
! 3485: 10 $string$ data_conversion
! 3486: } def
! 3487: [(nl)
! 3488: [(nl is the newline character.)
! 3489: $Example: [(You can break line) nl (here.)] cat message$
! 3490: ]] putUsages
! 3491:
! 3492: ;
! 3493:
! 3494:
! 3495:
! 3496:
! 3497:
! 3498:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to dr.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Kan