[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.54

1.54    ! takayama    1: % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.53 2006/02/04 02:44:39 takayama Exp $
1.1       maekawa     2: %% dr.sm1 (Define Ring) 1994/9/25, 26
                      3: %% This file is error clean.
                      4:
                      5: @@@.quiet {   }
1.5       takayama    6: { (macro package : dr.sm1,   9/26,1995 --- Version 12/10, 2000. ) 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:
1.28      takayama   53:      [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1       maekawa    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]
1.28      takayama  170:      [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1       maekawa   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:   [
1.8       takayama  260:      (This is an obsolete macro. Use ring_of_differential_difference_operators)
                    261:       error
1.1       maekawa   262:      (mmLarger) (matrix) switch_function
                    263:      (mpMult)   (difference) switch_function
                    264:      (red@)     (module1) switch_function
                    265:      (groebner) (standard) switch_function
                    266:      (isSameComponent) (x) switch_function
                    267:
                    268:      [arg1 to_records pop] /vars set %[x y z]
                    269:      vars reverse /xList set         %[z y x]
                    270:      vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
                    271:      reverse /dList set              %[Dz Dy Dx]
1.28      takayama  272:      [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1       maekawa   273:      [(h)] dList join [@@@.Esymbol] join /dList set
                    274:      [0 1 1 << xList length >> << xList length >>
                    275:         1 1 << xList length 1 sub >> << xList length >> ] /param set
                    276:      [ xList dList param ] /arg1 set
                    277:   ] pop
                    278:   popVariables
                    279:   arg1
                    280: } def
                    281:
                    282:
1.8       takayama  283: /ring_of_differential_difference_operators {
                    284:   /arg1 set
                    285:   [/vars /n /i /xList /dList /param /dvar /evar /vars2 ] pushVariables
                    286:   [
                    287:      /vars arg1 def
                    288:      vars tag 6 eq not {
                    289:        ( List is expected as the argument for ring_of_differential_difference_operators ) error
                    290:      } { } ifelse
                    291:      vars 0 get /dvar set
                    292:      vars 1 get /evar set
                    293:      (mmLarger) (matrix) switch_function
                    294:      (mpMult)   (difference) switch_function
                    295:      (red@)     (module1) switch_function
                    296:      (groebner) (standard) switch_function
                    297:      (isSameComponent) (x) switch_function
                    298:
                    299:      [dvar to_records pop] /vars set %[x y z]
                    300:      vars reverse /xList set         %[z y x]
                    301:
                    302:      [evar to_records pop] /vars2 set %[s1 s2]
                    303:
                    304:      vars2 reverse  {@@@.Esymbol 2 1 roll 2 cat_n} map
                    305:      xList
                    306:      join /xList set   %[Es2 Es1 z y x]
                    307:
                    308:      vars2 reverse
                    309:      vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
                    310:      reverse join /dList set              %[s2 s1 Dz Dy Dx]
1.28      takayama  311:      [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.8       takayama  312:      [(h)] dList join [@@@.Esymbol] join /dList set
                    313:      [0 1 1 << vars2 length 1 add >>  << xList length >>
                    314:         1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set
                    315:      [ xList dList param ] /arg1 set
                    316:   ] pop
                    317:   popVariables
                    318:   arg1
                    319: } def
1.1       maekawa   320:
                    321: /reverse {
                    322:   /arg1 set
                    323:   arg1 length 1 lt
                    324:   { [ ] }
                    325:   {
                    326:     [
                    327:      <<  arg1 length 1 sub >> -1 0
                    328:      {
                    329:         arg1 2 1 roll get
                    330:       } for
                    331:      ]
                    332:    } ifelse
                    333: } def
                    334:
                    335: /memberQ {
                    336: %% a set0 memberQ bool
                    337:   /arg2 set  /arg1 set
                    338:   [/a /set0 /flag /i ] pushVariables
                    339:   [
                    340:      /a arg1 def  /set0 arg2 def
                    341:      /flag 0 def
                    342:      0 1 << set0 length 1 sub >>
                    343:      {
                    344:         /i set
1.42      takayama  345:         set0 i get tag , a tag , eq {
                    346:           << set0 i get >> a eq
                    347:           {
                    348:              /flag 1 def  exit
                    349:            }
                    350:           { }
                    351:           ifelse
                    352:         } {  } ifelse
1.1       maekawa   353:      } for
                    354:   ] pop
                    355:   /arg1 flag def
                    356:   popVariables
                    357:   arg1
                    358: } def
                    359:
                    360: /transpose {
                    361:   /arg1 set
                    362:   [/mat /m /n /ans /i /j] pushVariables
                    363:   [
                    364:     /mat arg1 def
                    365:     /m mat length def
1.34      takayama  366:   {
                    367:     m 0 eq { /ans [ ] def exit } { } ifelse
1.1       maekawa   368:     mat 0 get isArray
                    369:     {   }
                    370:     { (transpose: Argument must be an array of arrays.) error }
                    371:     ifelse
                    372:     /n mat 0 get length def
                    373:     /ans [ 1 1 n { pop [ 1 1 m { pop 0 } for ]} for ] def
                    374:     0 1 << m 1 sub >> {
                    375:        /i set
                    376:        0 1 << n 1 sub >> {
                    377:          /j set
                    378:          ans [ j i ]  <<  mat i get j get >> put
                    379:       } for
                    380:     } for
1.34      takayama  381:     exit
                    382:    } loop
1.1       maekawa   383:    /arg1 ans def
                    384:   ] pop
                    385:   popVariables
                    386:   arg1
                    387: } def
                    388:
                    389:
                    390: /getPerm {
                    391: %% old new getPerm perm
                    392:   /arg2 set /arg1 set
                    393:   [/old /new /i /j /p] pushVariables
                    394:   [
                    395:     /old arg1 def
                    396:     /new arg2 def
                    397:     [
                    398:         /p old length def
                    399:         0 1 << p 1 sub >>
                    400:         {
                    401:            /i set
                    402:            0 1 << p 1 sub >>
                    403:            {
                    404:               /j set
                    405:               old i get
                    406:               new j get
                    407:               eq
                    408:               { j }
                    409:               {   } ifelse
                    410:             } for
                    411:          } for
                    412:      ] /arg1 set
                    413:    ] pop
                    414:    popVariables
                    415:    arg1
                    416: } def
                    417:
                    418: /permuteOrderMatrix {
                    419: %% order perm puermuteOrderMatrix newOrder
                    420:   /arg2 set /arg1 set
                    421:   [/order /perm /newOrder /k ] pushVariables
                    422:   [
                    423:     /order arg1 def
                    424:     /perm arg2 def
                    425:     order transpose /order set
                    426:     order 1 copy /newOrder set pop
                    427:
                    428:     0 1 << perm length 1 sub >>
                    429:     {
                    430:        /k set
                    431:        newOrder << perm k get >> << order k get >> put
                    432:     } for
                    433:     newOrder transpose /newOrder set
                    434:   ] pop
                    435:   /arg1 newOrder def
                    436:   popVariables
                    437:   arg1
                    438: } def
                    439:
                    440:
                    441:
                    442: /complement {
                    443: %% set0 universe complement compl
                    444:   /arg2 set /arg1 set
                    445:   [/set0 /universe /compl /i] pushVariables
                    446:    /set0 arg1 def  /universe arg2 def
                    447:   [
                    448:      0 1 << universe length 1 sub >>
                    449:      {
                    450:         /i set
                    451:         << universe i get >> set0 memberQ
                    452:         {   }
                    453:         { universe i get }
                    454:         ifelse
                    455:       } for
                    456:    ] /arg1 set
                    457:    popVariables
                    458:    arg1
                    459: } def
                    460:
                    461:
                    462: %%% from order.sm1
                    463:
                    464: %% size i evec [0 0 ... 0 1 0 ... 0]
                    465: /evec {
                    466:  /arg2 set /arg1 set
                    467:  [/size /iii] pushVariables
                    468:  /size arg1 def  /iii arg2 def
                    469:  [
                    470:    0 1 << size 1 sub >>
                    471:    {
                    472:       iii eq
                    473:       {  1 }
                    474:       {  0 }
                    475:       ifelse
                    476:    } for
                    477:   ] /arg1 set
                    478:   popVariables
                    479:   arg1
                    480: } def
                    481:
                    482: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
                    483: /evec_neg {
                    484:  /arg2 set /arg1 set
                    485:  [/size /iii] pushVariables
                    486:  /size arg1 def  /iii arg2 def
                    487:  [
                    488:    0 1 << size 1 sub >>
                    489:    {
                    490:       iii eq
                    491:       {  -1 }
                    492:       {  0 }
                    493:       ifelse
                    494:    } for
                    495:   ] /arg1 set
                    496:   popVariables
                    497:   arg1
                    498: } def
                    499:
                    500:
                    501: %% size i j e_ij  << matrix e(i,j) >>
                    502: /e_ij {
                    503:   /arg3 set /arg2 set /arg1 set
                    504:   [/size /k /i /j] pushVariables
                    505:   [
                    506:     /size arg1 def  /i arg2 def /j arg3 def
                    507:     [ 0 1 << size 1 sub >>
                    508:       {
                    509:          /k set
                    510:          k i eq
                    511:          { size j evec }
                    512:          {
                    513:             k j eq
                    514:             { size i evec }
                    515:             { size k evec }
                    516:             ifelse
                    517:           } ifelse
                    518:        } for
                    519:      ] /arg1 set
                    520:    ] pop
                    521:    popVariables
                    522:    arg1
                    523: } def
                    524:
                    525:
                    526: %% size i j d_ij  << matrix E_{ij} >>
                    527: /d_ij {
                    528:   /arg3 set /arg2 set /arg1 set
                    529:   [/size /k /i /j] pushVariables
                    530:   [
                    531:     /size arg1 def  /i arg2 def /j arg3 def
                    532:     [ 0 1 << size 1 sub >>
                    533:       {
                    534:          /k set
                    535:          k i eq
                    536:          { size j evec }
                    537:          {
                    538:             [ 0 1 << size 1 sub >> { pop 0} for ]
                    539:           } ifelse
                    540:        } for
                    541:      ] /arg1 set
                    542:    ] pop
                    543:    popVariables
                    544:    arg1
                    545: } def
                    546:
                    547: %% size matid << id matrix  >>
                    548: /matid {
                    549:   /arg1 set
                    550:   [/size /k ] pushVariables
                    551:   [
                    552:     /size arg1 def
                    553:     [ 0 1 << size 1 sub >>
                    554:       {
                    555:          /k set
                    556:          size k evec
                    557:        } for
                    558:      ] /arg1 set
                    559:    ] pop
                    560:    popVariables
                    561:    arg1
                    562: } def
                    563:
                    564:
                    565: %% m1 m2 oplus
                    566: /oplus {
                    567:   /arg2 set /arg1 set
                    568:   [/m1 /m2 /n /m  /k ] pushVariables
                    569:   [
                    570:     /m1 arg1 def  /m2 arg2 def
                    571:     m1 length /n set
                    572:     m2 length /m set
                    573:     [
                    574:       0 1 << n m add 1 sub >>
                    575:       {
                    576:         /k set
                    577:         k n lt
                    578:         {
                    579:             << m1 k get >> << m -1 evec >> join
                    580:         }
                    581:         {
                    582:             << n -1 evec >> << m2 << k n sub >> get >> join
                    583:         } ifelse
                    584:       } for
                    585:      ] /arg1 set
                    586:    ] pop
                    587:    popVariables
                    588:    arg1
                    589: } def
                    590:
                    591: %%%%%%%%%%%%%%%%%%%%%%%
                    592:
                    593: /eliminationOrderTemplate  { %% esize >= 1
                    594: %% if esize == 0, it returns reverse lexicographic order.
                    595: %%  m esize eliminationOrderTemplate mat
                    596:   /arg2 set /arg1 set
                    597:   [/m  /esize /m1 /m2 /k ] pushVariables
                    598:   [
                    599:     /m arg1 def  /esize arg2 def
                    600:     /m1 m esize sub 1 sub def
                    601:     /m2 esize 1 sub def
                    602:      [esize 0 gt
                    603:       {
                    604:        [1 1 esize
                    605:         { pop 1 } for
                    606:         esize 1 << m 1 sub >>
                    607:         { pop 0 } for
                    608:        ]  %% 1st vector
                    609:       }
                    610:       { } ifelse
                    611:
                    612:       m esize gt
                    613:       {
                    614:        [1 1  esize
                    615:         { pop 0 } for
                    616:         esize 1 << m 1 sub >>
                    617:         { pop 1 } for
                    618:        ]  %% 2nd vector
                    619:       }
                    620:       { } ifelse
                    621:
                    622:       m1 0 gt
                    623:       {
                    624:          m 1 sub -1 << m m1 sub >>
                    625:          {
                    626:               /k set
                    627:               m  k  evec_neg
                    628:          } for
                    629:       }
                    630:       { } ifelse
                    631:
                    632:       m2 0 gt
                    633:       {
                    634:          << esize 1 sub >> -1 1
                    635:          {
                    636:               /k set
                    637:               m  k  evec_neg
                    638:          } for
                    639:       }
                    640:       { } ifelse
                    641:
                    642:     ] /arg1 set
                    643:    ] pop
                    644:    popVariables
                    645:    arg1
                    646: } def
                    647:
                    648: /elimination_order {
                    649: %% [x-list d-list params]  (x,y,z) elimination_order
                    650: %%  vars                    evars
                    651: %% [x-list d-list params order]
                    652:   /arg2 set  /arg1 set
                    653:   [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
                    654:   /vars arg1 def /evars [arg2 to_records pop] def
                    655:   [
                    656:     /univ vars 0 get reverse
                    657:           vars 1 get reverse join
                    658:     def
                    659:
                    660:     << univ length 2 sub >>
                    661:     << evars length >>
                    662:     eliminationOrderTemplate /order set
                    663:
                    664:     [[1]] order oplus [[1]] oplus /order set
                    665:
                    666:     /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
                    667:
                    668:     /compl
                    669:       [univ 0 get] evars join evars univ0 complement join
                    670:     def
                    671:     compl univ
                    672:     getPerm /perm set
                    673:     %%perm :: univ :: compl ::
                    674:
                    675:     order perm permuteOrderMatrix /order set
                    676:
                    677:
                    678:     vars [order] join /arg1 set
                    679:   ] pop
                    680:   popVariables
                    681:   arg1
                    682: } def
                    683:
                    684: /elimination_order2 {
                    685: %% [x-list d-list params]  (x,y,z) elimination_order
                    686: %%  vars                    evars
                    687: %% [x-list d-list params order]
                    688: %% with no graduation and homogenization variables.
                    689:   /arg2 set  /arg1 set
                    690:   [/vars /evars /univ /order /perm /compl] pushVariables
                    691:   /vars arg1 def /evars [arg2 to_records pop] def
                    692:   [
                    693:     /univ vars 0 get reverse
                    694:           vars 1 get reverse join
                    695:     def
                    696:
                    697:     << univ length  >>
                    698:     << evars length >>
                    699:     eliminationOrderTemplate /order set
                    700:     /compl
                    701:       evars << evars univ complement >> join
                    702:     def
                    703:     compl univ
                    704:     getPerm /perm set
                    705:     %%perm :: univ :: compl ::
                    706:
                    707:     order perm permuteOrderMatrix /order set
                    708:
                    709:     vars [order] join /arg1 set
                    710:   ] pop
                    711:   popVariables
                    712:   arg1
                    713: } def
                    714:
                    715:
                    716: /elimination_order3 {
                    717: %% [x-list d-list params]  (x,y,z) elimination_order
                    718: %%  vars                    evars
                    719: %% [x-list d-list params order]
                    720:   /arg2 set  /arg1 set
                    721:   [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
                    722:   /vars arg1 def /evars [arg2 to_records pop] def
                    723:   [
                    724:     /univ vars 0 get reverse
                    725:           vars 1 get reverse join
                    726:     def
                    727:
                    728:     << univ length 1 sub >>
                    729:     << evars length >>
                    730:     eliminationOrderTemplate /order set
                    731:
                    732:     [[1]] order oplus  /order set
                    733:
                    734:     /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
                    735:
                    736:     /compl
                    737:       [univ 0 get] evars join evars univ0 complement join
                    738:     def
                    739:     compl univ
                    740:     getPerm /perm set
                    741:     %%perm :: univ :: compl ::
                    742:
                    743:     order perm permuteOrderMatrix /order set
                    744:
                    745:     vars [order] join /arg1 set
                    746:   ] pop
                    747:   popVariables
                    748:   arg1
                    749: } def
                    750:
                    751:
                    752: /define_ring {
                    753: %[  (x,y,z) ring_of_polynominals
                    754: %   (x,y) elimination_order
                    755: %   17
                    756: %] define_ring
                    757: % or
                    758: %[  (x,y,z) ring_of_polynominals
                    759: %   (x,y) elimination_order
                    760: %   17
                    761: %   [(keyword) value (keyword) value ...]
                    762: %] define_ring
                    763:    /arg1 set
                    764:    [/rp /param /foo] pushVariables
                    765:    [/rp arg1 def
                    766:
                    767:      rp 0 get length 3 eq {
                    768:        rp 0  [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
                    769:              ( ) elimination_order put
                    770:      } { } ifelse
                    771:
                    772:     [
                    773:       rp 0 get 0 get             %% x-list
                    774:       rp 0 get 1 get             %% d-list
                    775:       rp 0 get 2 get /param set
                    776:       param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
                    777:       param                      %% parameters.
                    778:       rp 0 get 3 get             %% order matrix.
                    779:       rp length 2 eq
                    780:       { [  ] }                   %% null optional argument.
                    781:       { rp 2 get }
                    782:       ifelse
                    783:     ]  /foo set
                    784:     foo aload pop set_up_ring@
                    785:    ] pop
                    786:    popVariables
                    787:    [(CurrentRingp)] system_variable
                    788: } def
                    789:
                    790:
                    791: [(define_qring)
                    792:   [( [varlist ring_of_q_difference_operators order characteristic] define_qring)
                    793:    (    Pointer to the ring. )
                    794:    (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)
                    795:    (          0] define_qring )
1.37      takayama  796:    (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << __ >>)
1.1       maekawa   797:   ]
                    798: ] putUsages
                    799: /define_qring {
                    800: %[  (x,y,z) ring_of_q_difference_operators
                    801: %   (Qx,Qy) elimination_order
                    802: %   17
                    803: %] define_qring
                    804:    /arg1 set
                    805:    [/rp /param /foo /cring /ppp] pushVariables
                    806:    [/rp arg1 def
                    807:     /ppp rp 1 get def
                    808:     %% define coefficient ring.
                    809:     [(q) @@@.esymbol] [(h) @@@.Esymbol]
                    810:     [ppp 2 2 2 2 1 2 2 2]
                    811:     [[1 0 0 0] [0 1 0 0] [0 0 1 0] [0 0 0 1]]
                    812:     [(mpMult) (poly)] set_up_ring@
                    813:     /cring  [(CurrentRingp)] system_variable def
                    814:
                    815:      rp 0 get length 3 eq {
                    816:        rp 0  [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
                    817:              ( ) elimination_order put
                    818:      } { } ifelse
                    819:
                    820:     [
                    821:       rp 0 get 0 get             %% x-list
                    822:       rp 0 get 1 get             %% d-list
                    823:       rp 0 get 2 get /param set
                    824:       param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
                    825:       param                      %% parameters.
                    826:       rp 0 get 3 get             %% order matrix.
                    827:       rp length 2 eq
                    828:       { [(mpMult) (diff) (coefficient ring) cring] }  %% optional argument.
                    829:       { [(mpMult) (diff) (coefficient ring) cring] rp 2 get join }
                    830:       ifelse
                    831:     ]  /foo set
                    832:     foo aload pop set_up_ring@
                    833:    ] pop
                    834:    popVariables
                    835:    [(CurrentRingp)] system_variable
                    836: } def
                    837:
                    838: [(ring_def)
                    839:  [(ring ring_def)
                    840:   (Set the current ring to the <<ring>>)
                    841:   (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 0 ] define_ring)
                    842:   (          /R set)
                    843:   (          R ring_def)
                    844:   (In order to get the ring object R to which a given polynomial f belongs,)
                    845:   (one may use the command )
                    846:   (          f (ring) data_conversion /R set)
                    847:   (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)
1.51      takayama  848:   (cf. << __ >>, getRing)
1.1       maekawa   849:  ]
                    850: ] putUsages
                    851:
                    852: /ring_def {
                    853:   /arg1 set
                    854:   [(CurrentRingp) arg1] system_variable
                    855: } def
                    856:
                    857:
                    858:
                    859: /lexicographicOrderTemplate {
                    860: % size lexicographicOrderTemplate matrix
                    861:   /arg1 set
                    862:   [/k /size] pushVariables
                    863:   [
                    864:     /size arg1 def
                    865:     [ 0 1 << size 1 sub >>
                    866:       {
                    867:          /k set
                    868:          size k evec
                    869:        } for
                    870:     ] /arg1 set
                    871:   ] pop
                    872:   popVariables
                    873:   arg1
                    874: } def
                    875:
                    876: /lexicographic_order {
                    877: %% [x-list d-list params]  (x,y,z) lexicograhic_order
                    878: %%  vars                    evars
                    879: %% [x-list d-list params order]
                    880:   /arg2 set  /arg1 set
                    881:   [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
                    882:   /vars arg1 def /evars [arg2 to_records pop] def
                    883:   [
                    884:     /univ vars 0 get reverse
                    885:           vars 1 get reverse join
                    886:     def
                    887:
                    888:     << univ length 2 sub >>
                    889:     lexicographicOrderTemplate /order set
                    890:
                    891:     [[1]] order oplus [[1]] oplus /order set
                    892:
                    893:     /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
                    894:
                    895:     /compl
                    896:       [univ 0 get] evars join evars univ0 complement join
                    897:     def
                    898:     compl univ
                    899:     getPerm /perm set
                    900:     %%perm :: univ :: compl ::
                    901:
                    902:     order perm permuteOrderMatrix /order set
                    903:
                    904:     vars [order] join /arg1 set
                    905:   ] pop
                    906:   popVariables
                    907:   arg1
                    908: } def
                    909:
                    910: /lexicographic_order2 {
                    911: %% [x-list d-list params]  (x,y,z) lexicograhic_order
                    912: %%  vars                    evars
                    913: %% [x-list d-list params order]
                    914: %% with no graduation and homogenization variables
                    915:   /arg2 set  /arg1 set
                    916:   [/vars /evars /univ /order /perm /compl] pushVariables
                    917:   /vars arg1 def /evars [arg2 to_records pop] def
                    918:   [
                    919:     /univ vars 0 get reverse
                    920:           vars 1 get reverse join
                    921:     def
                    922:
                    923:     << univ length  >>
                    924:     lexicographicOrderTemplate /order set
                    925:
                    926:     /compl
                    927:       evars << evars univ complement >> join
                    928:     def
                    929:     compl univ
                    930:     getPerm /perm set
                    931:
                    932:     order perm permuteOrderMatrix /order set
                    933:
                    934:     vars [order] join /arg1 set
                    935:   ] pop
                    936:   popVariables
                    937:   arg1
                    938: } def
                    939:
                    940: /lexicographic_order3 {
                    941: %% [x-list d-list params]  (x,y,z) lexicograhic_order
                    942: %%  vars                    evars
                    943: %% [x-list d-list params order]
                    944: %% with no homogenization variable.
                    945:   /arg2 set  /arg1 set
                    946:   [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
                    947:   /vars arg1 def /evars [arg2 to_records pop] def
                    948:   [
                    949:     /univ vars 0 get reverse
                    950:           vars 1 get reverse join
                    951:     def
                    952:
                    953:     << univ length 1 sub >>
                    954:     lexicographicOrderTemplate /order set
                    955:
                    956:     [[1]] order oplus /order set
                    957:
                    958:     /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
                    959:
                    960:     /compl
                    961:       [univ 0 get] evars join evars univ0 complement join
                    962:     def
                    963:     compl univ
                    964:     getPerm /perm set
                    965:     %%perm :: univ :: compl ::
                    966:
                    967:     order perm permuteOrderMatrix /order set
                    968:
                    969:     vars [order] join /arg1 set
                    970:   ] pop
                    971:   popVariables
                    972:   arg1
                    973: } def
                    974:
                    975: %%%%%%   add_rings %%%%%%%%%%%%%% 10/5
                    976:
                    977: /graded_reverse_lexicographic_order {
                    978:   (  ) elimination_order
                    979: } def
                    980:
                    981:
                    982: /getX {
                    983: %% param [1|2|3|4] getX [var-lists]  ;  1->c,2->l,3->m,4->n
                    984:   /arg2 set /arg1 set
                    985:   [/k /param /func /low /top] pushVariables
                    986:   [
                    987:      /param arg1 def  /func arg2 def
                    988:      func 1 eq
                    989:      {
                    990:        /low 0 def
                    991:      }
                    992:      {
                    993:        /low << param 2 get >> << func 1 sub >> get def
                    994:      } ifelse
                    995:      /top << param 2 get >> << func 4 add >> get 1 sub def
                    996:      [
                    997:        low 1 top
                    998:        {
                    999:            /k set
                   1000:           param 0 get k get
                   1001:         } for
                   1002:      ] /arg1 set
                   1003:   ] pop
                   1004:   popVariables
                   1005:   arg1
                   1006: } def
                   1007:
                   1008: /getD {
                   1009: %% param [1|2|3|4] getD [var-lists]  ;  1->c,2->l,3->m,4->n
                   1010:   /arg2 set /arg1 set
                   1011:   [/k /param /func /low /top] pushVariables
                   1012:   [
                   1013:      /param arg1 def  /func arg2 def
                   1014:      func 1 eq
                   1015:      {
                   1016:        /low 0 def
                   1017:      }
                   1018:      {
                   1019:        /low << param 2 get >> << func 1 sub >> get def
                   1020:      } ifelse
                   1021:      /top << param 2 get >> << func 4 add >> get 1 sub def
                   1022:      [
                   1023:        low 1 top
                   1024:        {
                   1025:            /k set
                   1026:           param 1 get k get
                   1027:         } for
                   1028:      ] /arg1 set
                   1029:   ] pop
                   1030:   popVariables
                   1031:   arg1
                   1032: } def
                   1033:
                   1034: /getXV {
                   1035: %% param [1|2|3|4] getXV [var-lists]  ;  1->c,2->l,3->m,4->n
                   1036:   /arg2 set /arg1 set
                   1037:   [/k /param /func /low /top] pushVariables
                   1038:   [
                   1039:      /param arg1 def  /func arg2 def
                   1040:      /low << param 2 get >> << func 4 add >> get def
                   1041:      /top << param 2 get >>  func get 1 sub def
                   1042:      [
                   1043:        low 1 top
                   1044:        {
                   1045:            /k set
                   1046:           param 0 get k get
                   1047:         } for
                   1048:      ] /arg1 set
                   1049:   ] pop
                   1050:   popVariables
                   1051:   arg1
                   1052: } def
                   1053:
                   1054: /getDV {
                   1055: %% param [1|2|3|4] getDV [var-lists]  ;  1->c,2->l,3->m,4->n
                   1056:   /arg2 set /arg1 set
                   1057:   [/k /param /func /low /top] pushVariables
                   1058:   [
                   1059:      /param arg1 def  /func arg2 def
                   1060:      /low << param 2 get >> << func 4 add >> get def
                   1061:      /top << param 2 get >>  func get 1 sub def
                   1062:      [
                   1063:        low 1 top
                   1064:        {
                   1065:            /k set
                   1066:           param 1 get k get
                   1067:         } for
                   1068:      ] /arg1 set
                   1069:   ] pop
                   1070:   popVariables
                   1071:   arg1
                   1072: } def
                   1073:
                   1074: /reNaming {
                   1075:   %% It also changes oldx2 and oldd2, which are globals.
                   1076:   /arg1 set
                   1077:   [/i /j /new /count /ostr /k] pushVariables
                   1078:   [
                   1079:     /new arg1 def
                   1080:     /count 0 def
                   1081:     0 1 << new length 1 sub >> {
                   1082:        /i set
                   1083:       << i 1 add >> 1 << new length 1 sub >> {
                   1084:           /j set
                   1085:           << new i get >> << new j get >> eq
                   1086:           {
                   1087:              new j get /ostr set
                   1088:              (The two rings have the same name :) messagen
                   1089:              new i get messagen (.) message
                   1090:              (The name ) messagen
                   1091:              new i get messagen ( is changed into ) messagen
                   1092:              new j << new i get << 48 count add $string$ data_conversion >>
                   1093:                       2 cat_n >> put
                   1094:              new j get messagen (.) message
                   1095:              /oldx2 ostr << new j get >> reNaming2
                   1096:              /oldd2 ostr << new j get >> reNaming2
                   1097:              /count count 1 add def
                   1098:            }
                   1099:            { }
                   1100:            ifelse
                   1101:       } for
                   1102:     } for
                   1103:     /arg1 new def
                   1104:   ] pop
                   1105:   popVariables
                   1106:   arg1
                   1107: } def
                   1108:
                   1109: /reNaming2 {
                   1110:   %% array oldString newString reNaming2
                   1111:   %% /aa (x) (y) reNaming2
                   1112:   /arg3 set /arg2 set /arg1 set
                   1113:   [/array /oldString /newString /k] pushVariables
                   1114:   [
                   1115:     /array arg1 def /oldString arg2 def /newString arg3 def
                   1116:       0 1 << array load length 1 sub >>
                   1117:       {
                   1118:          /k set
                   1119:          << array load k get  >> oldString eq
                   1120:          {
                   1121:             array load k newString put
                   1122:           }
                   1123:           { } ifelse
                   1124:       } for
                   1125:    ] pop
                   1126:    popVariables
                   1127: } def
                   1128:
                   1129: /add_rings {
                   1130:   /arg2 set /arg1 set
                   1131:   [/param1 /param2
                   1132:    /newx /newd  /newv
                   1133:    /k /const /od1 /od2 /od
                   1134:    /oldx2 /oldd2  % these will be changed in reNaming.
                   1135:    /oldv
                   1136:   ] pushVariables
                   1137:   [
                   1138:      /param1 arg1 def /param2 arg2 def
                   1139:    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                   1140:      /newx
                   1141:        [ ]
                   1142:        param2 1 getX join  param1 1 getX join
                   1143:        param2 1 getXV join param1 1 getXV join
                   1144:
                   1145:        param2 2 getX join  param1 2 getX join
                   1146:        param2 2 getXV join param1 2 getXV join
                   1147:
                   1148:        param2 3 getX join  param1 3 getX join
                   1149:        param2 3 getXV join param1 3 getXV join
                   1150:
                   1151:        param2 4 getX join  param1 4 getX join
                   1152:        param2 4 getXV join param1 4 getXV join
                   1153:      def
                   1154:      /newd
                   1155:        [ ]
                   1156:        param2 1 getD join  param1 1 getD join
                   1157:        param2 1 getDV join param1 1 getDV join
                   1158:
                   1159:        param2 2 getD join  param1 2 getD join
                   1160:        param2 2 getDV join param1 2 getDV join
                   1161:
                   1162:        param2 3 getD join  param1 3 getD join
                   1163:        param2 3 getDV join param1 3 getDV join
                   1164:
                   1165:        param2 4 getD join  param1 4 getD join
                   1166:        param2 4 getDV join param1 4 getDV join
                   1167:      def
                   1168:
                   1169:      /newv  newx newd join def
                   1170:      /oldx2 param2 0 get def  /oldd2 param2 1 get def
                   1171:      /oldx2 oldx2 {1 copy 2 1 roll pop} map def
                   1172:      /oldd2 oldd2 {1 copy 2 1 roll pop} map def
                   1173:      /newv newv reNaming def
                   1174:
                   1175:      /newx [
                   1176:        0 1 << newv length 2 idiv 1 sub >>
                   1177:        {
                   1178:           /k set
                   1179:           newv k get
                   1180:        } for
                   1181:      ] def
                   1182:      /newd [
                   1183:        0 1 << newv length 2 idiv 1 sub >>
                   1184:        {
                   1185:           /k set
                   1186:           newv << newv length 2 idiv k add >> get
                   1187:        } for
                   1188:      ] def
                   1189:      /const [
                   1190:         << param1 2 get 0 get >>
                   1191:         << param1 2 get 1 get  param2 2 get 1 get add >>
                   1192:         << param1 2 get 2 get  param2 2 get 2 get add >>
                   1193:         << param1 2 get 3 get  param2 2 get 3 get add >>
                   1194:         << param1 2 get 4 get  param2 2 get 4 get add >>
                   1195:         << param1 2 get 5 get  param2 2 get 5 get add >>
                   1196:         << param1 2 get 6 get  param2 2 get 6 get add >>
                   1197:         << param1 2 get 7 get  param2 2 get 7 get add >>
                   1198:         << param1 2 get 8 get  param2 2 get 8 get add >>
                   1199:     ] def
                   1200:
                   1201:     /od1 param1 3 get def /od2 param2 3 get def
                   1202:     od1 od2 oplus /od set
                   1203:
                   1204:     %%oldx2 :: oldd2 ::
                   1205:     << param1 0 get reverse >> << param1 1 get reverse >> join
                   1206:     << oldx2 reverse >> << oldd2 reverse >> join
                   1207:     join /oldv set
                   1208:
                   1209:
                   1210:     od << oldv << newx reverse newd reverse join >> getPerm >>
                   1211:     permuteOrderMatrix /od set
                   1212:
                   1213:      /arg1 [newx newd const od] def
                   1214:   ] pop
                   1215:   popVariables
                   1216:   arg1
                   1217: } def
                   1218:
                   1219:
                   1220: %%%% end of add_rings
                   1221:
                   1222:
                   1223:
                   1224: [(swap01) [
                   1225:    $[ .... ] swap01 [....]$
                   1226:    $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
                   1227:    $          define_ring$
                   1228: ]] putUsages
                   1229: %
                   1230: /swap01 {
                   1231:   /arg1 set
                   1232:   [/rg /ch ] pushVariables
                   1233:   [
                   1234:     arg1 0 get /rg set  % ring
                   1235:     arg1 1 get /ch set  % characteristics
                   1236:     [rg 0 get , rg 1 get , rg 2 get ,
                   1237:      << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
                   1238:     /arg1 [ rg ch ] def
                   1239:   ] pop
                   1240:   popVariables
                   1241:   arg1
                   1242: } def
                   1243:
                   1244: [(swap0k) [
                   1245:    $[ .... ] k swap0k [....]$
                   1246:    $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
                   1247:    $          define_ring$
                   1248:    $swap01 == 1 swap0k$
                   1249: ]] putUsages
                   1250: %
                   1251: /swap0k {
                   1252:   /arg2 set
                   1253:   /arg1 set
                   1254:   [/rg /ch /kk] pushVariables
                   1255:   [
                   1256:     arg2 /kk set
                   1257:     arg1 0 get /rg set  % ring
                   1258:     arg1 1 get /ch set  % characteristics
                   1259:     [rg 0 get , rg 1 get , rg 2 get ,
                   1260:      << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
                   1261:     /arg1 [ rg ch ] def
                   1262:   ] pop
                   1263:   popVariables
                   1264:   arg1
                   1265: } def
                   1266:
                   1267: %%%%%%%%%%%%%   weight vector
                   1268: [(position)
                   1269:   [(set element position number)
                   1270:    (Example: [(cat) (dog) (hot chocolate)] (cat) position ===> 0.)
                   1271:   ]
                   1272: ] putUsages
                   1273: /position {
                   1274:   /arg2 set /arg1 set
                   1275:   [/univ /elem /num /flag] pushVariables
                   1276:   [
                   1277:      /univ arg1 def
                   1278:      /elem arg2 def
                   1279:      /num -1 def /flag -1 def
                   1280:      0 1 << univ length 1 sub >>
                   1281:      {
                   1282:         /num set
                   1283:         univ num get  elem  eq
                   1284:         { /flag 0 def exit }
                   1285:         {    }
                   1286:         ifelse
                   1287:      }  for
                   1288:      flag -1 eq
                   1289:      {/num -1 def}
                   1290:      {  }
                   1291:      ifelse
                   1292:   ] pop
                   1293:   /arg1 num def
                   1294:   popVariables
                   1295:   arg1
                   1296: } def
                   1297:
                   1298:
                   1299: [(evecw)
                   1300:   [(size position weight evecw  [0 0 ... 0 weight 0 ... 0] )
                   1301:    (Example: 3 0 113 evecw ===> [113  0  0])
                   1302:   ]
                   1303: ] putUsages
                   1304: /evecw {
                   1305:  /arg3 set /arg2 set /arg1 set
                   1306:  [/size /iii /www] pushVariables
                   1307:  /size arg1 def  /iii arg2 def /www arg3 def
                   1308:  [
                   1309:    0 1 << size 1 sub >>
                   1310:    {
                   1311:       iii eq
                   1312:       {  www }
                   1313:       {  0 }
                   1314:       ifelse
                   1315:    } for
                   1316:   ] /arg1 set
                   1317:   popVariables
                   1318:   arg1
                   1319: } def
                   1320:
                   1321: [(weight_vector)
                   1322:  [ ([x-list d-list params] [[(name) weight ...] [...] ...] weight_vector)
                   1323:    ([x-list d-list params order])
                   1324:    (Example:)
                   1325:    (   [(x,y,z) ring_of_polynomials [[(x) 100 (y) 10]] weight_vector 0] )
                   1326:    (   define_ring )
                   1327:   ]
                   1328: ] putUsages
                   1329: /weight_vector {
                   1330:   /arg2 set  /arg1 set
                   1331:   [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
                   1332:   /vars arg1 def /w-vectors arg2 def
                   1333:   [
                   1334:     /univ vars 0 get reverse
                   1335:           vars 1 get reverse join
                   1336:     def
1.33      takayama 1337:     w-vectors to_int32 /w-vectors set
1.1       maekawa  1338:     [
                   1339:     0 1 << w-vectors length 1 sub >>
                   1340:     {
                   1341:       /k set
                   1342:       univ w-vectors k get w_to_vec
                   1343:     } for
                   1344:     ] /order1 set
                   1345:     %% order1 ::
                   1346:
                   1347:     vars ( ) elimination_order 3 get /order2 set
                   1348:     vars [ << order1 order2 join >> ] join /arg1 set
                   1349:   ] pop
                   1350:   popVariables
                   1351:   arg1
                   1352: } def
                   1353:
                   1354: %% [@@@.esymbol (x) (y) (h)] [(x) 100 (y) 10] w_to_vec [0 100 10 0]
                   1355: %%  univ              www
                   1356: /w_to_vec {
                   1357:   /arg2 set  /arg1 set
                   1358:   [/univ /www /k /vname /vweight /ans] pushVariables
                   1359:   /univ arg1 def /www arg2 def
1.32      takayama 1360:   [
1.33      takayama 1361:     www to_int32 /www set
1.1       maekawa  1362:     /ans << univ length >> -1 0 evecw def
                   1363:     0  2  << www length 2 sub >>
                   1364:     {
                   1365:       %% ans ::
                   1366:       /k set
                   1367:       www k get /vname set
                   1368:       www << k 1 add >> get /vweight set
                   1369:       << univ length >>
                   1370:       << univ vname position >>
                   1371:       vweight evecw
                   1372:       ans add /ans set
                   1373:     } for
                   1374:     /arg1 ans def
                   1375:   ] pop
                   1376:   popVariables
                   1377:   arg1
                   1378: } def
                   1379:
                   1380: %%%%%%%%%% end of weight_vector macro
                   1381:
                   1382: %%%%%%%% eliminatev macro
                   1383: [(eliminatev)
                   1384:  [([g1 g2 g3 ...gm] [list of variables] eliminatev [r1 ... rp])
                   1385:   (Example: [(x y z - 1). (z-1). (y-1).] [(x) (y)] eliminatev [ z-1 ])
                   1386:  ]
                   1387: ] putUsages
                   1388: /eliminatev {
                   1389:  /arg2 set /arg1 set
                   1390:  [/gb /var /vars /ans /k] pushVariables
                   1391:  [
                   1392:    /gb arg1 def
                   1393:    /vars arg2 def
                   1394:    /ans gb def
                   1395:    0 1 << vars length 1 sub >> {
                   1396:      /k set
                   1397:      ans  << vars k get >> eliminatev.tmp
                   1398:      /ans set
                   1399:    } for
                   1400:    /arg1 ans def
                   1401:  ] pop
                   1402:  popVariables
                   1403:  arg1
                   1404: } def
                   1405: /eliminatev.tmp {
                   1406:   /arg2 set /arg1 set
                   1407:   [/gb /degs /ans /n /var /ff /rr /gg] pushVariables
                   1408:   [
                   1409:   /gb arg1 def
                   1410:   /var arg2 def
                   1411:   /degs gb {
                   1412:        /gg set
                   1413:        gg (0). eq
                   1414:        { 0 }
                   1415:        { gg (ring) data_conversion /rr set
1.37      takayama 1416:          gg  << var rr __ >> degree
1.1       maekawa  1417:        } ifelse
                   1418:     } map def
                   1419:   %%degs message
                   1420:   /ans [
                   1421:     0 1 << gb length 1 sub >> {
                   1422:       /n set
                   1423:       << degs n get  >>  0 eq
                   1424:       { gb n get /ff set
                   1425:         ff (0). eq
                   1426:         {  }
                   1427:         { ff } ifelse
                   1428:       }
                   1429:       {   } ifelse
                   1430:     } for
                   1431:   ] def
                   1432:   /arg1 ans def
                   1433:   ] pop
                   1434:   popVariables
                   1435:   arg1
                   1436: } def
                   1437:
                   1438: /eliminatev.tmp.org {
                   1439:   /arg2 set /arg1 set
                   1440:   [/gb /degs /ans /n /var /ff] pushVariables
                   1441:   [
                   1442:   /gb arg1 def
                   1443:   /var arg2 def
                   1444:   /degs gb {var . degree} map def
                   1445:   /ans [
                   1446:     0 1 << gb length 1 sub >> {
                   1447:       /n set
                   1448:       << degs n get  >>  0 eq
                   1449:       { gb n get /ff set
                   1450:         ff (0). eq
                   1451:         {  }
                   1452:         { ff } ifelse
                   1453:       }
                   1454:       {   } ifelse
                   1455:     } for
                   1456:   ] def
                   1457:   /arg1 ans def
                   1458:   ] pop
                   1459:   popVariables
                   1460:   arg1
                   1461: } def
                   1462: %%% end of eliminatev macro
                   1463:
                   1464: %%% macro for output
                   1465:
                   1466: [(isInteger)
                   1467:  [(obj isInteger bool) ]
                   1468: ] putUsages
                   1469: /isInteger {
                   1470:   (type?) data_conversion  << 0  (type?) data_conversion >> eq
                   1471: } def
                   1472:
                   1473: [(isArray)
                   1474:  [(obj isArray bool) ]
                   1475: ] putUsages
                   1476: /isArray {
                   1477:   (type?) data_conversion << [ ] (type?) data_conversion >>  eq
                   1478: } def
                   1479:
                   1480: [(isPolynomial)
                   1481:  [(obj isPolynomial bool) ]
                   1482: ] putUsages
                   1483: /isPolynomial {
                   1484:   (type?) data_conversion
                   1485:    << [(x) (var) 0] system_variable . (type?) data_conversion >> eq
                   1486: } def
                   1487:
                   1488: [(isString)
                   1489:  [(obj isString bool) ]
                   1490: ] putUsages
                   1491: /isString {
                   1492:   (type?) data_conversion
                   1493:    << (Hi) (type?) data_conversion >> eq
                   1494: } def
                   1495:
                   1496: [(isClass)
                   1497:  [(obj isClass bool) ]
                   1498: ] putUsages
                   1499: /isClass {
                   1500:   (type?) data_conversion  ClassP eq
                   1501: } def
                   1502:
                   1503: [(isUniversalNumber)
                   1504:  [(obj isUniversalNumber bool) ]
                   1505: ] putUsages
                   1506: /isUniversalNumber {
                   1507:   (type?) data_conversion  UniversalNumberP eq
                   1508: } def
                   1509:
                   1510: [(isDouble)
                   1511:  [(obj isDouble bool) ]
                   1512: ] putUsages
                   1513: /isDouble {
                   1514:   (type?) data_conversion  DoubleP eq
                   1515: } def
                   1516:
                   1517: [(isRational)
                   1518:  [(obj isRational bool) ]
                   1519: ] putUsages
                   1520: /isRational {
                   1521:   (type?) data_conversion  RationalFunctionP eq
1.7       takayama 1522: } def
                   1523:
                   1524: [(isRing)
                   1525:  [(obj isRing bool) ]
                   1526: ] putUsages
                   1527: /isRing {
                   1528:   (type?) data_conversion  RingP eq
1.1       maekawa  1529: } def
                   1530:
1.47      takayama 1531: [(isByteArray)
                   1532:  [(obj isByteArray bool) ]
                   1533: ] putUsages
                   1534: /isByteArray {
                   1535:   (type?) data_conversion  ByteArrayP eq
                   1536: } def
                   1537:
1.1       maekawa  1538: /toString.tmp {
                   1539:   /arg1 set
                   1540:   [/obj /fname] pushVariables
                   1541:   /obj arg1 def
                   1542:   [
                   1543:     obj isArray
                   1544:     {
                   1545:        obj {toString.tmp} map
                   1546:     }
                   1547:     { } ifelse
                   1548:     obj isInteger
                   1549:     {
                   1550:        obj (dollar) data_conversion  %% not string. It returns the ascii code.
                   1551:     }
                   1552:     { } ifelse
                   1553:     obj isPolynomial
                   1554:     {
                   1555:        obj (string) data_conversion
                   1556:     }
                   1557:     { } ifelse
                   1558:     obj isString
                   1559:     { obj }
                   1560:     { } ifelse
                   1561:     obj isUniversalNumber
                   1562:     { obj (string) data_conversion } { } ifelse
                   1563:     obj isDouble
                   1564:     { obj (string) data_conversion } { } ifelse
                   1565:     obj isRational
                   1566:     { obj (string) data_conversion } { } ifelse
1.47      takayama 1567:     obj isByteArray
                   1568:     { obj (array) data_conversion toString } { } ifelse
1.1       maekawa  1569:     obj tag 0 eq
                   1570:     { (null) } { } ifelse
                   1571:
                   1572:     %%% New code that uses a file.
                   1573:     obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
                   1574:     { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
                   1575:       [(outputObjectToFile) fname obj] extension pop
                   1576:       fname pushfile
                   1577:       [(/bin/rm -rf ) fname] cat system
                   1578:     } { } ifelse
                   1579:   ] /arg1 set
                   1580:   popVariables
                   1581:   arg1 aload pop
                   1582: } def
                   1583:
                   1584:
                   1585:
                   1586: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
                   1587: /toString.tmp2 {
                   1588:   /arg1 set
                   1589:   [/obj /i /n /r] pushVariables
                   1590:   [
                   1591:     /obj arg1 def
                   1592:     obj isArray
                   1593:     {
1.2       takayama 1594:        [(LeftBracket)] system_variable %%( [ )
1.1       maekawa  1595:        obj {toString.tmp2} map /r set
                   1596:        /n r length 1 sub def
                   1597:        [0 1  n  {
                   1598:           /i set
                   1599:           i n eq {
                   1600:             r i get
                   1601:           }
                   1602:           { r i get ( , ) 2 cat_n }
                   1603:           ifelse
                   1604:         } for
                   1605:        ] aload length cat_n
1.2       takayama 1606:        [(RightBracket)] system_variable %%( ] )
1.1       maekawa  1607:        3 cat_n
                   1608:      }
                   1609:      {
                   1610:         obj
                   1611:      } ifelse
                   1612:    ] /arg1 set
                   1613:    popVariables
                   1614:    arg1 aload pop
                   1615: } def
                   1616:
                   1617:
                   1618: [(toString)
                   1619:  [(obj toString)
                   1620:   (Convert obj to a string.)
                   1621:   (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ]  ]$)
                   1622:  ]
                   1623: ] putUsages
                   1624: /toString {
                   1625:   /arg1 set
                   1626:   [/obj ] pushVariables
                   1627:   [
                   1628:     /obj arg1 def
                   1629:     obj isString
                   1630:     { obj }
                   1631:     { obj toString.tmp toString.tmp2 }
                   1632:     ifelse /arg1 set
                   1633:   ] pop
                   1634:   popVariables
                   1635:   arg1
                   1636: } def
                   1637:
                   1638: [(output)
                   1639:  [(obj output) (Output the object to the standard file sm1out.txt)]
                   1640: ] putUsages
                   1641: /output {
                   1642:   /arg1 set
                   1643:   [/obj /fd ] pushVariables
                   1644:   [
                   1645:     /obj arg1 def
                   1646:     (sm1out.txt) (a) file /fd set
                   1647:     (Writing to sm1out.txt  ...) messagen
                   1648:     [ fd << obj toString >> writestring ] pop
                   1649:     [ fd << 10 (string) data_conversion >> writestring ] pop
                   1650:     ( Done.) message
                   1651:     fd closefile
                   1652:   ] pop
                   1653:   popVariables
                   1654: } def
                   1655: %%%% end of macro for output.
                   1656: [(tag)
                   1657:  [(obj tag integer)
                   1658:   (tag returns datatype.)
                   1659:   (cf. data_conversion)
                   1660:   (Example: 2 tag IntegerP eq ---> 1)
                   1661:  ]
                   1662: ] putUsages
                   1663: /etag {(type??) data_conversion} def
                   1664: [(etag)
                   1665:  [(obj etag integer)
                   1666:   (etag returns extended object tag. cf. kclass.c)
                   1667:  ]
                   1668: ] putUsages
                   1669: /tag {(type?) data_conversion} def
                   1670: %% datatype constants
                   1671: /IntegerP 1  (type?) data_conversion def
                   1672: /LiteralP /arg1 (type?) data_conversion def   %Sstring
                   1673: /StringP (?) (type?) data_conversion def      %Sdollar
                   1674: /ExecutableArrayP  { 1 } (type?) data_conversion def
                   1675: /ArrayP [ 0 ] (type?) data_conversion def
                   1676: /PolyP  (1).  (type?) data_conversion def
                   1677: /FileP  13 def
                   1678: /RingP  14 def
                   1679: /UniversalNumberP 15 def
                   1680: /RationalFunctionP 16 def
                   1681: /ClassP 17 def
                   1682: /DoubleP 18 def
1.47      takayama 1683: /ByteArrayP 19 def
1.1       maekawa  1684: /@.datatypeConstant.usage [
                   1685:  (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
1.47      takayama 1686:  (UniversalNumberP, RationalFunctionP, ClassP, DoubleP, ByteArrayP)
1.1       maekawa  1687:  (      return data type identifiers.)
                   1688:  (Example:  7 tag IntegerP eq  ---> 1)
                   1689: ] def
                   1690: [(IntegerP) @.datatypeConstant.usage ] putUsages
                   1691: [(LiteralP) @.datatypeConstant.usage ] putUsages
                   1692: [(StringP) @.datatypeConstant.usage ] putUsages
                   1693: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
                   1694: [(ArrayP) @.datatypeConstant.usage ] putUsages
                   1695: [(PolyP) @.datatypeConstant.usage ] putUsages
                   1696: [(RingP) @.datatypeConstant.usage ] putUsages
                   1697: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
                   1698: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
                   1699: [(ClassP) @.datatypeConstant.usage ] putUsages
                   1700: [(DoubleP) @.datatypeConstant.usage ] putUsages
1.47      takayama 1701: [(ByteArrayP) @.datatypeConstant.usage ] putUsages
1.1       maekawa  1702:
1.37      takayama 1703: [(__)
                   1704:  [( string ring __ polynomial)
1.1       maekawa  1705:   (Parse the <<string>> as an element in the <<ring>> and returns)
                   1706:   (the polynomial.)
                   1707:   (cf. define_ring, define_qring, ring_def)
                   1708:   (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
                   1709:   (         /myring set)
1.37      takayama 1710:   (         ((x+y)^4) myring __ /f set)
1.1       maekawa  1711: ]] putUsages
                   1712:
1.37      takayama 1713: /__ {
1.1       maekawa  1714:   /arg2 set /arg1 set
                   1715:   [/rrr] pushVariables
                   1716:   [ arg1 tag StringP eq
                   1717:     arg2 tag RingP eq  and
                   1718:     { [(CurrentRingp)] system_variable /rrr set
                   1719:       [(CurrentRingp) arg2] system_variable
                   1720:       /arg1 arg1 expand def
                   1721:       [(CurrentRingp) rrr] system_variable
                   1722:     }
1.37      takayama 1723:     {(Argument Error for __ ) error }
1.1       maekawa  1724:     ifelse
                   1725:   ] pop
                   1726:   popVariables
                   1727:   arg1
                   1728: } def
                   1729:
                   1730: [(..)
                   1731:  [( string .. universalNumber)
                   1732:   (Parse the << string >> as a universalNumber.)
                   1733:   (Example:  (123431232123123).. /n set)
1.46      takayama 1734:   ({ commands }..  executes the commands.  << .. >> is equivalent to exec.)
1.1       maekawa  1735: ]] putUsages
1.46      takayama 1736: /.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def
1.1       maekawa  1737:
                   1738: [(dc)
                   1739:  [(Abbreviation of data_conversion.)
                   1740: ]] putUsages
                   1741: /dc { data_conversion } def
                   1742:
                   1743:
                   1744: %%% start of shell sort macro.
                   1745: [(and) [(obj1 obj2 and bool)]] putUsages
                   1746: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
                   1747:
                   1748: [(or) [(obj1 obj2 or bool)]] putUsages
                   1749: /or  { add 1 copy 2 eq {pop 1} { } ifelse} def
                   1750:
                   1751: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
                   1752: %% 2 copy is equivalent to  dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
                   1753: /ge  { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
                   1754:                eq {pop pop 1}
                   1755:                   { gt {1}
                   1756:                        {0}
                   1757:                        ifelse}
                   1758:                   ifelse} def
                   1759:
                   1760: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
                   1761: /le  { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
                   1762:                eq {pop pop 1}
                   1763:                   { lt {1}
                   1764:                        {0}
                   1765:                        ifelse}
                   1766:                   ifelse} def
                   1767:
                   1768: [(break)
                   1769:  [(bool break)]
                   1770: ] putUsages
                   1771: /break { {exit} { } ifelse } def
                   1772:
                   1773: /not { 0 eq {1} {0} ifelse} def
                   1774: /append { /arg2 set [arg2] join } def
                   1775:
                   1776: [(power)
                   1777:  [(obj1 obj2 power obj3)
                   1778:   $obj3 is (obj1)^(obj2). cf. npower$
                   1779:   $Example:  (2). 8 power ::  ===>  256 $
                   1780:  ]
                   1781: ] putUsages
                   1782: %% From SSWork/yacc/incmac.sm1
                   1783: %% f k power f^k
                   1784: /power {
                   1785:   /arg2 set
                   1786:   /arg1 set
                   1787:   [/f /k /i /ans] pushVariables
                   1788:   [
1.26      takayama 1789:    /ans (1).. def
                   1790:    [(QuoteMode)] system_variable {
                   1791:      /f arg1 def   /k arg2 def
                   1792:      [(ooPower) f k] extension /ans set
                   1793:    } {
1.1       maekawa  1794:      /f arg1 def   /k arg2 ..int def
                   1795:      k 0 lt {
                   1796:        1 1 << 0 k sub >> {
                   1797:          /ans f ans {mul} sendmsg2 def
                   1798:        } for
                   1799:        /ans (1).. ans {div} sendmsg2 def
                   1800:      }
                   1801:      {
                   1802:        1 1 k {
                   1803:          /ans f ans {mul} sendmsg2 def
                   1804:        } for
                   1805:      } ifelse
1.26      takayama 1806:    } ifelse
                   1807:    /arg1 ans def
1.1       maekawa  1808:   ] pop
                   1809:   popVariables
                   1810:   arg1
                   1811: } def
                   1812: [(..int)
                   1813:  [ (universalNumber ..int int)]] putUsages
                   1814: /..int { %% universal number to int
                   1815:   (integer) data_conversion
                   1816: } def
                   1817: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
                   1818: /SmallRing  [(CurrentRingp)] system_variable  def
                   1819:
                   1820: %%% From SSWork/yacc/lib/printSVector.modified.sm1
                   1821: %%% supporting code for printSVector.
                   1822: /greaterThanOrEqual {
                   1823:   /arg2 set /arg1 set
                   1824:   arg1 arg2 gt { 1 }
                   1825:   { arg1 arg2 eq {1} {0} ifelse} ifelse
                   1826: } def
                   1827:
                   1828: /lengthUniv {
                   1829:  length (universalNumber) dc
                   1830: } def
                   1831:
                   1832: /getUniv {
                   1833:  (integer) dc get
                   1834: } def  %% Do not forget to thow away /.
                   1835:
                   1836: %%[(@@@.printSVector)
                   1837: %% [( vector @@@.printSVector   outputs the <<vector>> in a pretty way.)
                   1838: %%  ( The elements of the vector must be strings.)
                   1839: %% ]
                   1840: %%] putUsages
                   1841:
                   1842: %%% compiled code by d0, 1996, 8/17.
                   1843: /@@@.printSVector {
                   1844:  /arg1 set
                   1845: [ %%start of local variables
                   1846: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
                   1847: /keys arg1 def
                   1848: /n
                   1849: keys lengthUniv
                   1850:  def
                   1851: /max (0)..  def
                   1852: /i (0)..  def
                   1853: %%for init.
                   1854: %%for
                   1855: { i n  lt
                   1856:  {  } {exit} ifelse
                   1857: [ {%%increment
                   1858: /i  i (1).. add def
                   1859: } %%end of increment{A}
                   1860: {%%start of B part{B}
                   1861: keys i  getUniv lengthUniv
                   1862: max  gt
                   1863:  %% if-condition
                   1864:   { %%ifbody
                   1865: /max
                   1866: keys i   getUniv lengthUniv
                   1867:  def
                   1868:   }%%end if if body
                   1869:   { %%if- else part
                   1870:   } ifelse
                   1871: } %% end of B part. {B}
                   1872:  2 1 roll] {exec} map
                   1873: } loop %%end of for
                   1874: /max max (3)..  add
                   1875:  def
                   1876: /width (80)..  def
                   1877: /m (0)..  def
                   1878:
                   1879: %%while
                   1880: { m max  mul
                   1881: (80)..  lt
                   1882:  { } {exit} ifelse
                   1883:  /m m (1)..  add
                   1884:  def
                   1885: } loop
                   1886: /k (0)..  def
                   1887: /kk (0)..  def
                   1888: /i (0)..  def
                   1889: %%for init.
                   1890: %%for
                   1891: { i n  lt
                   1892:  {  } {exit} ifelse
                   1893: [ {%%increment
                   1894: /i  i (1).. add def
                   1895: } %%end of increment{A}
                   1896: {%%start of B part{B}
                   1897: keys i getUniv messagen
                   1898: /kk kk (1)..  add
                   1899:  def
                   1900: /k k
                   1901: keys i getUniv lengthUniv
                   1902:  add
                   1903:  def
                   1904: /tmp0 max
                   1905: keys i  getUniv lengthUniv
                   1906:  sub
                   1907:  def
                   1908: /j (0)..  def
                   1909: %%for init.
                   1910: %%for
                   1911: { j tmp0  lt
                   1912:  {  } {exit} ifelse
                   1913: [ {%%increment
                   1914: /j  j (1).. add def
                   1915: } %%end of increment{A}
                   1916: {%%start of B part{B}
                   1917: /k k (1)..  add
                   1918:  def
                   1919: kk m  lt
                   1920:  %% if-condition
                   1921:   { %%ifbody
                   1922: ( ) messagen
                   1923:   }%%end if if body
                   1924:   { %%if- else part
                   1925:   } ifelse
                   1926: } %% end of B part. {B}
                   1927:  2 1 roll] {exec} map
                   1928: } loop %%end of for
                   1929: kk m  greaterThanOrEqual
                   1930:  %% if-condition
                   1931:   { %%ifbody
                   1932: /kk (0)..  def
                   1933: /k (0)..  def
                   1934: newline
                   1935:   }%%end if if body
                   1936:   { %%if- else part
                   1937:   } ifelse
                   1938: } %% end of B part. {B}
                   1939:  2 1 roll] {exec} map
                   1940: } loop %%end of for
                   1941: newline
                   1942: /ExitPoint ]pop popVariables %%pop the local variables
                   1943: } def
                   1944: %%end of function
                   1945:
1.35      takayama 1946: /rest {
                   1947:   /arg1 set [(Krest) arg1] extension
1.1       maekawa  1948: } def
                   1949: [(rest)
                   1950:  [(array rest the-rest-of-the-array)
                   1951:   (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
                   1952:  ]
                   1953: ] putUsages
                   1954:
                   1955: %% from SSkan/develop/minbase.sm1
                   1956: /reducedBase {
                   1957:   /arg1 set
                   1958:   [/base /minbase /n /i /j /myring /zero /f] pushVariables
                   1959:   [
                   1960:      /base arg1 def
                   1961:      base isArray { }
                   1962:      { (The argument of reducedBase must be an array of polynomials)
                   1963:         error
                   1964:      } ifelse
                   1965:      base 0 get isPolynomial { }
                   1966:      { (The element of the argument of reducedBase must be polynomials)
                   1967:         error
                   1968:      } ifelse
                   1969:      /myring  base 0 get (ring) dc def
1.37      takayama 1970:      /zero (0) myring __ def
1.1       maekawa  1971:      base length 1 sub /n set
                   1972:      /minbase [ 0 1 n { /i set base i get } for ] def
                   1973:      0 1 n {
                   1974:        /i set
                   1975:        minbase i get  /f set
                   1976:        f zero eq {
                   1977:        }
                   1978:        {
                   1979:            0 1 n {
                   1980:                /j set
                   1981:               << minbase j get zero eq >> << i j eq >> or {
                   1982:               }
                   1983:               {
                   1984:                  [(isReducible) << minbase j get >> f] gbext
                   1985:                  {
                   1986:                      minbase j zero put
                   1987:                   }
                   1988:                  {  } ifelse
                   1989:               } ifelse
                   1990:            } for
                   1991:        } ifelse
                   1992:      } for
                   1993:      minbase { minbase.iszero } map /arg1 set
                   1994:   ] pop
                   1995:   popVariables
                   1996:   arg1
                   1997: } def
                   1998:
                   1999: [(reducedBase)
                   2000:  [(base reducedBase reducedBase)
                   2001:   (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
                   2002:   (returns <<reducedBase>>.)
                   2003:   (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
                   2004:  ]
                   2005: ] putUsages
                   2006:
                   2007: %% package functions
                   2008: /minbase.iszero {
                   2009:   dup (0). eq {
                   2010:     pop
                   2011:   }
                   2012:   { } ifelse
                   2013: } def
                   2014:
                   2015: /== {
                   2016:   message
                   2017: } def
                   2018: [(==)
                   2019:  [(obj ==)
                   2020:   (Print obj)
                   2021:  ]
                   2022: ] putUsages
                   2023:
                   2024: /@@@.all_variables {
                   2025:   [/n /i] pushVariables
                   2026:   [
                   2027:      /n [(N)] system_variable def
                   2028:      [
                   2029:       0 1 n 1 sub {
                   2030:           /i set
                   2031:           [(x) (var) i] system_variable
                   2032:       } for
                   2033:       0 1 n 1 sub {
                   2034:           /i set
                   2035:           [(D) (var) i] system_variable
                   2036:       } for
                   2037:      ] /arg1 set
                   2038:   ] pop
                   2039:   popVariables
                   2040:   arg1
                   2041: } def
                   2042:
                   2043: /weightv {
                   2044:   @@@.all_variables
                   2045:   2 1 roll w_to_vec
                   2046: } def
                   2047:
                   2048: [(weightv)
                   2049:  [(array weightv weight_vector_for_init)
                   2050:   (cf. init)
                   2051:   (Example: /w [(x) 10 (h) 2] weightv def)
                   2052:   (         ((x-h)^10).  w init ::)
                   2053:  ]
                   2054: ] putUsages
                   2055:
                   2056: /output_order {
                   2057:   /arg1 set
                   2058:   [/vars /vlist /perm /total /ans] pushVariables
                   2059:   [
                   2060:     /vlist arg1 def
                   2061:     /vars @@@.all_variables def
                   2062:     vlist { vars 2 1 roll position } map  /perm set
                   2063:     perm ==
                   2064:     /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
                   2065:     perm perm total complement join /ans set
                   2066:     [(outputOrder) ans] system_variable
                   2067:   ] pop
                   2068:   popVariables
                   2069: } def
                   2070:
                   2071: [(output_order)
                   2072:  [$ [(v1) (v2) ...] output_order $
                   2073:   (Set the order of variables to print for the current ring.)
                   2074:   (cf. system_variable)
                   2075:   (Example:  [(y) (x)] output_order)
                   2076:   $           (x*y). ::   ===> y*x $
                   2077:  ]
                   2078: ] putUsages
                   2079:
                   2080: %% destraction.   SSkan/Kan/debug/des.sm1, 1998, 2/27 ,  3/1
                   2081: %% should be included in dr.sm1
                   2082:
                   2083: /factorial {
                   2084:   /arg2 set
                   2085:   /arg1 set
                   2086:   [ /f /n ] pushVariables
                   2087:   [
                   2088:     /f arg1 def
                   2089:     /n arg2 def
                   2090:     /ans (1).. def
                   2091:     n 0 lt { (f n factorial : n must be a non-negative integer)
                   2092:               error } { } ifelse
                   2093:     0 1 n 1 sub {
                   2094:        (universalNumber) dc /i set
                   2095:          ans  << f  i sub >> mul /ans set
                   2096:     } for
                   2097:     /arg1 ans def
                   2098:    ] pop
                   2099:    popVariables
                   2100:    arg1
                   2101: } def
                   2102:
                   2103: [(factorial)
                   2104:  [(f n factorial g)
                   2105:   $integer n,  g is f (f-1) ... (f-n+1)$
                   2106:  ]
                   2107: ] putUsages
                   2108:
                   2109:
                   2110: /destraction1 {
                   2111:   /arg4 set
                   2112:   /arg3 set
                   2113:   /arg2 set
                   2114:   /arg1 set
                   2115:   [/ww /f  /dx /ss /xx /coeff0 /expvec
                   2116:    /coeffvec /expvec2 /ans /one] pushVariables
                   2117:   [
                   2118:     /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
                   2119:     /one (1). def %%
                   2120:     /ww [ xx toString -1 dx toString 1 ] weightv  def
                   2121:     f ww init f sub (0). eq {   }
                   2122:     { [(destraction1 : inhomogeneous with respect to )
                   2123:         xx  ( and )  dx ] cat error } ifelse
                   2124:     f [[xx one]] replace dx coefficients  /coeff0 set
                   2125:     /expvec coeff0 0 get { (integer) dc } map def
                   2126:     /coeffvec coeff0 1 get def
                   2127:     expvec { ss 2 -1 roll factorial } map /expvec2 set
                   2128:     expvec2 coeffvec mul  /ans set
                   2129:     /arg1 ans def
                   2130:    ] pop
                   2131:    popVariables
                   2132:    arg1
                   2133: } def
                   2134:
                   2135:
                   2136: /distraction {
                   2137:   /arg4 set
                   2138:   /arg3 set
                   2139:   /arg2 set
                   2140:   /arg1 set
                   2141:   [/f  /dx /ss /xx  /ans /n /i] pushVariables
                   2142:   [(CurrentRingp)] pushEnv
                   2143:   [
                   2144:     /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
                   2145:     f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
                   2146:     /n xx length  def
                   2147:     0 1 n 1 sub {
                   2148:        /i set
                   2149:        /f  f xx i get dx i get ss i get destraction1 /f set
                   2150:     } for
                   2151:     /dist1.L
                   2152:     /arg1 f def
                   2153:   ]pop
                   2154:   popEnv
                   2155:   popVariables
                   2156:   arg1
                   2157: } def
                   2158: [(distraction)
                   2159:  [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
                   2160:   (   distraction  result )
                   2161:   $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
                   2162:  ]
                   2163: ] putUsages
                   2164: /destraction { distraction } def
                   2165:
                   2166:
                   2167:
                   2168:
                   2169: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                   2170: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                   2171: %%%%%%%%%%%%%%%% sorting
                   2172: %/N 1000 def
                   2173: %/a.shell [N -1 0 { } for ]  def
                   2174: %a.shell 0 -1000 put
                   2175: %% You need gate keeper.
                   2176: [(shell)
                   2177:  [([gate-keeper f1 f2 ... fm] shell result)
                   2178:   (Sort the list. Gate-keeper should be the smallest element)]
                   2179: ] putUsages
                   2180: /shell {
                   2181:  /arg1 set
                   2182:  [/N /a.shell /h /i /v /j] pushVariables
                   2183:  [
                   2184:   /a.shell arg1 def
                   2185:   /N a.shell length  1 sub def
                   2186:
                   2187:   /h 1 def
                   2188:   {/h h 3 mul 1 add def
                   2189:    << h N ge >> break
                   2190:   } loop
                   2191:   {
                   2192:      /h << h 3 idiv >> def
                   2193:      << h 1 add >> 1 N {
                   2194:         /i set
                   2195:         /v a.shell i get def
                   2196:         /j i def
                   2197:         {
                   2198:            %% a.shell print newline
                   2199:            << a.shell << j h sub >> get >>  v  le  break
                   2200:            a.shell j << a.shell << j h sub >> get >> put
                   2201:            /j j h sub def
                   2202:            j  h le break
                   2203:          } loop
                   2204:          a.shell j v put
                   2205:      } for
                   2206:      h 1 lt break
                   2207:   } loop
                   2208:   /arg1 a.shell def
                   2209:  ] pop
                   2210:  popVariables
                   2211:  arg1
                   2212: } def
                   2213: %%%% end of shell sort macro
                   2214:
                   2215: /variableNames {
                   2216:   /arg1 set
                   2217:   [/in-variableNames /rrr /nnn /i /cp] pushVariables
                   2218:   [
                   2219:     /rrr arg1 def
                   2220:     [(CurrentRingp)] system_variable /cp set
                   2221:     [(CurrentRingp) rrr] system_variable
                   2222:     [(N)] system_variable /nnn set
                   2223:     [ 0 1 nnn 1 sub {
                   2224:          /i set [(x) (var) i] system_variable } for ]
                   2225:     [ 0 1 nnn 1 sub {
                   2226:          /i set [(D) (var) i] system_variable } for ]
                   2227:     join /arg1 set
                   2228:     [(CurrentRingp) cp] system_variable
                   2229:    ] pop
                   2230:    popVariables
                   2231:    arg1
                   2232: } def
                   2233:
                   2234:
                   2235: /makeRingMap {
                   2236:   /arg3 set /arg2 set /arg1 set
                   2237:   [/in-makeRingMap /corres /M /N /corresM /corresN
                   2238:     /vars /vars-org /i /p /ans /cp] pushVariables
                   2239:   [
                   2240:     /corres arg1 def /M arg2 def /N arg3 def
                   2241:     /corresM corres 0 get def
                   2242:     /corresN corres 1 get def
                   2243:     [(CurrentRingp)] system_variable /cp set
                   2244:     [(CurrentRingp) M] system_variable
                   2245:     M variableNames /vars set  vars 1 copy /vars-org set
                   2246:     0 1 corresM length 1 sub {
                   2247:       /i set
                   2248:       vars corresM i get position /p set
                   2249:       p -1 gt {
                   2250:         vars p  $($ corresN i get $)$ 3 cat_n put
                   2251:       }  {   } ifelse
                   2252:     } for
                   2253:     /arg1 [vars M  N vars-org] def
                   2254:     [(CurrentRingp) cp] system_variable
                   2255:   ] pop
                   2256:   popVariables
                   2257:   arg1
                   2258: } def
                   2259:
                   2260:
                   2261:
                   2262: /ringmap {
                   2263:   /arg2 set /arg1 set
                   2264:   [/in-ringmap /f /M2N /cp /f2] pushVariables
                   2265:   [
                   2266:     /f arg1 def /M2N arg2 def
                   2267:     [(CurrentRingp)] system_variable /cp set
                   2268:     f (0). eq { /f2 f def }
                   2269:     {
                   2270:        %f (ring) dc M2N 1 get eq
                   2271:        %{ }
                   2272:        %{ (The argument polynomial does not belong to the domain ring.) message
                   2273:        %  error
                   2274:        % } ifelse
                   2275:         [(CurrentRingp) M2N 1 get] system_variable
                   2276:         [(variableNames) M2N 0 get] system_variable
                   2277:         f toString /f2 set
                   2278:         [(variableNames) M2N 3 get] system_variable
1.37      takayama 2279:         f2 M2N 2 get __ /f2 set
1.1       maekawa  2280:     } ifelse
                   2281:     [(CurrentRingp) cp] system_variable
                   2282:     /arg1 f2 def
                   2283:   ] pop
                   2284:   popVariables
                   2285:   arg1
                   2286: } def
                   2287:
                   2288: [(makeRingMap)
                   2289:  [( rule  ring1 ring2 makeRingMap maptable   )
                   2290:   (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
                   2291:  ]
                   2292: ] putUsages
                   2293: [(ringmap)
                   2294:  [(f mapTable ringmap r)
                   2295:   (f is mapped to r where the map is defined by the mapTable, which is generated)
                   2296:   (by makeRingMap as follows:)
                   2297:   ( rule  ring1 ring2 makeRingMap maptable   )
                   2298:   $Example:$
                   2299:   $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
                   2300:   $/R1 set$
                   2301:   $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
                   2302:   $/R2 set$
                   2303:   $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
                   2304:   $r0 R1 R2 makeRingMap /maptable set$
1.37      takayama 2305:   $(Dx-1) R1 __ /ff set$
1.1       maekawa  2306:   $ ff maptable ringmap :: $
                   2307:  ]
                   2308: ] putUsages
                   2309:
                   2310:
                   2311: /getVariableNames {
                   2312:   [/in-getVariableNames /ans /i /n] pushVariables
                   2313:   [
                   2314:      /n [(N)] system_variable def
                   2315:      [
                   2316:        n 1 sub -1 0 {
                   2317:          /i set
                   2318:          [(x) (var) i] system_variable
                   2319:        } for
                   2320:        n 1 sub -1 0{
                   2321:          /i set
                   2322:          [(D) (var) i] system_variable
                   2323:        } for
                   2324:       ] /arg1 set
                   2325:    ] pop
                   2326:   popVariables
                   2327:   arg1
                   2328: } def
                   2329: [(getVariableNames)
                   2330:  [(getVariableNames list-of-variables)
                   2331:   (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
                   2332:  ]
                   2333: ] putUsages
                   2334:
                   2335: /tolower {
                   2336:   /arg1 set
                   2337:   [/in-tolower /s /sl] pushVariables
                   2338:   [
                   2339:     /s arg1 def
                   2340:     s (array) dc /s set
                   2341:     s { tolower.aux (string) dc } map /sl set
                   2342:     sl aload length cat_n /arg1 set
                   2343:   ] pop
                   2344:   popVariables
                   2345:   arg1
                   2346: } def
                   2347:
                   2348: /tolower.aux {
                   2349:   /arg1 set
1.9       takayama 2350:   arg1 64 gt  arg1 91 lt and
1.1       maekawa  2351:   { arg1 32 add }
                   2352:   { arg1 } ifelse
                   2353: } def
                   2354: [(tolower)
                   2355:  [(string tolower string2)
                   2356:   (Capital letters in string are converted to lower case letters.)
                   2357:   $Example:  (Hello World) tolower :: (hello world)$
                   2358:  ]
                   2359: ] putUsages
                   2360:
                   2361: /hilbert {
                   2362:   /arg2 set
                   2363:   /arg1 set
                   2364:   [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
                   2365:   [
                   2366:      /base arg1 def
                   2367:      /vlist arg2 def
                   2368:      [(CurrentRingp)] system_variable /rrrorg set
                   2369:      /strf 0 def
                   2370:      vlist isString
                   2371:      {  /vlist [ vlist to_records pop ] def }
                   2372:      {  } ifelse
                   2373:      base isArray {  }
                   2374:      { (hilb : the first argument must be an array of polynomials.)
                   2375:         error
                   2376:      } ifelse
                   2377:      vlist isArray {  }
                   2378:      { (hilb : the second argument must be an array of polynomials.)
                   2379:         error
                   2380:      } ifelse
                   2381:
                   2382:      vlist 0 get isString{ /strf 1 def } { } ifelse
                   2383:      base 0 get isPolynomial {
                   2384:        base 0 get (ring) dc /rrr set
                   2385:      }
                   2386:      {
                   2387:        [  vlist { (,) } map  aload length cat_n ring_of_polynomials 0 ] define_ring
                   2388:        /rrr set
                   2389:        base { . } map /base set
                   2390:      } ifelse
1.37      takayama 2391:      vlist { dup isPolynomial {  } { rrr __ } ifelse } map /vlist set
1.1       maekawa  2392:
                   2393:      [(hilbert) base vlist] extension /ff set
                   2394:      [(CurrentRingp) rrrorg] system_variable
                   2395:      /arg1 ff def
                   2396:   ] pop
                   2397:   popVariables
                   2398:   arg1
                   2399: } def
                   2400:
                   2401: /hilbReduce {
                   2402:   /arg2 set
                   2403:   /arg1 set
                   2404:   [/hhh /f /d /vv /ans] pushVariables
                   2405:   [
                   2406:      /hhh arg1 def %% hilbert function
                   2407:      /vv arg2 def
                   2408:      /f hhh 1 get def
                   2409:      f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
1.37      takayama 2410:      f vv << f (ring) dc >> __  degree /vv set
1.1       maekawa  2411:      hhh 0 get /d set
                   2412:      d   d  (integer) dc factorial /d set
                   2413:      d << vv (universalNumber) dc vv factorial >> idiv /d set
                   2414:      [(divByN) f d] gbext /ans set
                   2415:      ans 1 get (0). eq
                   2416:      {  }
                   2417:      { (hilbReduce : Invalid hilbert function ) error } ifelse
                   2418:      /hilbReduce.label
                   2419:      ans 0 get /arg1 set
                   2420:   ]  pop
                   2421:   popVariables
                   2422:   arg1
                   2423: } def
                   2424:
                   2425:
                   2426: [(hilbReduce)
                   2427:  [([f,g] v hilbReduce p)
                   2428:   (output of hilbert [f,g];  string v; poly p)
                   2429:   (p is  (g/(f!))*deg(g)!)
                   2430:   $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
                   2431:  ]
                   2432: ] putUsages
                   2433: [(hilbert)
                   2434:  [(base vlist hilbert [m f])
                   2435:   (array of poly base; array of poly vlist; number m; poly f;)
                   2436:   (array of string base; array of string vlist; number m; poly f;)
                   2437:   (array of string base; string vlist; number m; poly f;)
                   2438:   ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
                   2439:   (The << base >> should be a reduced Grobner basis.)
                   2440:   (Or, when the << base >> is an array of string,)
                   2441:   (all entries should be monomials.)
                   2442:   (Example: [(x^2) (x y )] (x,y)  hilbert ::  [2, 2 h + 4] )
                   2443:   (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce ::  4)
                   2444:   (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce ::  3)
                   2445:   (cf. hilb,    hilbReduce)
                   2446:  ]
                   2447: ] putUsages
                   2448:
                   2449: /hilb {
                   2450:   hilbert (h) hilbReduce
                   2451: } def
                   2452: [(hilb)
                   2453:  [(base vlist hilb f)
                   2454:   (array of poly base; array of poly vlist;  poly f;)
                   2455:   (array of string base; array of string vlist; poly f;)
                   2456:   (array of string base; string vlist; number m; poly f;)
                   2457:   (f is the hilbert function (a_d x^d + ...)/m!)
                   2458:   (The << base >> should be a reduced Grobner basis.)
                   2459:   (Or, when the << base >> is an array of string,)
                   2460:   (all entries should be monomials.)
                   2461:   (Example: [(x^2) (x y )] (x,y)  hilb ::   h + 2 )
                   2462:   (Example: [(x^2) (y^2)] (x,y) hilb  4)
                   2463:   (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb ::  3)
                   2464:   (cf. hilbert,    hilbReduce)
                   2465:  ]
                   2466: ] putUsages
                   2467:
                   2468: [(diff0)
                   2469:  [ (f v n diff0 fn)
                   2470:    (<poly> fn, v ; <integer>  n ; <poly> fn)
                   2471:    (fn = v^n f where v^n is the operator to take the n-th differential.)
                   2472:    (We can use diff0 only in the ring of differential operators.)
                   2473:    (Example: [(x) ring_of_differential_operators 0] define_ring )
                   2474:    (         (x^10-x). (Dx). 1 diff0 ::)
                   2475:  ]
                   2476: ] putUsages
                   2477: /diff0 {
                   2478:   /arg3 set /arg2 set /arg1 set
                   2479:   [/in-diff /f /v /n /fn /rrr] pushVariables
                   2480:   [
                   2481:     /f arg1 def /v arg2 def /n arg3 def
                   2482:     f (0). eq
                   2483:     { /fn (0). def }
                   2484:     {
                   2485:        f (ring) dc /rrr set
1.37      takayama 2486:        v toString (^) n toString 3 cat_n rrr __
1.1       maekawa  2487:        f mul
1.37      takayama 2488:        [[v (0).] [(h) rrr __ (1) rrr __]] replace /fn set
1.1       maekawa  2489:      } ifelse
                   2490:      fn /arg1 set
                   2491:   ] pop
                   2492:   popVariables
                   2493:   arg1
                   2494: } def
                   2495:
                   2496: [(action)
                   2497:  [( f g action p )
                   2498:   (<poly> f,g,p)
                   2499:   (Act f on g. The result is p. The homogenization variable h is put to 1.)
                   2500:   (We can use diff0 only in the ring of differential operators.)
                   2501:   (Example: [(x) ring_of_differential_operators 0] define_ring )
                   2502:   (         (Dx^2). (x^2). action ::)
                   2503:  ]
                   2504: ] putUsages
                   2505: /action {
                   2506:   /arg2 set /arg1 set
                   2507:   [/in-action /f /g /h /rr /rr.org /rule] pushVariables
                   2508:   [
                   2509:     /f arg1 def /g arg2 def
                   2510:     /rr.org [(CurrentRingp)] system_variable def
                   2511:     f (0). eq
                   2512:     { /h (0). def }
                   2513:     {
                   2514:         f (ring) dc /rr set
                   2515:         [(CurrentRingp) rr] system_variable
                   2516:         f g mul /h set
                   2517:         /rule getVariableNames def
                   2518:         0 1 rule length 2 idiv { rule rest /rule set } for
                   2519:         rule { . [ 2 1 roll (0). ] } map /rule set
                   2520:         rule << rule length 1 sub >> [(h). (1).] put
                   2521:         %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
                   2522:         /h h rule replace def
                   2523:     } ifelse
                   2524:     [(CurrentRingp) rr.org ] system_variable
                   2525:     /arg1 h def
                   2526:   ] pop
                   2527:   popVariables
                   2528:   arg1
                   2529: } def
                   2530:
                   2531: [(ord_w)
                   2532:  [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
                   2533:   (poly ff; string v1; integer w1; ...)
1.11      takayama 2534:   (order of the initial of ff by the weight vector [w1 w2 ...])
1.1       maekawa  2535:   (Example: [(x,y) ring_of_polynomials 0] define_ring )
                   2536:   (          (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
                   2537:  ]
                   2538: ] putUsages
                   2539: /ord_w {
                   2540:   /arg2 set /arg1 set
                   2541:   [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
                   2542:   [
                   2543:     /fff arg1 def
                   2544:     /www arg2 def
1.33      takayama 2545:     www to_int32 /www set
1.1       maekawa  2546:     fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
                   2547:     fff (ring) dc /rrr set
                   2548:     fff init /fff set
                   2549:     /ddd 0 def
                   2550:     0 2 www length 1 sub {
                   2551:       /iii set
1.37      takayama 2552:       fff << www iii get rrr __ >> degree
1.1       maekawa  2553:       << www iii 1 add get >> mul
                   2554:       ddd add /ddd set
                   2555:     } for
1.12      takayama 2556:     /ord_w.LLL
                   2557:     /arg1 ddd def
                   2558:   ] pop
                   2559:   popVariables
                   2560:   arg1
                   2561: } def
                   2562:
                   2563: [(ord_w_all)
                   2564:  [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
                   2565:   (poly ff; string v1; integer w1; ...)
                   2566:   (order of ff by the weight vector [w1 w2 ...])
                   2567:   (Example: [(x,y,t) ring_of_polynomials 0] define_ring )
                   2568:   (          (x^2 y^3-x-t). [(t) 1 ] ord_w_all ::)
                   2569:  ]
                   2570: ] putUsages
                   2571: /ord_w_all {
                   2572:   /arg2 set /arg1 set
1.13      takayama 2573:   [/ord_w_all-in /fff /fff-in /www /rrr /iii /ddd /zzz /ddd-tmp] pushVariables
1.12      takayama 2574:   [
                   2575:     /fff arg1 def
                   2576:     /www arg2 def
1.33      takayama 2577:     www to_int32 /www set
1.13      takayama 2578:     fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse
                   2579:     /ddd -intInfinity def
1.12      takayama 2580:     fff (ring) dc /rrr set
1.37      takayama 2581:     /zzz (0) rrr __ def
1.12      takayama 2582:     fff init /fff-in set
                   2583:     fff fff-in sub /fff set
                   2584:     {
1.13      takayama 2585:      /ddd-tmp 0 def
1.12      takayama 2586:      0 2 www length 1 sub {
                   2587:        /iii set
1.37      takayama 2588:        fff-in << www iii get rrr __ >> degree
1.12      takayama 2589:        << www iii 1 add get >> mul
1.13      takayama 2590:        ddd-tmp add /ddd-tmp set
1.12      takayama 2591:      } for
1.13      takayama 2592:      ddd-tmp ddd gt { /ddd ddd-tmp def }  {  } ifelse
1.12      takayama 2593:      fff zzz eq { exit } {  } ifelse
                   2594:      fff init /fff-in set
                   2595:      fff fff-in sub /fff set
                   2596:     } loop
1.13      takayama 2597:     /ord_w_all.LLL
1.1       maekawa  2598:     /arg1 ddd def
                   2599:   ] pop
                   2600:   popVariables
                   2601:   arg1
                   2602: } def
                   2603:
                   2604: [(laplace0)
                   2605:  [
                   2606:  (f [v1 ... vn] laplace0 g)
                   2607:  (poly f ; string v1 ... vn ; poly g;)
                   2608:  (array of poly f ; string v1 ... vn ; array of poly g;)
                   2609:  ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
                   2610:  $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
                   2611:  $ x --> -Dx, Dx --> x,  y --> -Dy, Dy --> y. $
                   2612:  ]
                   2613: ] putUsages
                   2614: /laplace0 {
                   2615:   /arg2 set /arg1 set
                   2616:   [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
                   2617:   ] pushVariables
                   2618:   [
                   2619:   /ff arg1 def /vv arg2 def
                   2620:   /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
                   2621:   /rule [ ] def
                   2622:   ff isPolynomial {
                   2623:    ff (0). eq { /ans1 (0). def }
                   2624:    {
                   2625:      ff (ring) dc /rr set
                   2626:      /nn vv length def
                   2627:      0 1 nn 1 sub {
                   2628:       /ii set
                   2629:       vv ii get (type?) dc 1 eq
                   2630:       {  }  % skip, may be weight [(x) 2 ] is OK.
                   2631:       {
                   2632:          /v0 vv ii get (string) dc def
                   2633:          v0 (array) dc 0 get Dascii eq  %% If the first character is D?
                   2634:          {  rule  %% Dx-->x
1.37      takayama 2635:             [v0 rr __
                   2636:             v0 (array) dc rest { (string) dc} map aload length cat_n rr __]
1.1       maekawa  2637:             append /rule set
                   2638:          }
                   2639:          { rule   %% x --> -Dx
1.37      takayama 2640:            [v0 rr __
1.1       maekawa  2641:             (0).
                   2642:             [Dascii] v0 (array) dc join { (string) dc } map aload length
1.37      takayama 2643:             cat_n rr __  sub
1.1       maekawa  2644:            ]
                   2645:            append /rule set
                   2646:          } ifelse
                   2647:       } ifelse
                   2648:      } for
                   2649:      % rule message
1.37      takayama 2650:      ff rule replace [[(h) rr __ (1) rr __]] replace /ans1 set
1.1       maekawa  2651:      } ifelse
                   2652:     }
                   2653:    {
                   2654:        ff isArray { /ans1 ff {vv laplace0 } map def }
                   2655:        {
                   2656:          (laplace0 : the first argument must be a polynomial.) error
                   2657:        }ifelse
                   2658:     } ifelse
                   2659:     /arg1 ans1 def
                   2660:   ] pop
                   2661:   popVariables
                   2662:   arg1
                   2663: } def
                   2664:
                   2665: [(ip1)
                   2666:  [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
                   2667:   (<poly> v1 ... vn ; <integer> w1 ... wn m)
                   2668:   (<poly> f1 ... fs )
                   2669:   (Example: [(x,y) ring_of_differential_operators 0] define_ring )
                   2670:   (         [(Dx). (Dy).] [2 1] 3 ip1  ::    [(2 Dx Dy). (Dy^3).])
                   2671:   (         Returns Dx^p Dy^q such that  2 p + 1 q = 3.)
                   2672:  ]
                   2673: ] putUsages
                   2674: /ip1 {
                   2675:   /arg3 set /arg2 set /arg1 set
                   2676:   [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
                   2677:   [
                   2678:      /vv arg1 def /ww arg2 def /m arg3 def
                   2679:      vv 0 get (ring) dc /rr set
                   2680:      /rr.org [(CurrentRingp)] system_variable def
                   2681:      [(CurrentRingp) rr] system_variable
                   2682:      [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
                   2683:      /ans [ ] def
                   2684:      m 0 lt
                   2685:      {  }
                   2686:      {
                   2687:        vv
                   2688:        ww { tt 2 1 roll power } map mul /tmp1 set
                   2689:  %%      (tmp1 = ) messagen tmp1 message
                   2690:        0 1 m {
                   2691:          /k set
                   2692:          k 0 eq {
                   2693:            /ff (1). def
                   2694:          }
                   2695:          { tmp1 k power /ff set } ifelse
                   2696:          ff [[(h). (1).]] replace /ff set
                   2697:  %%        ff message
                   2698:          {
                   2699:            ff init tt degree m eq {
                   2700:              /ans ans [ ff init [[tt (1).]] replace ] join def
                   2701:            } { } ifelse
                   2702:            ff ff init sub /ff set
                   2703:            ff (0). eq { exit } {  } ifelse
                   2704:          } loop
                   2705:         } for
                   2706:       } ifelse
                   2707:      [(CurrentRingp) rr.org] system_variable
                   2708:      /arg1 ans def
                   2709:   ] pop
                   2710:   popVariables
                   2711:   arg1
                   2712: } def
                   2713:
                   2714: [(findIntegralRoots)
                   2715:  [( f findIntegralRoots vlist)
                   2716:   (poly f; list of integers vlist;)
                   2717:   (string f; list of integers vlist;)
                   2718:   (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
                   2719:   (Example: (s^4-1) findIntegralRoots )
                   2720:  ]
                   2721: ] putUsages
                   2722:
                   2723: /findIntegralRoots { findIntegralRoots.slow } def
                   2724:
                   2725: /findIntegralRoots.slow {  %% by a stupid algorithm
                   2726:   /arg1 set
                   2727:   [/in-findIntegralRoots
                   2728:    /ff /kk /roots /rrr /nn /k0 /d.find
                   2729:   ] pushVariables
                   2730:   [
                   2731:     /ff arg1 def
                   2732:     /roots [  ] def
                   2733:     /rrr [(CurrentRingp)] system_variable def
                   2734:     ff toString /ff set
                   2735:     [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
                   2736:     ff . /ff set
                   2737:
                   2738:     %%ff message  %% Cancel the common numerical factor of the polynomial ff.
                   2739:     ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
                   2740:     [(divByN) ff d.find] gbext 0 get /ff set
                   2741:     %% d.find message
                   2742:     %% ff message
                   2743:
                   2744:     ff [[(s). (0).]] replace /k0 set
                   2745:     k0 (universalNumber) dc /k0 set
                   2746:     k0 (0).. eq { roots (0).. append /roots set } { } ifelse
                   2747:
                   2748:     {
                   2749:       ff [[(s). (0).]] replace /nn set
                   2750:       nn (universalNumber) dc /nn set
                   2751:       nn (0).. eq
                   2752:       { (s^(-1)). ff mul /ff set }
                   2753:       { exit }
                   2754:       ifelse
                   2755:     } loop
                   2756:     ff [[(s). (0).]] replace /k0 set
                   2757:     k0 (universalNumber) dc /k0 set
                   2758:     k0 (-40000).. gt k0 (40000).. lt and not {
                   2759:      [(Roots of b-function cannot be obtained by a stupid method.) nl
                   2760:       (Use ox_asir for efficient factorizations, or restall and bfm manually.)
                   2761:        nl
                   2762:       (ox_asir server will be distributed from the asir ftp cite.) nl
                   2763:       (See lib/ttt.tex for details.) nl
                   2764:       ] cat
                   2765:       error
                   2766:     } {  } ifelse
                   2767:     nn (0).. lt { (0).. nn sub /nn set } {  } ifelse
                   2768:     /kk  (0).. nn sub  def
                   2769:     /roots [ kk (1).. sub ] roots join def
                   2770:     {
                   2771:        kk nn gt { exit } {  } ifelse
                   2772:        ff [[(s). kk (poly) dc]] replace
                   2773:        (0). eq
                   2774:        { /roots roots kk append def }
                   2775:        {  } ifelse
                   2776:        kk (1).. add /kk set
                   2777:     }  loop
                   2778:     [(CurrentRingp) rrr] system_variable
                   2779:     roots { (integer) dc } map /roots set %% ??  OK?
                   2780:     roots shell rest /roots set
                   2781:     /arg1 roots def
                   2782:   ] pop
                   2783:   popVariables
                   2784:   arg1
                   2785: } def
                   2786:
                   2787: /ngcd {
                   2788:   /arg1 set
                   2789:   [/in-ngcd /nlist /g.ngcd /ans] pushVariables
                   2790:   [
                   2791:      /nlist arg1 def
1.29      takayama 2792:      nlist to_univNum /nlist set
1.1       maekawa  2793:      nlist length 2 lt
                   2794:      { /ans nlist 0 get def /L.ngcd goto }
                   2795:      {
                   2796:         [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
                   2797:         g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
                   2798:         [g.ngcd] nlist rest rest join ngcd /ans set
                   2799:       } ifelse
                   2800:      /L.ngcd
                   2801:      ans /arg1 set
                   2802:   ] pop
                   2803:   popVariables
                   2804:   arg1
                   2805: } def
                   2806:
                   2807: [(ngcd)
                   2808:  [(nlist ngcd d )
                   2809:   (list of numbers nlist; number d;)
                   2810:   (d is the gcd of the numbers in nlist.)
                   2811:   (Example: [(12345).. (67890).. (98765)..] ngcd )
                   2812: ]] putUsages
                   2813:
                   2814: /dehomogenize {
                   2815:   /arg1 set
                   2816:   [/in-dehomogenize /f /rr /ans /cring] pushVariables
                   2817:   [
                   2818:      /f arg1 def
                   2819:      f isPolynomial {
                   2820:        f (0). eq
                   2821:        { f /ans set }
                   2822:        {
                   2823:           f (ring) dc /rr set
                   2824:           [(CurrentRingp)] system_variable /cring set
                   2825:           [(CurrentRingp) rr] system_variable
                   2826:           f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
                   2827:           [(CurrentRingp) cring] system_variable
                   2828:        } ifelse
                   2829:      }
                   2830:      {
                   2831:         f isArray {
                   2832:          f { dehomogenize } map /ans set
                   2833:         }
                   2834:         {(dehomogenize: argument should be a polynomial.) error }
                   2835:         ifelse
                   2836:      } ifelse
                   2837:      /arg1 ans def
                   2838:   ] pop
                   2839:   popVariables
                   2840:   arg1
                   2841: } def
                   2842:
                   2843: [(dehomogenize)
                   2844:  [(obj dehomogenize obj2)
                   2845:   (dehomogenize puts the homogenization variable to 1.)
                   2846:   (Example:  (x*h+h^2). dehomogenize ::    x+1 )
                   2847:  ]
                   2848: ] putUsages
                   2849:
                   2850:
                   2851: /from_records { { (,) } map aload length cat_n } def
                   2852: [(from_records)
                   2853:  [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
                   2854:    (Example : [(x) (y)] from_records ::    (x,y,))
                   2855:    (cf. to_records)
                   2856:  ]
                   2857: ] putUsages
                   2858: /popEnv {
                   2859:   { system_variable pop } map pop
                   2860: } def
                   2861:
                   2862: /pushEnv {
                   2863:    %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
                   2864:    { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
                   2865: } def
                   2866: [(pushEnv)
                   2867:  [(keylist pushEnv envlist)
                   2868:   (array of string keylist, array of [string object] envlist;)
                   2869:   (Values <<envlist>> of the global system variables specified )
                   2870:   (by the <<keylist>> is push on the stack.)
                   2871:   (keylist is an array of keywords for system_variable.)
                   2872:   (cf. system_variable, popEnv)
                   2873:   (Example:  [(CurrentRingp) (KanGBmessage)] pushEnv)
                   2874:  ]
                   2875: ] putUsages
                   2876: [(popEnv)
                   2877:  [(envlist popEnv)
                   2878:   (cf. pushEnv)
                   2879:  ]
                   2880: ] putUsages
                   2881:
                   2882: /npower {
                   2883:   /arg2 set
                   2884:   /arg1 set
                   2885:   [/f /k /i /ans] pushVariables
                   2886:   [
                   2887:      /f arg1 def   /k arg2 ..int def
                   2888:      f tag PolyP eq {
                   2889:        /ans (1). def
                   2890:      } {
                   2891:        /ans (1).. def
                   2892:      } ifelse
                   2893:      k 0 lt {
                   2894:        1 1 << 0 k sub >> {
                   2895:          /ans f ans {mul} sendmsg2 def
                   2896:        } for
                   2897:        /ans (1).. ans {div} sendmsg2 def
                   2898:      }
                   2899:      {
                   2900:        1 1 k {
                   2901:          /ans f ans {mul} sendmsg2 def
                   2902:        } for
                   2903:      } ifelse
                   2904:      /arg1 ans def
                   2905:   ] pop
                   2906:   popVariables
                   2907:   arg1
                   2908: } def
                   2909: [(npower)
                   2910:  [(obj1 obj2 npower obj3)
                   2911:   (npower returns obj1^obj2 as obj3)
                   2912:   (The difference between power and npower occurs when we compute f^0)
                   2913:   (where f is a polynomial.)
                   2914:   $power returns number(universalNumber) 1, but npower returns 1$
                   2915:   (in the current ring.)
                   2916:  ]
                   2917: ] putUsages
                   2918:
                   2919: /gensym {
                   2920:   (dollar) dc 2 cat_n
                   2921: } def
                   2922: [(gensym)
                   2923:  [(x i gensym xi)
                   2924:   (string x; integer i; string xi)
                   2925:   (It generate a string x indexed with the number i.)
                   2926:   $Example:  (Dx) 12 gensym (Dx12)$
                   2927:  ]
                   2928: ] putUsages
                   2929:
                   2930: /cat {
                   2931:   { toString } map aload length cat_n
                   2932: } def
                   2933: [(cat)
                   2934:  [(a cat s)
                   2935:   (array a ; string s;)
                   2936:   (cat converts each entry of << a >> to a string and concatenates them.)
                   2937:   (Example: [ (x) 1 2] cat ==> (x12))
                   2938:  ]
                   2939: ] putUsages
                   2940:
                   2941:
                   2942: %%%%%%%%%%%%%%%%%%% pmat-level
                   2943: /pmat-level {
                   2944:   /arg2 set
                   2945:   /arg1 set
                   2946:   [/n /i /m /lev /flag] pushVariables
                   2947:   [
                   2948:     /m arg1 def
                   2949:     /lev arg2 def
                   2950:     m isArray {
                   2951:        /n m length def
                   2952:        n 0 eq { /flag 0 def }
                   2953:        { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
                   2954:     } {  /flag 0 def } ifelse
                   2955:
                   2956:     flag {
                   2957:       0 1 lev {
                   2958:         pop ( ) messagen
                   2959:       } for
                   2960:       ([ ) message
                   2961:       0 1 n 1 sub {
                   2962:         /i set
                   2963:         m i get lev 1 add pmat-level
                   2964:       } for
                   2965:       0 1 lev {
                   2966:         pop ( ) messagen
                   2967:       } for
                   2968:       (]) message
                   2969:     }
                   2970:     {
                   2971:        0 1 lev {
                   2972:          pop ( ) messagen
                   2973:        } for
                   2974:        ( ) messagen
                   2975:        m message
                   2976:     } ifelse
                   2977:   ] pop
                   2978:   popVariables
                   2979: } def
                   2980:
                   2981: /pmat {  0 pmat-level } def
                   2982:
                   2983: [(pmat)
                   2984:  [(f pmat)
                   2985:   (array f;)
                   2986:   (f is pretty printed.)
                   2987:  ]
                   2988: ] putUsages
                   2989:
                   2990:
                   2991: /adjoint1 {
                   2992:   /arg2 set
                   2993:   /arg1 set
                   2994:   [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
                   2995:   [
                   2996:      /f arg1 def
                   2997:      /xx arg2 def
                   2998:      f isPolynomial {  }
                   2999:      { (adjoint1: the first argument must be a polynomial.) message
                   3000:        pop popVariables
                   3001:        (adjoint1: the first argument must be a polynomial.)  error
                   3002:      } ifelse
                   3003:      /ans (0). def
                   3004:      f (0). eq {   }
                   3005:      {
                   3006:         /xx xx (string) dc def
                   3007:         /dxx [@@@.Dsymbol xx] cat def
1.37      takayama 3008:         /xx xx f (ring) dc __ def
                   3009:         /dxx dxx f (ring) dc __ def
                   3010:         /one (1) f (ring) dc __ def
1.1       maekawa  3011:
                   3012:         {
                   3013:           /g f init def
                   3014:           /f f g sub def
                   3015:           /p g xx degree def
                   3016:           /q g dxx degree def
                   3017:           g [[xx one] [dxx one]] replace /g set
                   3018:           g
                   3019:           << (0). dxx sub q npower    xx p npower mul >>
                   3020:           mul
                   3021:           ans add /ans set
                   3022:           f (0). eq { exit } { } ifelse
                   3023:         } loop
                   3024:         ans dehomogenize /ans set
                   3025:      } ifelse
                   3026:      /arg1 ans def
                   3027:   ] pop
                   3028:   popVariables
                   3029:   arg1
                   3030: } def
                   3031:
                   3032: /adjoint {
                   3033:   /arg2 set
                   3034:   /arg1 set
                   3035:   [/in-adjoint /f /xx /xx0] pushVariables
                   3036:   [
                   3037:      /f arg1 def /xx arg2 def
                   3038:      xx toString /xx set
                   3039:      [xx to_records pop] /xx set
                   3040:      xx { /xx0 set f xx0 adjoint1 /f set } map
                   3041:      /arg1 f def
                   3042:   ]pop
                   3043:   popVariables
                   3044:   arg1
                   3045: } def
                   3046:
                   3047: [(adjoint)
                   3048:  [(f xlist adjoint g)
                   3049:   (poly f; string xlist; poly g;)
                   3050:   (g is the adjoint operator of f.)
                   3051:   (The variables to take adjoint are specified by xlist.)
                   3052:   (Example: [(x,y) ring_of_differential_operators 0] define_ring)
                   3053:   (          (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
                   3054:   $          ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
                   3055: ]] putUsages
                   3056:
                   3057: %%%%% diagonal for tensor products
                   3058: %% 1998, 12/4 (Sat)
                   3059: %% s_i = x_i, t_i = x_i - y_i,    Restrict to t_i = 0.
                   3060: %% x_i = x_i, y_i = s_i - t_i,
                   3061: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
                   3062: /diagonalx {
                   3063:   /arg2 set
                   3064:   /arg1 set
                   3065:   [/in-diagonalx /f] pushVariables
                   3066:   [
                   3067:     (Not implemented yet.) message
                   3068:   ] pop
                   3069:   popVariables
                   3070:   arg1
                   3071: } def
                   3072:
                   3073:
                   3074:
                   3075: %%%%%%%%%%%  distraction2 for b-function
                   3076: /distraction2 {
                   3077:   /arg4 set
                   3078:   /arg3 set
                   3079:   /arg2 set
                   3080:   /arg1 set
                   3081:   [/f  /dx /ss /xx  /ans /n /i /rr] pushVariables
                   3082:   [
                   3083:     /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
                   3084:     f (0). eq {  }
                   3085:     {
                   3086:       /rr f (ring) dc def
1.37      takayama 3087:       xx {toString rr __ } map /xx set
                   3088:       dx {toString rr __ } map /dx set
                   3089:       ss {toString rr __ } map /ss set
1.1       maekawa  3090:       /n xx length  def
                   3091:       0 1 n 1 sub {
                   3092:          /i set
                   3093:          /f  f xx i get dx i get ss i get destraction2.1 /f set
                   3094:       } for
                   3095:     } ifelse
                   3096:     /arg1 f def
                   3097:   ]pop
                   3098:   popVariables
                   3099:   arg1
                   3100: } def
                   3101: [(distraction2)
                   3102:  [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
                   3103:   (   distraction2  result )
                   3104:   $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
                   3105:   $  (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
                   3106:   $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
                   3107:  ]
                   3108: ] putUsages
                   3109: /destraction2.1 {
                   3110:   /arg4 set
                   3111:   /arg3 set
                   3112:   /arg2 set
                   3113:   /arg1 set
                   3114:   [/ww /f  /dx /ss /xx /coeff0 /expvec
                   3115:    /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
                   3116:   [
                   3117:     /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
                   3118:     f (ring) dc /rr set
1.37      takayama 3119:     /one (1) rr __ def %%
1.1       maekawa  3120:     /ww [ xx toString -1 dx toString 1 ] weightv  def
                   3121:     f ww init f sub (0). eq {   }
                   3122:     { [(destraction2.1 : inhomogeneous with respect to )
                   3123:         xx  ( and )  dx  nl
                   3124:        (Your weight vector may not be generic.)
                   3125:       ] cat error } ifelse
                   3126:     /dd << f dx degree >> << f xx degree >> sub def
                   3127:     f [[xx one]] replace dx coefficients  /coeff0 set
                   3128:     /expvec coeff0 0 get { (integer) dc } map def
                   3129:     /coeffvec coeff0 1 get def
                   3130:     expvec { ss 2 -1 roll factorial } map /expvec2 set
                   3131:     expvec2 coeffvec mul  /ans set
                   3132:     %% x^p d^q, (p > q) case.  x^2( x^2 Dx^2 + x Dx + 1)
                   3133:     dd 0 lt {
                   3134:       %% (ss+1) (ss+2) ... (ss+d)
                   3135:       one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
                   3136:       ans mul /ans set
                   3137:     }
                   3138:     {  } ifelse
                   3139:     /arg1 ans def
                   3140:    ] pop
                   3141:    popVariables
                   3142:    arg1
1.3       takayama 3143: } def
                   3144:
                   3145: /distraction2* {
                   3146:   /arg1 set
                   3147:   [/in-distraction2* /aa /f /vlist /xlist /dlist /slist ] pushVariables
                   3148:   [(CurrentRingp)] pushEnv
                   3149:   [
                   3150:      /aa arg1 def
                   3151:      /f aa 0 get def
                   3152:      /vlist aa 1 get def
                   3153:      /xlist aa 2 get def
                   3154:      /dlist aa 3 get def
                   3155:      /slist aa 4 get def
                   3156:      vlist isArray
                   3157:      {
                   3158:         vlist { toString } map   /vlist set
                   3159:      }
                   3160:      {
                   3161:         vlist toString to_records  /vlist set
                   3162:       } ifelse
                   3163:      xlist isArray
                   3164:      {
                   3165:         xlist { toString } map   /xlist set
                   3166:      }
                   3167:      {
                   3168:         xlist toString to_records  /xlist set
                   3169:       } ifelse
                   3170:      slist isArray
                   3171:      {
                   3172:         slist { toString } map   /slist set
                   3173:      }
                   3174:      {
                   3175:         slist toString to_records  /slist set
                   3176:       } ifelse
                   3177:      [vlist from_records ring_of_differential_operators 0] define_ring pop
                   3178:      f toString .
                   3179:      xlist { . } map
                   3180:      dlist { toString . } map
                   3181:      slist { toString . } map
                   3182:      distraction2 /arg1 set
                   3183:   ] pop
                   3184:   popEnv
                   3185:   popVariables
                   3186:   arg1
1.1       maekawa  3187: } def
                   3188:
                   3189: /message-quiet  {
                   3190:   @@@.quiet { pop } { message } ifelse
                   3191: } def
                   3192: [(message-quiet)
                   3193:  [(s message-quiet )
                   3194:  (string s;)
                   3195:  (It outputs the message s when @@@.quiet is not equal to 1.)
                   3196:  (@@@.quiet is set to 1 when you start sm1 with the option -q.)
                   3197: ]] putUsages
                   3198: /messagen-quiet  {
                   3199:   @@@.quiet { pop } { messagen } ifelse
                   3200: } def
                   3201: [(messagen-quiet)
                   3202:  [(s messagen-quiet )
                   3203:  (string s;)
                   3204:  (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
                   3205:  (@@@.quiet is set to 1 when you start sm1 with the option -q.)
                   3206: ]] putUsages
                   3207:
                   3208: /getvNames0 {
                   3209:   /arg1 set
                   3210:   [/in-getvNames0 /nlist /nn /i] pushVariables
                   3211:   [
                   3212:     /nlist arg1 def
                   3213:     [(N)] system_variable /nn set
                   3214:     nlist { /i set
                   3215:        i nn lt {
                   3216:          [(x) (var) i] system_variable
                   3217:        } {
                   3218:          [(D) (var) i nn sub] system_variable
                   3219:        } ifelse
                   3220:     } map
                   3221:     /arg1 set
                   3222:   ] pop
                   3223:   popVariables
                   3224:   arg1
                   3225: } def
                   3226:
                   3227: /getvNames {
                   3228:   [/in-getvNames /nn] pushVariables
                   3229:   [
                   3230:     [(N)] system_variable /nn set
                   3231:     [0 1 nn 2 mul 1 sub {  } for] getvNames0 /arg1 set
                   3232:   ] pop
                   3233:   popVariables
                   3234:   arg1
                   3235: } def
                   3236: [(getvNames)
                   3237: [(getvNames vlist)
                   3238:  (list vlist)
                   3239:  (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
                   3240:  (Use with [(variableNames) vlist] system_variable.)
                   3241:  (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
                   3242: ]] putUsages
                   3243:
                   3244: /getvNamesC {
                   3245:   [/in-getvNamesC /nn /i] pushVariables
                   3246:   [
                   3247:     [(N)] system_variable /nn set
                   3248:     [nn 1 sub -1 0 {  } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
                   3249:   ] pop
                   3250:   popVariables
                   3251:   arg1
                   3252: } def
                   3253: [(getvNamesC)
                   3254: [(getvNamesC vlist)
                   3255:  (list vlist)
                   3256:  $It returns of the list of the variables in the order 0, 1, 2, ... $
                   3257:  $(cmo-order and output_order).$
                   3258:  (cf. getvNames)
                   3259: ]] putUsages
                   3260:
                   3261: /getvNamesCR {
                   3262:   /arg1 set
                   3263:   [/in-getvNamesCR /rrr] pushVariables
                   3264:   [(CurrentRingp)] pushEnv
                   3265:   [
                   3266:     /rrr arg1 def
                   3267:     rrr isPolynomial {
                   3268:       rrr (0). eq { (No name field for 0 polynomial.) error }
                   3269:       { rrr (ring) dc /rrr set } ifelse
                   3270:     } { } ifelse
                   3271:     [(CurrentRingp) rrr] system_variable
                   3272:     getvNamesC /arg1 set
                   3273:   ] pop
                   3274:   popEnv
                   3275:   popVariables
                   3276:   arg1
                   3277: } def
                   3278: [(getvNamesCR)
                   3279: [(obj getvNamesCR vlist)
                   3280:  (obj ring | poly ; list vlist)
                   3281:  $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
                   3282:  (for <<obj>>.)
                   3283:  (Example: ( (x-2)^3 ). /ff set )
                   3284:  (         [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
                   3285: ]] putUsages
                   3286:
                   3287:
                   3288: /reduction-noH {
                   3289:   /arg2 set
                   3290:   /arg1 set
                   3291:   [/in-reduction-noH /ff /gg] pushVariables
                   3292:   [(Homogenize)] pushEnv
                   3293:   [
                   3294:     /ff arg1 def
                   3295:     /gg arg2 def
                   3296:     [(Homogenize) 0] system_variable
                   3297:     ff gg reduction /arg1 set
                   3298:   ] pop
                   3299:   popEnv
                   3300:   popVariables
                   3301:   arg1
                   3302: } def
                   3303: [(reduction-noH)
                   3304: [(f g reduction-noH r)
                   3305:  (poly f; array g; array r;)
                   3306:  (Apply the normal form algorithm for f with the set g. All computations are)
                   3307:  (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
                   3308:  (specifications are the same with reduction. cf. reduction)
                   3309:  (g should be dehomogenized.)
                   3310: ]] putUsages
                   3311:
                   3312: /-intInfinity -999999999  def
                   3313: /intInfinity   999999999  def
                   3314: [(intInfinity)
                   3315: [(intInfinity = 999999999)]
                   3316: ] putUsages
                   3317: [(-intInfinity)
                   3318: [(-intInfinity = -999999999)]
                   3319: ] putUsages
                   3320:
                   3321:
                   3322: /maxInArray {
                   3323:   /arg1 set
                   3324:   [/in-maxInArray /v /ans /i /n] pushVariables
                   3325:   [
                   3326:     /v arg1 def
                   3327:     /n v length def
                   3328:     /maxInArray.pos 0 def
                   3329:     n 0 eq {
                   3330:       /ans null def
                   3331:     } {
                   3332:       /ans v 0 get def
                   3333:       1 1 n 1 sub {
                   3334:         /i set
                   3335:         v i get ans gt {
                   3336:            /ans v i get def
                   3337:            /maxInArray.pos i def
                   3338:         } { } ifelse
                   3339:       } for
                   3340:     } ifelse
                   3341:     /arg1 ans def
                   3342:   ] pop
                   3343:   popVariables
                   3344:   arg1
                   3345: } def
                   3346: [(maxInArray)
                   3347: [( [v1 v2 ....] maxInArray m )
                   3348:  (m is the maximum in [v1 v2 ...].)
                   3349:  (The position of m is stored in the global variable maxInArray.pos.)
                   3350: ]] putUsages
                   3351:
                   3352: /cancelCoeff {
1.18      takayama 3353:   /arg1 set
                   3354:   [(reduceContent) arg1] gbext 0 get
                   3355: } def
                   3356: /cancelCoeff_org {
1.1       maekawa  3357:  /arg1 set
                   3358:  [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
                   3359:  [  /ff arg1 def
                   3360:     ff (0). eq {
                   3361:       /label.cancelCoeff2 goto
                   3362:     } {  } ifelse
                   3363:     /gg ff def
                   3364:     /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
                   3365:     {
                   3366:        gg (0). eq { exit} {  } ifelse
                   3367:        [(lcoeff) gg init] gbext (universalNumber) dc  /dd2 set
                   3368:        [(gcd) dd dd2] mpzext /dd set
                   3369:        dd (1).. eq {
                   3370:          /label.cancelCoeff goto
                   3371:        } {  } ifelse
                   3372:        /gg gg gg init sub def
                   3373:      } loop
                   3374:      [(divByN)  ff dd] gbext 0 get /ff set
                   3375:     /label.cancelCoeff
                   3376:      [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
                   3377:      { ff (-1).. mul /ff set } {  } ifelse
                   3378:     /label.cancelCoeff2
                   3379:     /arg1 ff def
                   3380:  ] pop
                   3381:  popVariables
                   3382:  arg1
                   3383: } def
                   3384: [(cancelCoeff)
                   3385:  [(f cancelcoeff g)
                   3386:   (poly f,g;)
                   3387:   (Factor out the gcd of the coefficients.)
                   3388:   (Example: (6 x^2 - 10 x). cancelCoeff)
                   3389:   (See also gbext.)
                   3390: ]] putUsages
                   3391:
                   3392:
                   3393: /flatten {
                   3394:   /arg1 set
                   3395:   [/in-flatten /mylist] pushVariables
                   3396:   [
                   3397:      /mylist arg1 def
                   3398:      mylist isArray {
                   3399:        mylist { dup isArray { aload pop } { } ifelse } map /mylist set
                   3400:      }{ } ifelse
                   3401:      /arg1 mylist def
                   3402:   ] pop
                   3403:   popVariables
                   3404:   arg1
                   3405: } def
                   3406: [(flatten)
                   3407:  [(list flatten list2)
                   3408:   (Flatten the list.)
                   3409:   (Example 1: [ [1 2 3] 4 [2]] flatten    ===> [1 2 3 4 2])
                   3410: ]] putUsages
                   3411:
                   3412: %% Take first N elements.
                   3413: /carN {
                   3414:   /arg2 set
                   3415:   /arg1 set
                   3416:   [/in-res-getN /pp /nn /ans] pushVariables
                   3417:   [
                   3418:      /nn arg2 def
                   3419:      /pp arg1 def
                   3420:      pp isArray {
                   3421:        pp length nn lt {
                   3422:          /ans pp def
                   3423:        } {
                   3424:          [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
                   3425:        } ifelse
                   3426:      } {
                   3427:        /ans pp def
                   3428:      } ifelse
                   3429:      /arg1 ans def
                   3430:   ] pop
                   3431:   popVariables
                   3432:   arg1
                   3433: } def
                   3434: [(carN)
                   3435: [([f1 ... fm]  n carN  [f1 ... fn])
                   3436:  (carN extracts the first n elements from the list.)
                   3437: ]] putUsages
                   3438:
                   3439: /getRing {
                   3440:   /arg1 set
                   3441:   [/in-getRing /aa /n /i /ans] pushVariables
                   3442:   [
                   3443:     /aa arg1 def
                   3444:     /ans null def
                   3445:     aa isPolynomial {
                   3446:       aa (0). eq {
                   3447:       } {
                   3448:          /ans aa (ring) dc def
                   3449:       } ifelse
                   3450:     } {
                   3451:      aa isArray {
                   3452:        /n aa length 1 sub def
                   3453:        0 1 n { /i set aa i get getRing /ans set
                   3454:                ans tag 0 eq {  } { /getRing.LLL goto } ifelse
                   3455:        } for
                   3456:      }{ } ifelse
                   3457:     } ifelse
                   3458:     /getRing.LLL
                   3459:     /arg1 ans def
                   3460:   ] pop
                   3461:   popVariables
                   3462:   arg1
                   3463: } def
                   3464: [(getRing)
                   3465: [(obj getRing rr)
1.51      takayama 3466:  (ring rr; )
1.1       maekawa  3467:  (getRing obtains the ring structure from obj.)
                   3468:  (If obj is a polynomial, it returns the ring structure associated to)
                   3469:  (the polynomial.)
                   3470:  (If obj is an array, it recursively looks for the ring structure.)
1.51      takayama 3471:  (cf. ring_def)
1.1       maekawa  3472: ]] putUsages
                   3473: /toVectors {
                   3474:   /arg1 set
                   3475:   [/in-toVectors /gg /n /ans] pushVariables
                   3476:   [
                   3477:     /gg arg1 def
                   3478:     gg isArray {
                   3479:       gg length 0 eq {
                   3480:         /ans [ ] def
                   3481:         /toVectors.LLL goto
                   3482:       } {
                   3483:         gg 0 get isInteger {
                   3484:           gg @@@.toVectors2 /ans set
                   3485:         } {
                   3486:           gg @@@.toVectors /ans set
                   3487:         } ifelse
                   3488:         /toVectors.LLL goto
                   3489:       } ifelse
                   3490:     } {
                   3491:       %% It is not array.
                   3492:       gg (array) dc /ans set
                   3493:     } ifelse
                   3494:     /toVectors.LLL
                   3495:     /arg1 ans def
                   3496:    ] pop
                   3497:    popVariables
                   3498:    arg1
                   3499: } def
                   3500: /@@@.toVectors2 {
                   3501:   /arg1 set
                   3502:   [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
                   3503:   [
                   3504:     /gg arg1 def
                   3505:     /ans gg 1 get @@@.toVectors def
                   3506:     /n   gg 0 get def
                   3507:     gg 1 get isArray not {
                   3508:        /ans [ans] def
                   3509:        /notarray 1 def
                   3510:     }{ /notarray 0 def} ifelse
                   3511:     ans {
                   3512:       /tmp set
                   3513:       tmp length n lt {
                   3514:         tmp
                   3515:         [1 1 n tmp length sub { pop (0). } for ]
                   3516:         join /tmp set
                   3517:       } {  } ifelse
                   3518:       tmp
                   3519:     } map
                   3520:     /ans set
                   3521:     notarray { ans 0 get /ans set } { } ifelse
                   3522:     /arg1 ans def
                   3523:   ] pop
                   3524:   popVariables
                   3525:   arg1
                   3526: } def
                   3527:
                   3528: /@@@.toVectors {
                   3529:   /arg1 set
                   3530:   [/in-@@@.toVectors /gg ] pushVariables
                   3531:   [
                   3532:     /gg arg1 def
                   3533:     gg isArray {
                   3534:       gg { $array$ data_conversion } map
                   3535:     } {
                   3536:       gg (array) data_conversion
                   3537:     }ifelse
                   3538:     /arg1 set
                   3539:    ] pop
                   3540:    popVariables
                   3541:    arg1
                   3542: } def
                   3543:
                   3544: /toVectors2 { toVectors } def
                   3545:
                   3546: /fromVectors { { fromVectors.aux } map } def
                   3547: /fromVectors.aux {
                   3548:   /arg1 set
                   3549:   [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
                   3550:   [(CurrentRingp)] pushEnv
                   3551:   [
                   3552:     /vv arg1 def
                   3553:     /mm vv length def
                   3554:     /ans (0). def
                   3555:     /ee (0). def
                   3556:     0 1 mm 1 sub {
                   3557:       /i set
                   3558:       vv i get (0). eq {
                   3559:       } {
                   3560:         [(CurrentRingp) vv i get (ring) dc] system_variable
                   3561:         [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
                   3562:         /fromVector.LLL  goto
                   3563:       } ifelse
                   3564:     } for
                   3565:     /fromVector.LLL
                   3566:     %% vv message
                   3567:     0 1 mm 1 sub {
                   3568:       /i set
                   3569:       vv i get (0). eq {
                   3570:       } {
                   3571:         /ans ans
                   3572:             << vv i get >> << ee i npower >> mul
                   3573:          add def
                   3574:       } ifelse
                   3575:       %% [i ans] message
                   3576:     } for
                   3577:     /arg1 ans def
                   3578:   ] pop
                   3579:   popEnv
                   3580:   popVariables
                   3581:   arg1
                   3582: } def
                   3583: [(fromVectors)
                   3584: [
                   3585: ([v1 v2 ...] fromVectors [s1 s2 ...])
                   3586: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
                   3587: (cf. toVectors. <<e_>> varaible is assumed to be the last )
                   3588: (    variable in x.  @@@.esymbol)
                   3589: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
                   3590: $ [(x).  (y).] /ff set  $
                   3591: $ [ff ff] fromVectors :: $
                   3592: ]] putUsages
                   3593:
                   3594: /getOrderMatrix {
                   3595:   /arg1 set
                   3596:   [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
                   3597:   [(CurrentRingp)] pushEnv
                   3598:   [
                   3599:     /obj arg1 def
                   3600:     obj isArray {
                   3601:       obj { getOrderMatrix } map /ans set
                   3602:       ans length 0 {
                   3603:          /ans null def
                   3604:       } {
                   3605:          /ans2 null def
                   3606:          0 1 ans length 1 sub {
                   3607:            /i set
                   3608:            ans i get tag 0 eq
                   3609:            {   }
                   3610:            { /ans2 ans i get def } ifelse
                   3611:          } for
                   3612:          /ans ans2 def
                   3613:       } ifelse
                   3614:       /getOrderMatrix.LLL goto
                   3615:     } {  } ifelse
                   3616:     obj tag 14 eq {
                   3617:       [(CurrentRingp) obj] system_variable
                   3618:       [(orderMatrix)] system_variable /ans set
                   3619:       /getOrderMatrix.LLL goto
                   3620:     } {  } ifelse
                   3621:     obj isPolynomial {
                   3622:       obj (0). eq
                   3623:       { /ans null def
                   3624:       } { obj getRing /rr set
                   3625:         [(CurrentRingp) rr] system_variable
                   3626:         [(orderMatrix)] system_variable /ans set
                   3627:       } ifelse
                   3628:       /getOrderMatrix.LLL goto
                   3629:     } { (getOrderMatrix: wrong argument.)  error } ifelse
                   3630:     /getOrderMatrix.LLL
                   3631:     /arg1 ans def
                   3632:   ] pop
                   3633:   popEnv
                   3634:   popVariables
                   3635:   arg1
                   3636: } def
                   3637:
                   3638:
                   3639: [(getOrderMatrix)
                   3640: [(obj getOrderMatrix m)
                   3641:  (array  m)
                   3642:  (getOrderMatrix obtains the order matrix from obj.)
                   3643:  (If obj is a polynomial, it returns the order matrix associated to)
                   3644:  (the polynomial.)
                   3645:  (If obj is an array, it returns an order matrix of an element.)
                   3646: ]] putUsages
                   3647:
                   3648: /nl {
                   3649:    10 $string$ data_conversion
                   3650: } def
                   3651: [(nl)
                   3652: [(nl is the newline character.)
                   3653:  $Example: [(You can break line) nl (here.)] cat message$
1.4       takayama 3654: ]] putUsages
                   3655:
                   3656: /to_int {
                   3657:   /arg1 set
                   3658:   [/to-int /ob /ans] pushVariables
                   3659:   [
                   3660:     /ob arg1 def
                   3661:     /ans ob def
                   3662:     ob isArray {
                   3663:       ob {to_int} map /ans set
                   3664:       /LLL.to_int goto
                   3665:     } {  } ifelse
                   3666:     ob isInteger {
                   3667:       ob (universalNumber) dc /ans set
                   3668:       /LLL.to_int goto
                   3669:     } {  } ifelse
                   3670:     /LLL.to_int
                   3671:     /arg1 ans def
                   3672:   ] pop
                   3673:   popVariables
                   3674:   arg1
                   3675: } def
                   3676: [(to_int)
                   3677: [(obj to_int obj2)
                   3678:  (All integers in obj are changed to universalNumber.)
                   3679:  (Example: /ff [1 2 [(hello) (0).]] def  ff { tag } map ::)
                   3680:  (         ff to_int { tag } map :: )
1.5       takayama 3681: ]] putUsages
                   3682:
1.33      takayama 3683: /to_int32 {
                   3684:   /arg1 set
                   3685:   [/to-int32 /ob /ans] pushVariables
                   3686:   [
                   3687:     /ob arg1 def
                   3688:     /ans ob def
                   3689:     ob isArray {
                   3690:       ob {to_int32} map /ans set
                   3691:       /LLL.to_int32 goto
                   3692:     } {  } ifelse
                   3693:     ob isUniversalNumber {
                   3694:       ob (integer) dc /ans set
                   3695:       /LLL.to_int32 goto
                   3696:     } {  } ifelse
                   3697:     /LLL.to_int32
                   3698:     /arg1 ans def
                   3699:   ] pop
                   3700:   popVariables
                   3701:   arg1
                   3702: } def
                   3703: [(to_int32)
                   3704: [(obj to_int32 obj2)
                   3705:  $All universalNumber in obj are changed to integer (int32).$
                   3706:  (Example: /ff [1 (2).. [(hello) (0).]] def  ff { tag } map ::)
                   3707:  (         ff to_int32 { tag } map :: )
                   3708:  (cf. to_int, to_univNum )
                   3709: ]] putUsages
                   3710:
1.5       takayama 3711: /define_ring_variables {
1.6       takayama 3712:   [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables
                   3713: %% You cannot use these names for names for polynomials.
1.5       takayama 3714:   [
1.6       takayama 3715:      /drv._v getVariableNames def
                   3716:      /drv._v0 drv._v def
                   3717:      drv._v { dup /drv._p set (/) 2 1 roll ( $) drv._p ($. def ) } map cat
                   3718:      /drv._v set
                   3719: %     drv._v message
                   3720:      [(parse) drv._v] extension
1.5       takayama 3721:   ] pop
                   3722:   popVariables
                   3723: } def
                   3724: [(define_ring_variables)
                   3725: [(It binds  a variable <<a>> in the current ring to the sm1 variable <<a>>.)
                   3726:  (For example, if x is a variable in the current ring, it defines the sm1)
                   3727:  (variable x by /x (x) def)
                   3728: ]] putUsages
                   3729:
                   3730: /boundp {
                   3731:   /arg1 set
                   3732:   [/a /ans] pushVariables
                   3733:   [
                   3734:     /a arg1 def
                   3735:     [(parse) [(/) a ( load tag 0 eq { /ans 0 def } )
                   3736:                     (               { /ans 1 def } ifelse )] cat ] extension
                   3737:     /arg1 ans def
                   3738:   ] pop
                   3739:   popVariables
                   3740:   arg1
                   3741: } def
                   3742: [(boundp)
                   3743:  [( a boundp b)
                   3744:   (string a, b is 0 or 1.)
                   3745:   (If the variable named << a >> is bounded to a value,)
                   3746:   (it returns 1 else it returns 0.)
                   3747:   $Example: (hoge) boundp ::$
1.1       maekawa  3748: ]] putUsages
1.10      takayama 3749: [(isSubstr)
                   3750:  [
                   3751:   (s1 s2 isSubstr pos)
                   3752:   (If s1 is a substring of s2, isSubstr returns the position in s2 from which)
                   3753:   (s1 is contained in s2.)
                   3754:   (If s1 is not a substring of s2, then isSubstr returns -1.)
                   3755:  ]
                   3756: ] putUsages
                   3757: /isSubstr {
                   3758:   /arg2 set /arg1 set
                   3759:   [/in-isSubstr /s1 /s2 /i1 /i2 /n1 /n2
                   3760:    /ans /flg
                   3761:   ]  pushVariables
                   3762:   [
                   3763:     /s1 arg1 def
                   3764:     /s2 arg2 def
                   3765:     s1 (array) dc /s1 set
                   3766:     s2 (array) dc /s2 set
                   3767:     /n1 s1 length def
                   3768:     /n2 s2 length def
                   3769:     /ans -1 def
                   3770:     0 1 n2 n1 sub {
                   3771:       /i2 set
                   3772:       /flg 1 def
                   3773:       0 1 n1 1 sub {
                   3774:         /i1 set
                   3775:         s1 i1 get s2 i2 i1 add get eq {
                   3776:         } {
                   3777:           /flg 0 def exit
                   3778:         } ifelse
                   3779:       } for
                   3780:       flg {
                   3781:         /ans i2 def
                   3782:         /isSubstr.L2 goto
                   3783:       } { /ans -1 def } ifelse
                   3784:     } for
                   3785:     /isSubstr.L2
                   3786:     /arg1 ans def
                   3787:   ] pop
                   3788:   popVariables
                   3789:   arg1
1.14      takayama 3790: } def
                   3791:
                   3792: [(execve)
                   3793:  [
                   3794:    (command execve)
                   3795:    ([arg0 arg1 arg2 ...] execve )
                   3796:    (It executes the command by the system call execve.)
                   3797:    (cf. system, forkExec)
                   3798:  ]
                   3799: ] putUsages
                   3800:
                   3801: /execve {
                   3802:   /execve.arg set
                   3803:   [(forkExec) execve.arg [ ] 1] extension
1.15      takayama 3804: } def
                   3805:
                   3806: [(beginEcart)
                   3807:  [
                   3808:    (beginEcart)
                   3809:    (Set the environments for the ecart division algorithm.)
                   3810:  ]
                   3811: ] putUsages
                   3812:
1.23      takayama 3813: /ecart.debug_reduction1 0 def
1.15      takayama 3814: /beginEcart {
                   3815:   (red@) (ecart) switch_function
                   3816:   [(Ecart) 1] system_variable
1.16      takayama 3817:   [(CheckHomogenization) 0] system_variable
                   3818:   [(ReduceLowerTerms) 0] system_variable
                   3819:   [(AutoReduce) 0] system_variable
1.17      takayama 3820:   [(EcartAutomaticHomogenization) 0] system_variable
1.23      takayama 3821:   ecart.debug_reduction1 {
                   3822:     (red@) (debug) switch_function
                   3823:   } {  } ifelse
1.15      takayama 3824: } def
                   3825:
                   3826: [(endEcart)
                   3827:  [
                   3828:    (endEcart)
                   3829:    (End of using the ecart division algorithm.)
                   3830:  ]
                   3831: ] putUsages
                   3832:
                   3833: /endEcart {
                   3834:   (red@) (standard) switch_function
                   3835:   [(Ecart) 0] system_variable
1.21      takayama 3836:   [(degreeShift) (reset)] homogenize pop
1.10      takayama 3837: } def
1.19      takayama 3838:
                   3839: /ord_ws_all {
                   3840:   /arg2 set /arg1 set
                   3841:   [(ord_ws_all) arg1 arg2] gbext
                   3842: } def
                   3843: [(ord_ws_all)
                   3844:  [
                   3845:    (fv wv ord_ws_all degree)
                   3846:    (  ord_ws_all returns the ord with respect to the weight vector wv.)
                   3847:    $Example: [(x,y) ring_of_differential_operators 0] define_ring  $
                   3848:    $        (Dx^2+x*Dx*Dy+2). [(Dx) 1 (Dy) 1] weightv ord_ws_all ::  $
                   3849:    (  )
                   3850:    (fv [wv shiftv] ord_ws_all degree)
                   3851:    (  ord_ws_all returns the ord with respect to the weight vector wv and)
                   3852:    (  the shift vector shiftv.)
                   3853:    $Example: [(x,y) ring_of_differential_operators 0] define_ring  $
                   3854:    $        [(Dx^2+x*Dx*Dy+2). (Dx).] [[(Dx) 1 (Dy) 1] weightv [0 2]] ord_ws_all ::$
                   3855:    (  )
                   3856:    (cf: init, gbext.   Obsolete: ord_w, ord_w_all)
                   3857:  ]
                   3858: ] putUsages
1.22      takayama 3859:
                   3860: [(newVector)
                   3861:  [( n newVector vec)
                   3862: ]] putUsages
                   3863: /newVector {
                   3864:   /arg1 set
                   3865:   [/in-newVector /n] pushVariables
                   3866:   [
                   3867:     /n arg1 def
                   3868:     [(newVector) n] extension /arg1 set
                   3869:   ] pop
                   3870:   popVariables
                   3871:   arg1
                   3872: } def
                   3873:
                   3874: [(newMatrix)
                   3875:  [( [m n] newMatrix mat)
                   3876: ]] putUsages
                   3877: /newMatrix {
                   3878:   /arg1 set
                   3879:   [/in-newMatrix /n] pushVariables
                   3880:   [
                   3881:     /n arg1 def
                   3882:     [(newMatrix) n 0 get n 1 get] extension /arg1 set
                   3883:   ] pop
                   3884:   popVariables
                   3885:   arg1
1.25      takayama 3886: } def
                   3887:
                   3888: /addStdoutStderr {
                   3889:   [(>) (stringOut://@@@stdout) (2>) (stringOut://@@@stderr)] join
1.27      takayama 3890: } def
                   3891:
1.37      takayama 3892: [(___)
1.27      takayama 3893: [(reparse a polynomial or polynomials)]
                   3894: ] putUsages
1.37      takayama 3895: /___ {
1.27      takayama 3896:   /arg1 set
                   3897:   [/in-reparse /ff] pushVariables
                   3898:   [
                   3899:     /ff arg1 def
                   3900:     ff tag 6 eq {
1.37      takayama 3901:       ff { ___ } map /arg1 set
1.27      takayama 3902:     } {
                   3903:       ff toString . /arg1 set
                   3904:     } ifelse
1.29      takayama 3905:   ] pop
                   3906:   popVariables
                   3907:   arg1
                   3908: } def
                   3909:
                   3910: /to_univNum {
                   3911:   /arg1 set
                   3912:   [/rr  ] pushVariables
                   3913:   [
                   3914:     /rr arg1 def
                   3915:     rr isArray {
                   3916:       rr { to_univNum } map /rr set
                   3917:     } {
                   3918:     } ifelse
                   3919:     rr isInteger {
                   3920:       rr (universalNumber) dc /rr set
                   3921:     } {
                   3922:     } ifelse
                   3923:     /arg1 rr def
                   3924:   ] pop
                   3925:   popVariables
                   3926:   arg1
                   3927: } def
                   3928: [(to_univNum)
                   3929: [(obj to_univNum obj2)
                   3930:  (Example. [ 2 (3).. ] to_univNum)
1.33      takayama 3931:  $cf. to_int32. (to_int)$
1.29      takayama 3932: ]] putUsages
                   3933:
                   3934: [(lcm)
                   3935:  [ ([a b c ...] lcm r)
                   3936:    (cf. polylcm, mpzext)
                   3937:  ]
                   3938: ] putUsages
                   3939: /lcm {
                   3940:   /arg1 set
                   3941:   [/aa /bb /rr /pp /i] pushVariables
                   3942:   [
                   3943:     /aa arg1 def
                   3944:     /rr (1).. def
                   3945:     /pp 0 def % isPolynomial array?
                   3946:     0 1 aa length 1 sub {
                   3947:       /i set
                   3948:       aa i get  isPolynomial {
                   3949:         /pp 1 def
                   3950:         exit
                   3951:       } {  } ifelse
                   3952:     } for
                   3953:
                   3954:     0 1 aa length 1 sub {
                   3955:       /i set
                   3956:       pp {
                   3957:         [rr aa i get] polylcm /rr set
                   3958:       } {
                   3959:         [(lcm) rr aa i get ] mpzext /rr set
                   3960:       } ifelse
                   3961:     } for
                   3962:
                   3963:     /arg1 rr def
                   3964:   ] pop
                   3965:   popVariables
                   3966:   arg1
                   3967: } def
                   3968: [(gcd)
                   3969:  [ ([a b c ...] gcd r)
                   3970:    (cf. polygcd, mpzext)
                   3971:  ]
                   3972: ] putUsages
                   3973: /gcd {
                   3974:   /arg1 set
                   3975:   [/aa /bb /rr /pp /i] pushVariables
                   3976:   [
                   3977:     /aa arg1 def
                   3978:     /rr (1).. def
                   3979:     /pp 0 def % isPolynomial array?
                   3980:     0 1 aa length 1 sub {
                   3981:       /i set
                   3982:       aa i get  isPolynomial {
                   3983:         /pp 1 def
                   3984:         /rr aa i get def
                   3985:         exit
                   3986:       } {  } ifelse
                   3987:     } for
                   3988:
                   3989:     pp {
                   3990:      0 1 aa length 1 sub {
                   3991:        /i set
                   3992:        [rr aa i get] polygcd /rr set
                   3993:      } for
                   3994:     } {
                   3995:       aa ngcd /rr set
                   3996:     } ifelse
                   3997:
                   3998:     /arg1 rr def
                   3999:   ] pop
                   4000:   popVariables
                   4001:   arg1
                   4002: } def
                   4003:
                   4004: [(denominator)
                   4005:  [ ([a b c ...] denominator r)
                   4006:    ( a denominator r )
                   4007:    (cf. dc, numerator)
1.30      takayama 4008:    (Output is Z or a polynomial.)
1.29      takayama 4009:  ]
                   4010: ] putUsages
                   4011: % test data.
                   4012: %  [(1).. (2).. div (1).. (3).. div ] denominator
                   4013: %  [(2).. (3).. (4).. ] denominator
                   4014: /denominator {
                   4015:   /arg1 set
                   4016:   [/pp /dd /ii /rr] pushVariables
                   4017:   [
                   4018:     /pp arg1 def
1.30      takayama 4019:     pp to_univNum /pp set
1.29      takayama 4020:     {
                   4021:       pp isArray {
                   4022:         pp { denominator } map /dd set
                   4023:         /rr dd lcm def % rr = lcm(dd[0], dd[1], ... )
                   4024:         rr /dd set
                   4025:         exit
                   4026:       } {  } ifelse
                   4027:
                   4028:       pp (denominator) dc /dd set
                   4029:       exit
                   4030:
                   4031:     } loop
                   4032:     /arg1 dd def
                   4033:   ] pop
                   4034:   popVariables
                   4035:   arg1
                   4036: } def
                   4037:
                   4038: [(numerator)
                   4039:  [ ([a b c ...] numerator r)
                   4040:    ( a numerator r )
                   4041:    (cf. dc, denominator)
1.30      takayama 4042:    (Output is a list of Z or polynomials.)
1.29      takayama 4043:  ]
                   4044: ] putUsages
                   4045: % test data.
                   4046: /numerator {
                   4047:   /arg1 set
                   4048:   [/pp /dd /ii /rr] pushVariables
                   4049:   [
                   4050:     /pp arg1 def
1.30      takayama 4051:     pp to_univNum /pp set
1.29      takayama 4052:     {
                   4053:       pp isArray {
                   4054:         pp denominator /dd set
                   4055:         pp dd mul /rr set
1.30      takayama 4056:         rr cancel /rr set
1.29      takayama 4057:         exit
                   4058:       } {  } ifelse
                   4059:
                   4060:       pp (numerator) dc /rr set
                   4061:       exit
                   4062:
                   4063:     } loop
                   4064:     /arg1 rr def
                   4065:   ] pop
                   4066:   popVariables
                   4067:   arg1
                   4068: } def
                   4069:
1.30      takayama 4070: /cancel.Q {
1.29      takayama 4071:   /arg1 set
                   4072:   [/aa /rr /nn /dd /gg]  pushVariables
                   4073:   [
                   4074:     /aa arg1 def
                   4075:     {
                   4076:       aa isRational {
                   4077:          [(cancel) aa] mpzext /rr set
                   4078:          rr (denominator) dc (1).. eq {
                   4079:             /rr rr (numerator) dc def
                   4080:             exit
                   4081:          } { } ifelse
                   4082:          rr (denominator) dc (-1).. eq {
                   4083:             /rr rr (numerator) dc (-1).. mul def
                   4084:          } { } ifelse
                   4085:          exit
                   4086:       } { } ifelse
                   4087:
                   4088:       /rr aa def
                   4089:       exit
                   4090:     } loop
                   4091:     /arg1 rr def
                   4092:   ] pop
                   4093:   popVariables
                   4094:   arg1
                   4095: } def
                   4096:
1.30      takayama 4097: /cancel.one {
1.29      takayama 4098:   /arg1 set
                   4099:   [/aa /rr /nn /dd /gg]  pushVariables
                   4100:   [
                   4101:     /aa arg1 def
                   4102:     {
                   4103:       aa isRational {
                   4104:         aa (numerator) dc /nn set
                   4105:         aa (denominator) dc /dd set
                   4106:         nn isUniversalNumber dd isUniversalNumber and {
1.30      takayama 4107:           /rr aa cancel.Q def
1.29      takayama 4108:           exit
1.30      takayama 4109:         } { (cancel: not implemented) error } ifelse
1.29      takayama 4110:       } { } ifelse
                   4111:
                   4112:       /rr aa def
                   4113:       exit
                   4114:     } loop
                   4115:     /arg1 rr def
                   4116:   ] pop
                   4117:   popVariables
                   4118:   arg1
                   4119: } def
                   4120:
1.30      takayama 4121: [(cancel)
                   4122:  [ (obj cancel r)
1.29      takayama 4123:    (Cancel numerators and denominators)
                   4124:    (The implementation has not yet been completed. It works only for Q.)
                   4125: ]] putUsages
1.30      takayama 4126: /cancel {
1.29      takayama 4127:   /arg1 set
                   4128:   [/aa /rr] pushVariables
                   4129:   [
                   4130:     /aa arg1 def
                   4131:     aa isArray {
1.30      takayama 4132:       aa {cancel} map /rr set
1.29      takayama 4133:     } {
1.30      takayama 4134:       aa cancel.one /rr set
1.29      takayama 4135:     } ifelse
                   4136:     /arg1 rr def
1.27      takayama 4137:   ] pop
                   4138:   popVariables
                   4139:   arg1
1.22      takayama 4140: } def
1.30      takayama 4141:
                   4142: /nnormalize_vec {
                   4143:   /arg1 set
                   4144:   [/pp /rr /dd ] pushVariables
                   4145:   [
                   4146:     /pp arg1 def
                   4147:     pp denominator /dd set
                   4148:     dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
                   4149:     pp numerator dd mul cancel /pp set
                   4150:     /@@@.nnormalize_vec_c dd def
                   4151:     pp gcd /dd set
                   4152:     dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
                   4153:     pp (1).. dd div mul cancel /rr set
                   4154:     @@@.nnormalize_vec_c dd div cancel /@@@.nnormalize_vec_c set
                   4155:     /arg1 rr def
                   4156:   ] pop
                   4157:   popVariables
                   4158:   arg1
                   4159: } def
                   4160: [(nnormalize_vec)
                   4161: [(pp nnormalize_vec npp)
                   4162:  (It normalizes a given vector of Q into a vector of Z with relatively prime)
                   4163:  (entries by multiplying a postive number.)
                   4164: ]] putUsages
1.31      takayama 4165:
                   4166: /getNode {
                   4167:   /arg2 set
                   4168:   /arg1 set
1.43      takayama 4169:   [/in-getNode /ob /key /rr /tt /ii] pushVariables
1.31      takayama 4170:   [
                   4171:     /ob arg1 def
                   4172:     /key arg2 def
                   4173:     /rr null def
                   4174:     {
1.43      takayama 4175:       ob isArray {
                   4176:         ob length 1 gt {
                   4177:           ob 0 get isString {
                   4178:             ob 0 get , key eq {
                   4179:               /rr ob 1 get def exit
                   4180:             } {  } ifelse
                   4181:           } { } ifelse
                   4182:         }{ } ifelse
                   4183:         ob { key getNode , dup tag 0 eq {pop} { } ifelse }  map /tt set
                   4184:         tt length 0 gt { /rr tt 0 get def exit }
                   4185:         {/rr null def exit } ifelse
                   4186:       } { } ifelse
                   4187:
1.31      takayama 4188:       ob isClass {
                   4189:         ob (array) dc /ob set
1.43      takayama 4190:       } { } ifelse
                   4191:       ob isClass , ob isArray or { } { exit } ifelse
1.31      takayama 4192:       ob 0 get key eq {
                   4193:         /rr ob def
                   4194:         exit
                   4195:       } {  } ifelse
                   4196:       ob 2 get /ob set
                   4197:       0 1 ob length 1 sub {
                   4198:          /ii set
                   4199:          ob ii get key getNode /rr set
                   4200:          rr tag 0 eq { } { exit } ifelse
                   4201:       } for
                   4202:       exit
                   4203:     } loop
                   4204:     /arg1 rr def
                   4205:   ] pop
                   4206:   popVariables
                   4207:   arg1
                   4208: } def
                   4209: [(getNode)
1.43      takayama 4210: [(ob key getNode node-value)
                   4211:  (ob is a class object or an array.)
1.31      takayama 4212:  (The operator getNode returns the node with the key in ob.)
1.43      takayama 4213:  (When ob is a class, the node is an array of the format [key attr-list node-list])
                   4214:  (When ob is an array, the node is a value of key-value pairs.)
1.31      takayama 4215:  (Example:)
                   4216:  (  /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
                   4217:  (  /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
                   4218:  (  /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
                   4219:  (  ma (dog) getNode )
1.43      takayama 4220:  (Example 2:)
                   4221:  ( [ [1 ] [2 3] [[(dog) 2]]] (dog) getNode ::)
1.31      takayama 4222: ]] putUsages
                   4223:
1.36      takayama 4224: /cons {
                   4225:   /arg2 set /arg1 set
                   4226:   [/aa /bb] pushVariables
                   4227:   [
                   4228:     /aa arg1 def /bb arg2 def
                   4229:     [aa] (list) dc bb join /arg1 set
                   4230:   ] pop
                   4231:   popVariables
                   4232:   arg1
                   4233: } def
                   4234: [(cons)
                   4235: [(obj list cons list)
                   4236: ]] putUsages
1.38      takayama 4237: /arrayToList {
                   4238:   /arg1 set
                   4239:   [/a /r] pushVariables
                   4240:   [
                   4241:     /a arg1 def
                   4242:     {
                   4243:       a isArray {
                   4244:        a { arrayToList } map /a set
                   4245:        a (list) dc  /r set
                   4246:        exit
                   4247:       } {  } ifelse
                   4248:       /r a def
                   4249:       exit
                   4250:     } loop
                   4251:     /arg1 r def
                   4252:   ] pop
                   4253:   popVariables
                   4254:   arg1
                   4255: } def
                   4256: [(arrayToList)
                   4257: [(a arrayToList list)
                   4258: ]] putUsages
                   4259:
                   4260: /listToArray {
                   4261:   /arg1 set
                   4262:   [/a /r] pushVariables
                   4263:   [
                   4264:     /a arg1 def
                   4265:     {
                   4266:       a tag 12 eq {
                   4267:        a (array) dc  /a set
                   4268:        a { listToArray } map /r set
                   4269:        exit
                   4270:       } {  } ifelse
                   4271:       a tag 0 eq {
                   4272:        /r [ ] def
                   4273:        exit
                   4274:       } {  } ifelse
                   4275:       /r a def
                   4276:       exit
                   4277:     } loop
                   4278:     /arg1 r def
                   4279:   ] pop
                   4280:   popVariables
                   4281:   arg1
                   4282: } def
                   4283: [(listToArray)
                   4284: [(list listToArray a)
                   4285: ]] putUsages
                   4286:
1.44      takayama 4287: % Body is moved to smacro.sm1
1.39      takayama 4288: [(makeInfix)
                   4289: [(literal makeInfix)
                   4290:  (Change literal to an infix operator.)
                   4291:  (Example: /+ { add } def )
                   4292:  (  /+ makeInfix)
                   4293:  (  /s 0 def 1 1 100 { /i set s + i /s set } for s message)
                   4294:  (  [ 1 2 3 ] { /i set i + 2 } map ::)
                   4295: ]] putUsages
1.22      takayama 4296:
1.24      takayama 4297: /usages {
                   4298:   /arg1 set
1.40      takayama 4299:   [/name /flag /n /k /slist /m /i /sss /key /ukeys] pushVariables
1.24      takayama 4300:   [
                   4301:     /name arg1 def
                   4302:     /flag true def
1.40      takayama 4303:     {  % begin loop
                   4304:
                   4305:        name isArray {
1.41      takayama 4306:          /ukeys @.usages { 0 get } map shell def
1.40      takayama 4307:          name { /key set [(regexec) key ukeys] extension
                   4308:                 { 0 get } map } map /sss set
                   4309:          exit
                   4310:        } {  } ifelse
1.24      takayama 4311:
                   4312:  name tag 1 eq {
                   4313:    @.usages { 0 get } map shell { (, ) nl } map /sss set
1.40      takayama 4314:    exit
1.24      takayama 4315:  } {
                   4316:
                   4317:     /sss [ ] def
                   4318:    @.usages length /n set
                   4319:    0 1 << n 1 sub >>
                   4320:    {
                   4321:       /k set
                   4322:       name << @.usages k get 0 get >> eq
                   4323:       {
                   4324:         /slist @.usages k get 1 get def
                   4325:         /m slist length def
                   4326:         0 1 << m 1 sub >> {
                   4327:           /i set
                   4328:           sss slist i get append nl append /sss set
                   4329:         } for
                   4330:         /flag false def
                   4331:       }
                   4332:       { }
                   4333:       ifelse
                   4334:    } for
                   4335:
                   4336:    %BUG:  cannot get usages of primitives.
                   4337:    flag
                   4338:    {name Usage  /sss [(Usage of ) name ( could not obtained.) nl ] def}
                   4339:    { }
                   4340:    ifelse
1.40      takayama 4341:    exit
1.24      takayama 4342:  } ifelse
1.40      takayama 4343:
                   4344: } loop
1.24      takayama 4345:    /arg1 sss cat def
                   4346:    ] pop
                   4347:    popVariables
                   4348:    arg1
                   4349: } def
                   4350: [(usages)
                   4351:  [(key usages usages-as-a-string)
                   4352:   (num usages list-of-key-words)
1.40      takayama 4353:   ([key1 key2 ... ] usages list-of-key-words  : it accepts regular expressions.)
1.42      takayama 4354: ]] putUsages
                   4355:
                   4356: /setMinus {
                   4357:   /arg2 set /arg1 set
                   4358:   [/aa /bb /i ] pushVariables
                   4359:   [
                   4360:     /aa arg1 def /bb arg2 def
                   4361:     [
                   4362:       0 1 aa length 1 sub {
                   4363:         /i set
                   4364:         aa i get bb memberQ {
                   4365:         } { aa i get } ifelse
                   4366:       } for
                   4367:     ] /arg1 set
                   4368:   ] pop
                   4369:   popVariables
                   4370:   arg1
                   4371: } def
                   4372: [(setMinus)
                   4373: [(a b setMinus c)
1.24      takayama 4374: ]] putUsages
1.45      takayama 4375:
                   4376: % Define  some infix operators
                   4377: /~add~ { add } def /~add~ makeInfix
                   4378: /~sub~ { sub } def /~sub~ makeInfix
                   4379: /~mul~ { mul } def /~mul~ makeInfix
                   4380: /~div~ { div } def /~div~ makeInfix
                   4381: /~power~ { power } def /~power~ makeInfix
                   4382: /~put~ {
                   4383:   dup tag 3 eq { exec } {  } ifelse  put
                   4384: } def
                   4385: /~put~ makeInfix
                   4386:
1.48      takayama 4387: /toTokensBySpace {
                   4388:   /arg1 set
                   4389:   [(cgiToTokens) arg1 [ ]] extension
                   4390: } def
                   4391: [(toTokensBySpace)
                   4392: [
                   4393:  ( string toTokensBySpace token_array )
1.49      takayama 4394: ]] putUsages
                   4395:
                   4396: /setAttributeList {
                   4397:   /arg2 set
                   4398:   /arg1 set
                   4399:   [
                   4400:     [(setAttributeList) arg1 arg2] extension /arg1 set
                   4401:   ] pop
                   4402:   arg1
                   4403: } def
                   4404: /getAttributeList {
                   4405:   /arg1 set
                   4406:   [(getAttributeList) arg1] extension
                   4407: } def
                   4408: /setAttribute {
                   4409:   /arg3 set
                   4410:   /arg2 set
                   4411:   /arg1 set
                   4412:   [
                   4413:     [(setAttribute) arg1 arg2 arg3] extension /arg1 set
                   4414:   ] pop
                   4415:   arg1
                   4416: } def
                   4417: /getAttribute {
                   4418:   /arg2 set
                   4419:   /arg1 set
                   4420:   [(getAttribute) arg1 arg2] extension
                   4421: } def
                   4422: [(setAttributeList)
                   4423: [
                   4424:  (ob attr setAttributeList new-obj )
                   4425:  (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set )
                   4426: ]] putUsages
                   4427: [(setAttribute)
                   4428: [
                   4429:  (ob key value setAttribute new-obj )
                   4430:  (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set )
                   4431: ]] putUsages
                   4432: [(getAttributeList)
                   4433: [
                   4434:  (ob getAttributeList attr-obj )
                   4435:  (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set )
                   4436:  (         ff getAttributeList :: )
                   4437: ]] putUsages
                   4438: [(getAttribute)
                   4439: [
                   4440:  (ob key getAttribute value )
                   4441:  (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set )
                   4442:  (         ff (gb) getAttribute :: )
1.48      takayama 4443: ]] putUsages
1.50      takayama 4444:
                   4445: % [(gbCheck) 1 (needSyz) 1 (countDown) 100]  (attribute format)
                   4446: % --> [(gbCheck) (needSyz) (countDown) 100]  (groebner option format)
                   4447: % cf. gb
                   4448: /configureGroebnerOption {
                   4449:   /arg1 set
                   4450:   [/opt /i] pushVariables
                   4451:   [
                   4452:     /opt arg1 def
                   4453:     opt tag 0 eq {
                   4454:      /arg1 null def
                   4455:     } {
                   4456:      [
                   4457:       0 2 opt length 1 sub {
                   4458:         /i set
                   4459:         opt i get
                   4460:         opt i get (countDown) eq {
                   4461:            opt i 1 add get
                   4462:         } { } ifelse
                   4463:         opt i get (stopDegree) eq {
                   4464:            opt i 1 add get
                   4465:         } { } ifelse
                   4466:       } for
                   4467:      ] /arg1 set
                   4468:     } ifelse
                   4469:   ] pop
                   4470:   popVariables
                   4471:   arg1
                   4472: } def
1.52      takayama 4473:
                   4474: [(getFileType)
                   4475: [
                   4476:  (string getFileType type)
                   4477:  $Example: (/www/prog/cohom.sm1) getFileType ==> (sm1)$
                   4478: ]] putUsages
                   4479: /getFileType {
                   4480:   /arg1 set
                   4481:   [/ss ] pushVariables
                   4482:   [ /ss arg1 def
                   4483:     [(stringToArgv2) ss (.)] extension /ss set
                   4484:     ss, ss length 1 sub, get /arg1 set
                   4485:   ] pop
                   4486:   popVariables
                   4487:   arg1
                   4488: } def
                   4489:
1.53      takayama 4490: % Default initial value.
                   4491: /localizedString.file null def
                   4492: /localizedString.dic [ ] def
                   4493: /localizedString.local { } def
                   4494:
                   4495: % Clear and load
                   4496: /localizedString.load {
                   4497:   /localizedString.dic [ ] def
                   4498:   /localizedString.local { } def
                   4499:   localizedString.file tag 0 eq { }
                   4500:   { [(parse) localizedString.file pushfile] extension pop  } ifelse
                   4501: } def
                   4502:
                   4503:
                   4504: [(localizedString)
                   4505:  [
                   4506:   (string localizedString translatedString)
                   4507:   (It returns localizedString if localizedString.dic [array] and)
                   4508:   (localizedString.local [function] are set.)
                   4509:  ]
                   4510: ] putUsages
                   4511: /localizedString {
                   4512:   /arg1 set
                   4513:   [/ss /ans /tt] pushVariables
                   4514:   [
                   4515:     arg1 /ss set
                   4516:     /ans ss def
                   4517:     {
                   4518:       localizedString.dic length 0  eq { exit } { } ifelse
                   4519:       localizedString.dic ss getNode /tt set
                   4520:       tt tag 0 eq {  } { tt /ans set exit } ifelse
                   4521:       ss localizedString.local /ans set
                   4522:       exit
                   4523:     } loop
                   4524:     ans /arg1 set
                   4525:   ] pop
                   4526:   popVariables
                   4527:   arg1
                   4528: } def
1.50      takayama 4529:
1.54    ! takayama 4530: [(univ2poly)
        !          4531: [(list univ2poly list2)
        !          4532:  (Change universal numbers in list to an element of a ring of polynomials)
        !          4533:  (defined by other elements in list. If there is no polynomial element,)
        !          4534:  (the current ring is used.)
        !          4535: ]] putUsages
        !          4536: /univ2poly {
        !          4537:   /arg1 set
        !          4538:   [/aa /rg /ag /ans] pushVariables
        !          4539:   [
        !          4540:     arg1 /aa set
        !          4541:     [(CurrentRingp)] system_variable /rg set
        !          4542:     aa getRing /ag set
        !          4543:     ag tag 0 { } {
        !          4544:       ag ring_def
        !          4545:     } ifelse
        !          4546:     aa univ2poly.aux /ans set
        !          4547:     rg ring_def
        !          4548:     ans /arg1 set
        !          4549:   ] pop
        !          4550:   popVariables
        !          4551:   arg1
        !          4552: } def
        !          4553:
        !          4554: /univ2poly.aux {
        !          4555:   /arg1 set
        !          4556:   [/aa /ans] pushVariables
        !          4557:   [
        !          4558:     arg1 /aa set
        !          4559:     aa getRing
        !          4560:     aa tag 6 eq {
        !          4561:       aa { univ2poly.aux} map /ans set
        !          4562:     }{
        !          4563:       aa tag 15 eq, aa tag 1 eq, or { aa toString . /ans set } {
        !          4564:         aa /ans set
        !          4565:       } ifelse
        !          4566:     } ifelse
        !          4567:     ans /arg1 set
        !          4568:   ] pop
        !          4569:   popVariables
        !          4570:   arg1
        !          4571: } def
1.1       maekawa  4572: ;
                   4573:
                   4574:
                   4575:
                   4576:
                   4577:
                   4578:

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