[BACK]Return to dr.sm1 CVS log [TXT][DIR] Up to [local] / OpenXM / src / kan96xx / Kan

Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.2

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>