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

Annotation of OpenXM/src/kan96xx/Doc/hol.sm1, Revision 1.29

1.29    ! takayama    1: % $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.28 2012/10/12 01:20:29 takayama Exp $
1.5       takayama    2: %% hol.sm1, 1998, 11/8, 11/10, 11/14, 11/25, 1999, 5/18, 6/5. 2000, 6/8
1.1       maekawa     3: %% rank, rrank, characteristic
                      4: %% This file is error clean.
                      5: /hol.version (2.990515) def
                      6: hol.version [(Version)] system_variable gt
                      7: { [(This package hol.sm1 requires the latest version of kan/sm1) nl
                      8:    (Please get it from http://www.math.kobe-u.ac.jp/KAN)
                      9:   ] cat
                     10:   error
                     11: } { } ifelse
                     12:
1.5       takayama   13: $hol.sm1, basic package for holonomic systems (C) N.Takayama, 2000, 06/08 $
1.1       maekawa    14: message-quiet
                     15:
1.7       takayama   16: /gb.warning 0 def
1.18      takayama   17: /gb.oxRingStructure [[ ] [ ]] def
1.1       maekawa    18: /rank.v [(x) (y) (z)] def   %% default value of v (variables).
                     19: /rank.ch [ ] def  %% characteristic variety.
                     20: /rank.verbose 0 def
                     21: /rank {
                     22:   /arg1 set
                     23:   [/in-rank /aa /typev /setarg /f /v /vsss /vddd
                     24:    /gg /wv /vd /vdweight /chv
                     25:    /one
                     26:   ] pushVariables
                     27:   [(CurrentRingp) (KanGBmessage)] pushEnv
                     28:   [
                     29:
                     30:     /aa arg1 def
                     31:     aa isArray { } { ( << array >> rank) error } ifelse
                     32:     /setarg 0 def
                     33:     aa { tag } map /typev set
                     34:     typev [ ArrayP ] eq
                     35:     {  /f aa 0 get def
                     36:        /v rank.v def
                     37:        /setarg 1 def
                     38:     } { } ifelse
                     39:     typev [ArrayP StringP] eq
                     40:     {  /f aa 0 get def
                     41:        /v [ aa 1 get to_records pop ] def
                     42:        /setarg 1 def
                     43:     } { } ifelse
                     44:     typev [ArrayP ArrayP] eq
                     45:     {  /f aa 0 get def
                     46:        /v aa 1 get def
                     47:        /setarg 1 def
                     48:     } { } ifelse
                     49:     setarg { } { (rank : Argument mismatch) error } ifelse
                     50:
                     51:     [(KanGBmessage) rank.verbose ] system_variable
                     52:
                     53:     f { toString } map /f set
                     54:     v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
                     55:     /vddd set   %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
                     56:     v { @@@.Dsymbol 2 1 roll 2 cat_n } map
                     57:     /vd set     %% vd = [(Dx) (Dy) (Dz)]
                     58:     /vdweight
                     59:        vd { [ 2 1 roll -1 ] } map  %% vdweight=[[(Dx) -1] [(Dy) -1] [(Dz) -1]]
                     60:     def
                     61:
                     62:     [v from_records
                     63:      ring_of_differential_operators [vddd] weight_vector 0] define_ring
                     64:     f { . dehomogenize } map /f set
                     65:     [f] groebner_sugar 0 get /gg set
                     66:
                     67:     /wv vddd weightv def
                     68:     gg { wv init } map /chv set  %%obtained the characteristic variety.
                     69:     /rank.ch chv def
                     70:     chv { toString } map /chv set
                     71:
                     72:     [ v vd join from_records
                     73:       ring_of_polynomials
                     74:       [vddd]  vdweight join weight_vector
                     75:       0
                     76:     ] define_ring
                     77:     [chv {.} map] groebner_sugar 0 get { init } map /chii set
                     78:
                     79:     /rank.chii chii def
                     80:     rank.verbose { chii message } {  } ifelse
                     81:     v {[ 2 1 roll . (1).]} map /one set
                     82:     %% [[(x). (1).] [(y). (1).] [(z). (1).]]
                     83:     %% chii { one replace } map  %% buggy code.
                     84:     %% Arg of hilb should be a reduced GB.
                     85:     [chii { one replace } map] groebner 0 get
                     86:     vd hilb /arg1 set
                     87:   ] pop
                     88:   popEnv
                     89:   popVariables
                     90:   arg1
                     91: } def
                     92:
                     93:
                     94: [(rank)
                     95:  [( a rank b)
                     96:   ( array a;  number b)
                     97:   (Example 1 : )
                     98:   $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rank :: $
                     99:   (Example 2 : )
                    100:   $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] rank :: $
                    101:  ]
                    102: ] putUsages
                    103: (rank ) messagen-quiet
                    104:
                    105: /characteristic.verbose 0 def
                    106: /characteristic.v [(x) (y) (z)] def
                    107: /characteristic.ch [ ] def
                    108: /ch { characteristic } def
                    109: /characteristic {
                    110:   /arg1 set
                    111:   [/in-rank /aa /typev /setarg /f /v /vsss /vddd
                    112:    /gg /wv /vd  /chv
                    113:    /one
                    114:   ] pushVariables
                    115:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    116:   [
                    117:
                    118:     /aa arg1 def
                    119:     aa isArray { } { ( << array >> characteristic) error } ifelse
                    120:     /setarg 0 def
                    121:     aa { tag } map /typev set
                    122:     typev [ ArrayP ] eq
                    123:     {  /f aa 0 get def
                    124:        /v characteristic.v def
                    125:        /setarg 1 def
                    126:     } { } ifelse
                    127:     typev [ArrayP StringP] eq
                    128:     {  /f aa 0 get def
                    129:        /v [ aa 1 get to_records pop ] def
                    130:        /setarg 1 def
                    131:     } { } ifelse
                    132:     typev [ArrayP ArrayP] eq
                    133:     {  /f aa 0 get def
                    134:        /v aa 1 get def
                    135:        /setarg 1 def
                    136:     } { } ifelse
                    137:     setarg { } { (rank : Argument mismatch) error } ifelse
                    138:
                    139:     [(KanGBmessage) characteristic.verbose ] system_variable
                    140:
                    141:     f { toString } map /f set
                    142:     v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
                    143:     /vddd set   %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
                    144:     v { @@@.Dsymbol 2 1 roll 2 cat_n } map
                    145:     /vd set     %% vd = [(Dx) (Dy) (Dz)]
                    146:
                    147:     [v from_records
                    148:      ring_of_differential_operators [vddd] weight_vector 0] define_ring
                    149:     f { . dehomogenize } map /f set
                    150:     [f] groebner_sugar 0 get /gg set
                    151:
                    152:     /wv vddd weightv def
                    153:     gg { wv init } map /chv set
                    154:     /characteristic.ch [chv] def
                    155: %%    gg { wv init toString} map /chv set  %%obtained the characteristic variety.
                    156: %%    /characteristic.ch chv def
                    157:
                    158: %%    [ v vd join from_records
                    159: %%      ring_of_polynomials
                    160: %%      [vddd] weight_vector
                    161: %%      0
                    162: %%    ] define_ring
                    163: %%    [chv {.} map] groebner_sugar 0 get /characteristic.ch set
                    164:
                    165:     characteristic.ch /arg1 set
                    166:   ] pop
                    167:   popEnv
                    168:   popVariables
                    169:   arg1
                    170: } def
                    171:
                    172: [(characteristic)
                    173:  [( a characteristic b)
                    174:   ( array a;  number b)
                    175:   (b is the generator of the characteristic variety of a.)
                    176:   (For the algorithm, see Japan J. of Industrial and Applied Math., 1994, 485--497.)
                    177:   (Example 1 : )
                    178:   $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] characteristic :: $
                    179:   (Example 2 : )
                    180:   $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] characteristic :: $
                    181:  ]
                    182: ] putUsages
                    183: (characteristic ) messagen-quiet
                    184: [(ch)
                    185:  [(ch is the abbreviation of characteristic.)
                    186:   ( a ch b)
                    187:   ( array a;  number b)
                    188:   (b is the generator of the characteristic variety of a.)
                    189:   (For the algorithm, see, Japan J. of Industrial and Applied Math., 1994, 485--497.)
                    190:   (Example 1 : )
                    191:   $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] ch :: $
                    192:   (Example 2 : )
                    193:   $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] ch :: $
                    194:  ]
                    195: ] putUsages
                    196: (ch ) messagen-quiet
                    197:
                    198: %%%% developing rrank.sm1
                    199: /rrank.v [(x) (y) (z)] def   %% default value of v (variables).
                    200: /rrank.init [ ] def  %% initial ideal.
                    201: /rrank.verbose 0 def
                    202: /rrank {
                    203:   /arg1 set
                    204:   [/in-rrank /aa /typev /setarg /f /v /vsss /vddd
                    205:    /gg /wv /vd /vdweight
                    206:    /one /i /chv
                    207:   ] pushVariables
                    208:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    209:   [
                    210:
                    211:     /aa arg1 def
                    212:     aa isArray { } { ( << array >> rrank) error } ifelse
                    213:     /setarg 0 def
                    214:     aa { tag } map /typev set
                    215:     typev [ ArrayP ] eq
                    216:     {  /f aa 0 get def
                    217:        /v rrank.v def
                    218:        /setarg 1 def
                    219:     } { } ifelse
                    220:     typev [ArrayP StringP] eq
                    221:     {  /f aa 0 get def
                    222:        /v [ aa 1 get to_records pop ] def
                    223:        /setarg 1 def
                    224:     } { } ifelse
                    225:     typev [ArrayP ArrayP] eq
                    226:     {  /f aa 0 get def
                    227:        /v aa 1 get def
                    228:        /setarg 1 def
                    229:     } { } ifelse
                    230:     setarg { } { (rrank : Argument mismatch) error } ifelse
                    231:
                    232:     [(KanGBmessage) rrank.verbose ] system_variable
                    233:
                    234:     f { toString } map /f set
                    235:     v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
                    236:
                    237:     v { @@@.Dsymbol 2 1 roll 2 cat_n } map
                    238:     /vd set     %% vd = [(Dx) (Dy) (Dz)] , v = [(x) (y) (z)]
                    239:     /vdweight
                    240:       [ 0 1 v length 1 sub { /i set v i get << 0 i sub >>
                    241:                                     vd i get << i >> } for ]
                    242:     def
                    243:     rrank.verbose { vdweight message } { } ifelse
                    244:
                    245:     [v from_records
                    246:      ring_of_differential_operators [vdweight] weight_vector 0] define_ring
                    247:     f { . dehomogenize homogenize } map /f set
                    248:     [f] groebner 0 get {dehomogenize} map /gg set
                    249:
                    250:     /wv vdweight weightv def
                    251:     gg { wv init } map /rrank.init set  %%obtained the initial ideal
                    252:     rrank.init {toString} map /chv set
                    253:     /arg1 [chv v] rank def
                    254:   ] pop
                    255:   popEnv
                    256:   popVariables
                    257:   arg1
                    258: } def
                    259:
                    260:
                    261: [(rrank)
                    262:  [( a rrank b)
                    263:   ( array a;  number b)
                    264:   (It computes the holonomic rank for regular holonomic system.)
                    265:   (For the algorithm, see Grobner deformations of hypergeometric differential equations, 1999, Springer.)
                    266:   (Chapter 2.)
                    267:   (Example 1 : )
                    268:   $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rrank :: $
                    269:  ]
                    270: ] putUsages
                    271: (rrank ) messagen-quiet
                    272:
1.23      takayama  273:
                    274: % Take the value of arg1 in prior.
                    275: /mergeGroebnerOptions {
                    276:   /arg2 set
                    277:   /arg1 set
                    278:   [/loc /glo /ans] pushVariables
                    279:   [
                    280:     /loc arg1 def
                    281:     /glo arg2 def
                    282:     /ans [ ] def
                    283:     {
                    284:       loc tag 0 eq { /ans glo def exit } { } ifelse
                    285:       /ans glo loc join def
                    286:       exit
                    287:     } loop
                    288:     /arg1 ans def
                    289:   ] pop
                    290:   popVariables
                    291:   arg1
                    292: } def
                    293:
1.1       maekawa   294: /gb.v 1 def
                    295: /gb.verbose 0 def
1.4       takayama  296: /gb.options [ ] def
1.13      takayama  297: /gb.characteristic 0 def
1.14      takayama  298: /gb.homogenized 0 def
                    299: /gb.autoHomogenize 1 def
1.1       maekawa   300: /gb {
                    301:   /arg1 set
                    302:   [/in-gb /aa /typev /setarg /f /v
                    303:    /gg /wv /termorder /vec /ans /rr /mm
1.23      takayama  304:    /degreeShift  /env2 /groebnerOptions
1.29    ! takayama  305:    /ggall
1.1       maekawa   306:   ] pushVariables
                    307:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    308:   [
                    309:
                    310:     /aa arg1 def
                    311:     aa isArray { } { ( << array >> gb) error } ifelse
1.23      takayama  312:     aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1       maekawa   313:     /setarg 0 def
                    314:     /wv 0 def
1.11      takayama  315:     /degreeShift 0 def
1.1       maekawa   316:     aa { tag } map /typev set
                    317:     typev [ ArrayP ] eq
                    318:     {  /f aa 0 get def
                    319:        /v gb.v def
                    320:        /setarg 1 def
                    321:     } { } ifelse
                    322:     typev [ArrayP StringP] eq
                    323:     {  /f aa 0 get def
                    324:        /v aa 1 get def
                    325:        /setarg 1 def
                    326:     } { } ifelse
1.10      takayama  327:     typev [ArrayP RingP] eq
                    328:     {  /f aa 0 get def
                    329:        /v aa 1 get def
                    330:        /setarg 1 def
                    331:     } { } ifelse
1.1       maekawa   332:     typev [ArrayP ArrayP] eq
                    333:     {  /f aa 0 get def
                    334:        /v aa 1 get from_records def
                    335:        /setarg 1 def
                    336:     } { } ifelse
                    337:     typev [ArrayP StringP ArrayP] eq
                    338:     {  /f aa 0 get def
                    339:        /v aa 1 get def
                    340:        /wv aa 2 get def
                    341:        /setarg 1 def
                    342:     } { } ifelse
                    343:     typev [ArrayP ArrayP ArrayP] eq
                    344:     {  /f aa 0 get def
                    345:        /v aa 1 get from_records def
                    346:        /wv aa 2 get def
                    347:        /setarg 1 def
                    348:     } { } ifelse
1.11      takayama  349:     typev [ArrayP StringP ArrayP ArrayP] eq
                    350:     {  /f aa 0 get def
                    351:        /v aa 1 get def
                    352:        /wv aa 2 get def
                    353:        /degreeShift aa 3 get def
                    354:        /setarg 1 def
                    355:     } { } ifelse
                    356:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    357:     {  /f aa 0 get def
                    358:        /v aa 1 get from_records def
                    359:        /wv aa 2 get def
                    360:        /degreeShift aa 3 get def
                    361:        /setarg 1 def
                    362:     } { } ifelse
1.1       maekawa   363:
1.12      takayama  364:     /env1 getOptions def
                    365:
1.1       maekawa   366:     setarg { } { (gb : Argument mismatch) error } ifelse
                    367:
                    368:     [(KanGBmessage) gb.verbose ] system_variable
                    369:
                    370:     %%% Start of the preprocess
1.10      takayama  371:     v tag RingP eq {
                    372:        /rr v def
                    373:     }{
                    374:       f getRing /rr set
                    375:     } ifelse
1.1       maekawa   376:     %% To the normal form : matrix expression.
                    377:     f gb.toMatrixOfString /f set
                    378:     /mm gb.itWasMatrix def
                    379:
1.14      takayama  380:     rr tag 0 eq
                    381:     v isInteger not
                    382:     or {
1.1       maekawa   383:       %% Define our own ring
                    384:       v isInteger {
                    385:         (Error in gb: Specify variables) error
                    386:       } {  } ifelse
                    387:       wv isInteger {
                    388:         [v ring_of_differential_operators
1.13      takayama  389:         gb.characteristic] define_ring
1.1       maekawa   390:         /termorder 1 def
                    391:       }{
1.11      takayama  392:        degreeShift isInteger {
                    393:          [v ring_of_differential_operators
                    394:           wv weight_vector
1.13      takayama  395:          gb.characteristic] define_ring
1.11      takayama  396:          wv gb.isTermOrder /termorder set
                    397:        }{
                    398:          [v ring_of_differential_operators
                    399:           wv weight_vector
1.13      takayama  400:           gb.characteristic
1.11      takayama  401:           [(degreeShift) degreeShift]
                    402:           ] define_ring
                    403:          wv gb.isTermOrder /termorder set
                    404:        } ifelse
1.1       maekawa   405:       } ifelse
                    406:     } {
                    407:       %% Use the ring structre given by the input.
                    408:       rr ring_def
                    409:       /wv rr gb.getWeight def
                    410:       wv gb.isTermOrder /termorder set
                    411:     } ifelse
                    412:     %%% Enf of the preprocess
                    413:
1.14      takayama  414:     termorder {
                    415:       /gb.homogenized 0 def
                    416:     }{
                    417:      /gb.homogenized 1 def
                    418:     } ifelse
1.23      takayama  419:     groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
                    420:     gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1       maekawa   421:     termorder {
1.22      takayama  422:       f { {___ dehomogenize} map } map /f set
1.29    ! takayama  423:       [f groebnerOptions] groebner_sugar /ggall set ggall 0 get /gg set
1.1       maekawa   424:     }{
1.22      takayama  425:       f { {___ dehomogenize} map} map /f set
1.14      takayama  426:       gb.autoHomogenize {
                    427:         f fromVectors { homogenize } map /f set
                    428:       } {  } ifelse
1.29    ! takayama  429:       [f groebnerOptions] groebner /ggall set ggall 0 get /gg set
1.1       maekawa   430:     }ifelse
                    431:     wv isInteger {
                    432:       /ans [gg gg {init} map] def
                    433:     }{
                    434:       /ans [gg gg {wv 0 get weightv init} map] def
                    435:     }ifelse
                    436:
                    437:     %% Postprocess : recover the matrix expression.
                    438:     mm {
                    439:       ans { /tmp set [mm tmp] toVectors } map
                    440:       /ans set
                    441:     }{ }
                    442:     ifelse
1.17      takayama  443:     ans getRing (oxRingStructure) dc /gb.oxRingStructure set
1.23      takayama  444:     %% gg getAttributeList message
1.29    ! takayama  445:     ans
        !           446:       gg getAttributeList , [(all) ggall] join
        !           447:     setAttributeList /ans set
1.1       maekawa   448:     %%
1.12      takayama  449:     env1 restoreOptions  %% degreeShift changes "grade"
1.1       maekawa   450:
                    451:     /arg1 ans def
                    452:   ] pop
                    453:   popEnv
                    454:   popVariables
                    455:   arg1
                    456: } def
                    457: (gb ) messagen-quiet
                    458:
                    459: /pgb {
                    460:   /arg1 set
                    461:   [/in-pgb /aa /typev /setarg /f /v
                    462:    /gg /wv /termorder /vec /ans /rr /mm
1.23      takayama  463:    /groebnerOptions
1.1       maekawa   464:   ] pushVariables
                    465:   [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
                    466:   [
                    467:
                    468:     /aa arg1 def
                    469:     aa isArray { } { (<< array >> pgb) error } ifelse
1.23      takayama  470:     aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1       maekawa   471:     /setarg 0 def
                    472:     /wv 0 def
                    473:     aa { tag } map /typev set
                    474:     typev [ ArrayP ] eq
                    475:     {  /f aa 0 get def
                    476:        /v gb.v def
                    477:        /setarg 1 def
                    478:     } { } ifelse
                    479:     typev [ArrayP StringP] eq
                    480:     {  /f aa 0 get def
                    481:        /v aa 1 get def
                    482:        /setarg 1 def
                    483:     } { } ifelse
                    484:     typev [ArrayP ArrayP] eq
                    485:     {  /f aa 0 get def
                    486:        /v aa 1 get from_records def
                    487:        /setarg 1 def
                    488:     } { } ifelse
                    489:     typev [ArrayP StringP ArrayP] eq
                    490:     {  /f aa 0 get def
                    491:        /v aa 1 get def
                    492:        /wv aa 2 get def
                    493:        /setarg 1 def
                    494:     } { } ifelse
                    495:     typev [ArrayP ArrayP ArrayP] eq
                    496:     {  /f aa 0 get def
                    497:        /v aa 1 get from_records def
                    498:        /wv aa 2 get def
                    499:        /setarg 1 def
                    500:     } { } ifelse
                    501:
                    502:     setarg { } { (pgb : Argument mismatch) error } ifelse
                    503:
                    504:     [(KanGBmessage) gb.verbose ] system_variable
                    505:
                    506:     %%% Start of the preprocess
                    507:     f getRing /rr set
                    508:     %% To the normal form : matrix expression.
                    509:     f gb.toMatrixOfString /f set
                    510:     /mm gb.itWasMatrix def
                    511:
                    512:     rr tag 0 eq {
                    513:       %% Define our own ring
                    514:       v isInteger {
                    515:         (Error in pgb: Specify variables) error
                    516:       } {  } ifelse
                    517:       wv isInteger {
                    518:         [v ring_of_polynomials
1.13      takayama  519:         gb.characteristic] define_ring
1.1       maekawa   520:         /termorder 1 def
                    521:       }{
                    522:         [v ring_of_polynomials
                    523:          wv weight_vector
1.13      takayama  524:         gb.characteristic] define_ring
1.1       maekawa   525:         wv gb.isTermOrder /termorder set
                    526:       } ifelse
                    527:     } {
                    528:       %% Use the ring structre given by the input.
                    529:       v isInteger not {
1.7       takayama  530:         gb.warning {
                    531:          (Warning : the given ring definition is not used.) message
                    532:         } { } ifelse
1.1       maekawa   533:       } {  } ifelse
                    534:       rr ring_def
                    535:       /wv rr gb.getWeight def
                    536:       wv gb.isTermOrder /termorder set
                    537:     } ifelse
                    538:     %%% Enf of the preprocess
                    539:
1.23      takayama  540:     groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
1.25      takayama  541:     gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1       maekawa   542:     termorder {
                    543:       f { {. dehomogenize} map } map /f set
                    544:       [(UseCriterion1) 1] system_variable
1.25      takayama  545:       [f groebnerOptions] groebner_sugar 0 get /gg set
1.1       maekawa   546:       [(UseCriterion1) 0] system_variable
                    547:     }{
                    548:       f { {. dehomogenize} map} map /f set
                    549:       f fromVectors { homogenize } map /f set
                    550:       [(UseCriterion1) 1] system_variable
1.23      takayama  551:       [f groebnerOptions] groebner 0 get /gg set
1.1       maekawa   552:       [(UseCriterion1) 0] system_variable
                    553:     }ifelse
                    554:     wv isInteger {
                    555:       /ans [gg gg {init} map] def
                    556:     }{
                    557:       /ans [gg gg {wv 0 get weightv init} map] def
                    558:     }ifelse
                    559:
                    560:     %% Postprocess : recover the matrix expression.
                    561:     mm {
                    562:       ans { /tmp set [mm tmp] toVectors } map
                    563:       /ans set
                    564:     }{ }
                    565:     ifelse
                    566:     %%
1.23      takayama  567:     ans gg getAttributeList setAttributeList /ans set
1.1       maekawa   568:
                    569:     /arg1 ans def
                    570:   ] pop
                    571:   popEnv
                    572:   popVariables
                    573:   arg1
                    574: } def
                    575:
                    576: /pgb.old {
                    577:   /arg1 set
                    578:   [/in-pgb /aa /typev /setarg /f /v
                    579:    /gg /wv /termorder /vec /ans
                    580:   ] pushVariables
                    581:   [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
                    582:   [
                    583:
                    584:     /aa arg1 def
                    585:     aa isArray { } { (array pgb) message (pgb) usage error } ifelse
                    586:     /setarg 0 def
                    587:     /wv 0 def
                    588:     aa { tag } map /typev set
                    589:     typev [ ArrayP ] eq
                    590:     {  /f aa 0 get def
                    591:        /v gb.v def
                    592:        /setarg 1 def
                    593:     } { } ifelse
                    594:     typev [ArrayP StringP] eq
                    595:     {  /f aa 0 get def
                    596:        /v aa 1 get def
                    597:        /setarg 1 def
                    598:     } { } ifelse
                    599:     typev [ArrayP ArrayP] eq
                    600:     {  /f aa 0 get def
                    601:        /v aa 1 get from_records def
                    602:        /setarg 1 def
                    603:     } { } ifelse
                    604:     typev [ArrayP StringP ArrayP] eq
                    605:     {  /f aa 0 get def
                    606:        /v aa 1 get def
                    607:        /wv aa 2 get def
                    608:        /setarg 1 def
                    609:     } { } ifelse
                    610:     typev [ArrayP ArrayP ArrayP] eq
                    611:     {  /f aa 0 get def
                    612:        /v aa 1 get from_records def
                    613:        /wv aa 2 get def
                    614:        /setarg 1 def
                    615:     } { } ifelse
                    616:
                    617:     setarg { } { (pgb : Argument mismatch) message error } ifelse
                    618:
                    619:     [(KanGBmessage) gb.verbose ] system_variable
                    620:
                    621:     %% Input must not be vectors.
                    622:     f { toString } map /f set
                    623:
                    624:     wv isInteger {
                    625:       [v ring_of_polynomials
                    626:       0] define_ring
                    627:       /termorder 1 def
                    628:     }{
                    629:       [v ring_of_polynomials
                    630:        wv weight_vector
                    631:       0] define_ring
                    632:       wv gb.isTermOrder /termorder set
                    633:     } ifelse
                    634:     termorder {
                    635:       f { . dehomogenize } map /f set
                    636:       [(UseCriterion1) 1] system_variable
                    637:       [f] groebner_sugar 0 get /gg set
                    638:       [(UseCriterion1) 0] system_variable
                    639:     }{
                    640:       f { . dehomogenize homogenize} map /f set
                    641:       [(UseCriterion1) 1] system_variable
                    642:       [f] groebner 0 get /gg set
                    643:       [(UseCriterion1) 0] system_variable
                    644:     }ifelse
                    645:     wv isInteger {
                    646:       /ans [gg gg {init} map] def
                    647:     }{
                    648:       /ans [gg gg {wv 0 get weightv init} map] def
                    649:     }ifelse
                    650:     /arg1 ans def
                    651:   ] pop
                    652:   popEnv
                    653:   popVariables
                    654:   arg1
                    655: } def
                    656: (pgb ) messagen-quiet
                    657:
                    658: /gb.toMatrixOfString {
                    659:   /arg1 set
                    660:   [/in-gb.toMatrixOfString /ff /aa /ans] pushVariables
                    661:   [
                    662:      /aa arg1 def
                    663:      aa length 0 eq { /ans [ ] def /gb.toMatrixOfString.LLL goto }{ } ifelse
                    664:      aa 0 get isArray {
                    665:        /gb.itWasMatrix aa 0 get length def
                    666:      }{
                    667:        /gb.itWasMatrix 0 def
                    668:      } ifelse
                    669:      aa {
                    670:        /ff set
                    671:        ff isArray {
                    672:          ff {toString} map /ff set
                    673:        }{
                    674:          [ff toString] /ff set
                    675:        } ifelse
                    676:        ff
                    677:      } map /ans set
                    678:     /gb.toMatrixOfString.LLL
                    679:     /arg1 ans def
                    680:   ] pop
                    681:   popVariables
                    682:   arg1
                    683: } def
                    684: [(gb.toMatrixOfString)
                    685: [(It translates given input into a matrix form which is a data structure)
                    686:  (for computations of kernel, image, cokernel, etc.)
                    687:  (gb.itWasMatrix is set to the length of the input vector.)
                    688:  $Example 1: $
                    689:  $  [ (x). (y).] gb.toMatrixOfString ==> [[(x)] [(y)]] $
                    690:  $  gb.itWasMatrix is 0.$
                    691:  $Example 2: $
                    692:  $  [ [(x). (1).] [(y). (0).]] gb.toMatrixOfString ==>  [ [(x) (1)] [(y) (0)]] $
                    693:  $  gb.itWasMatrix is 2.$
                    694: ]] putUsages
                    695:
                    696: /gb.toMatrixOfPoly {
                    697:   /arg1 set
                    698:   [/in-gb.toMatrixOfPoly /ff /aa /ans] pushVariables
                    699:   [
                    700:      /aa arg1 def
                    701:      aa length 0 eq { /ans [ ] def /gb.toMatrixOfPoly.LLL goto }{ } ifelse
                    702:      aa 0 get isArray {
                    703:        /gb.itWasMatrix aa 0 get length def
                    704:      }{
                    705:        /gb.itWasMatrix 0 def
                    706:      } ifelse
                    707:      aa {
                    708:        /ff set
                    709:        ff isArray {
                    710:        }{
                    711:          [ff] /ff set
                    712:        } ifelse
                    713:        ff
                    714:      } map /ans set
                    715:     /gb.toMatrixOfPoly.LLL
                    716:     /arg1 ans def
                    717:   ] pop
                    718:   popVariables
                    719:   arg1
                    720: } def
                    721: [(gb.toMatrixOfPoly)
                    722: [(It translates given input into a matrix form which is a data structure)
                    723:  (for computations of kernel, image, cokernel, etc.)
                    724:  (gb.itWasMatrix is set to the length of the input vector.)
                    725:  $Example 1: $
                    726:  $  [ (x). (y).] gb.toMatrixOfPoly ==> [[(x)] [(y)]] $
                    727:  $  gb.itWasMatrix is 0.$
                    728:  $Example 2: $
                    729:  $  [ [(x). (1).] [(y). (0).]] gb.toMatrixOfPoly ==>  [ [(x) (1)] [(y) (0)]] $
                    730:  $  gb.itWasMatrix is 2.$
                    731: ]] putUsages
                    732:
                    733: /gb.getWeight {
                    734:   /arg1 set
                    735:   [/in-gb.getWeight /rr /ww /vv /ans /nn /ii] pushVariables
                    736:   [(CurrentRingp)] pushEnv
                    737:   [
                    738:      /rr arg1 def
                    739:      rr ring_def
                    740:      getVariableNames /vv set
                    741:      [(orderMatrix)] system_variable 0 get /ww set
                    742:      /nn vv length 1 sub def
                    743:      [0 1 nn {
                    744:         /ii set
                    745:         ww ii get 0 eq {
                    746:         } {
                    747:           vv ii get
                    748:           ww ii get
                    749:         } ifelse
                    750:       } for
                    751:      ] /ans set
                    752:      /arg1 [ans] def
                    753:   ] pop
                    754:   popEnv
                    755:   popVariables
                    756:   arg1
                    757: } def
                    758: [(gb.getWeight)
                    759: [(ring gb.getWeight wv)
                    760:  (It gets the weight vector field of the ring ring.)
                    761: ]] putUsages
                    762:
                    763:
                    764: /gb.isTermOrder {
                    765:   /arg1 set
                    766:   [/in-gb.isTermOrder /vv /ww /yes /i /j] pushVariables
                    767:   [
                    768:      /vv arg1 def
                    769:      /yes 1 def
                    770:      0 1 vv length 1 sub {
                    771:        /i set
                    772:        /ww vv i get def
                    773:        0 1 ww length 1 sub {
                    774:           /j set
                    775:           ww j get isInteger {
                    776:             ww j get 0 lt { /yes 0 def } { } ifelse
                    777:           }{ } ifelse
                    778:        }for
                    779:      }for
                    780:      /arg1 yes def
                    781:   ] pop
                    782:   popVariables
                    783:   arg1
                    784: } def
                    785: [(gb)
                    786:  [(a gb b)
                    787:   (array a; array b;)
                    788:   (b : [g ii];  array g; array in; g is a Grobner basis of f)
                    789:   (             in the ring of differential operators.)
                    790:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                    791:    $            to a ring. In the other cases, it returns the initial monominal.$
                    792:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    793:   (a : [f v];   array f; string v;  v is the variables. )
                    794:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.11      takayama  795:   (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
                    796:   (                array ds; ds is the degree shift )
1.1       maekawa   797:   (  )
1.14      takayama  798:   (gb.authoHomogenize 1 [default])
1.17      takayama  799:   (gb.oxRingStructure )
1.14      takayama  800:   ( )
1.1       maekawa   801:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
                    802:   $             [ [ (Dx) 1 ] ] ] gb pmat ; $
                    803:   (Example 2: )
                    804:   (To put h=1, type in, e.g., )
                    805:   $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
                    806:   $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] gb /gg set gg dehomogenize pmat ;$
                    807:   (  )
                    808:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
                    809:   $             [ [ (Dx) 1 (Dy) 1] ] ] gb pmat ; $
                    810:   (  )
                    811:   $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
                    812:   $             [ [ (x) -1 (y) -1] ] ] gb pmat ; $
1.12      takayama  813:   (  )
                    814:   $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
                    815:   $             [ [ (x) -1 (y) -1] ]  [[0 1] [-3 1] ] ] gb pmat ; $
1.23      takayama  816:   ( )
                    817:   $Example 6: [ [( (x Dx)^2 + (y Dy)^2 - x y Dx Dy + 1) ( x y Dx Dy -1)] (x,y) $
                    818:   $             [ [ (Dx) 1 ] ] ] [(reduceOnly) 1] setAttributeList gb pmat ; $
                    819:   ( )
                    820:   $Example 7: [ [( (x Dx)^2 + (y Dy)^2 + 1) ( x y Dx Dy -1)] (x,y) $
                    821:   $     [ [ (Dx) 1 ] ] ] [(gbCheck) 1] setAttributeList gb getAttributeList ::$
1.1       maekawa   822:   (  )
1.28      takayama  823:   $Example 8: /gb.options [(StopDegree) 11] def Onverbose $
                    824:   $ [ [(x^10+y^10-1) (x^5*y^5 -1)] (x,y) $
                    825:   $     [ [ (x) 1 ] ]]  gb pmat ; $
                    826:   (  )
1.1       maekawa   827:   (cf. gb, groebner, groebner_sugar, syz. )
                    828: ]] putUsages
                    829:
                    830: [(pgb)
                    831:  [(a pgb b)
                    832:   (array a; array b;)
                    833:   (b : [g ii];  array g; array in; g is a Grobner basis of f)
                    834:   (             in the ring of polynomials.)
                    835:   $             ii is the initial ideal in case of w is given or <<a>>belongs$
                    836:   $             to a ring. In the other cases, it returns the initial monominal.$
                    837:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    838:   (a : [f v];   array f; string v;  v is the variables.)
                    839:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
                    840:   $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
                    841:   $           [ [(x^2+y^2-4). (x y -1).] ] pgb :: $
                    842:   $Example 2: [ [(x^2+y^2) (x y)]   (x,y)  [ [(x) -1 (y) -1] ] ] pgb :: $
1.23      takayama  843:   $Example 3: [ [(x^2+y^2 + x y ) (x y)]   (x,y)  [ [(x) -1 (y) -1] ] ]  $
1.24      takayama  844:   $           [(reduceOnly) 1] setAttributeList pgb :: $
1.1       maekawa   845:   (cf. gb, groebner, groebner_sugar, syz. )
                    846: ]] putUsages
                    847:
                    848:
                    849: %/syz.v 1 def
                    850: /syz.v 1 def
                    851: /syz.verbose 0 def
                    852: /syz {
                    853:   /arg1 set
                    854:   [/in-syz /aa /typev /setarg /f /v
                    855:    /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
                    856:    /rr /mm
                    857:   ] pushVariables
                    858:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    859:   [
                    860:
                    861:     /aa arg1 def
                    862:     aa isArray { } { (<< array >> syz) error } ifelse
                    863:     /setarg 0 def
                    864:     /wv 0 def
                    865:     aa { tag } map /typev set
                    866:     typev [ ArrayP ] eq
                    867:     {  /f aa 0 get def
                    868:        /v syz.v def
                    869:        /setarg 1 def
                    870:     } { } ifelse
                    871:     typev [ArrayP StringP] eq
                    872:     {  /f aa 0 get def
                    873:        /v aa 1 get def
                    874:        /setarg 1 def
                    875:     } { } ifelse
1.9       takayama  876:     typev [ArrayP RingP] eq
                    877:     {  /f aa 0 get def
                    878:        /v aa 1 get def
                    879:        /setarg 1 def
                    880:     } { } ifelse
1.1       maekawa   881:     typev [ArrayP ArrayP] eq
                    882:     {  /f aa 0 get def
                    883:        /v aa 1 get from_records def
                    884:        /setarg 1 def
                    885:     } { } ifelse
                    886:     typev [ArrayP StringP ArrayP] eq
                    887:     {  /f aa 0 get def
                    888:        /v aa 1 get def
                    889:        /wv aa 2 get def
                    890:        /setarg 1 def
                    891:     } { } ifelse
1.9       takayama  892:     typev [ArrayP RingP ArrayP] eq
                    893:     {  /f aa 0 get def
                    894:        /v aa 1 get def
                    895:        /wv aa 2 get def
                    896:        /setarg 1 def
                    897:     } { } ifelse
1.1       maekawa   898:     typev [ArrayP ArrayP ArrayP] eq
                    899:     {  /f aa 0 get def
                    900:        /v aa 1 get from_records def
                    901:        /wv aa 2 get def
                    902:        /setarg 1 def
                    903:     } { } ifelse
                    904:
                    905:     setarg { } { (syz : Argument mismatch) error } ifelse
                    906:
                    907:     [(KanGBmessage) syz.verbose ] system_variable
                    908:
                    909:
                    910:
                    911:     %%% Start of the preprocess
1.9       takayama  912:     v tag RingP eq {
                    913:       /rr v def
                    914:     }{
                    915:        f getRing /rr set
                    916:     } ifelse
1.1       maekawa   917:     %% To the normal form : matrix expression.
                    918:     f gb.toMatrixOfString /f set
                    919:     /mm gb.itWasMatrix def
                    920:     mm 0 gt {
                    921:       /vectorInput 1 def
                    922:     }{
                    923:       /vectorInput 1 def
                    924:     } ifelse
                    925:
                    926:     rr tag 0 eq {
                    927:       %% Define our own ring
                    928:       v isInteger {
                    929:         (Error in syz: Specify variables) error
                    930:       } {  } ifelse
                    931:       wv isInteger {
                    932:         [v ring_of_differential_operators
                    933:         0] define_ring
                    934:         /termorder 1 def
                    935:       }{
                    936:         [v ring_of_differential_operators
                    937:          wv weight_vector
                    938:         0] define_ring
                    939:         wv gb.isTermOrder /termorder set
                    940:       } ifelse
                    941:     }{
                    942:       %% Use the ring structre given by the input.
                    943:       v isInteger not {
1.7       takayama  944:         gb.warning {
                    945:          (Warning : the given ring definition is not used.) message
                    946:         } { } ifelse
1.1       maekawa   947:       } {  } ifelse
                    948:       rr ring_def
                    949:       /wv rr gb.getWeight def
                    950:       wv gb.isTermOrder /termorder set
                    951:     } ifelse
                    952:     %%% Enf of the preprocess
                    953:
                    954:     termorder {
                    955:       f { {. dehomogenize} map } map /f set
                    956:       [f [(needBack) (needSyz)]] groebner_sugar /ggall set
                    957:       ggall 2 get /gg set
                    958:     }{
                    959:       f { {. dehomogenize } map homogenize } map /f set
                    960:       [f [(needBack) (needSyz)]] groebner /ggall set
                    961:       ggall 2 get /gg set
                    962:     }ifelse
                    963:     vectorInput {
                    964:       /vsize f 0 get length def  %% input vector size.
                    965:       /gtmp ggall 0 get def
                    966:        [vsize gtmp] toVectors /gtmp set
                    967:        ggall 0 gtmp put
                    968:     }{  } ifelse
1.19      takayama  969:
1.27      takayama  970:     gg length 0 eq {  % there is no syzygy
                    971:        ggall getRing (oxRingStructure) dc /gb.oxRingStructure set
                    972:     }{
                    973:      gg getRing (oxRingStructure) dc /gb.oxRingStructure set
                    974:     } ifelse
1.19      takayama  975:
                    976:     /arg1 [gg dehomogenize ggall] def
1.1       maekawa   977:   ] pop
                    978:   popEnv
                    979:   popVariables
                    980:   arg1
                    981: } def
                    982: (syz ) messagen-quiet
                    983:
                    984: [(syz)
                    985:  [(a syz [b c])
                    986:   (array a; array b; array c)
                    987:   (b is a set of generators of the syzygies of f.)
                    988:   (c = [gb, backward transformation, syzygy without dehomogenization].)
                    989:   (See groebner.)
                    990:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    991:   (a : [f v];   array f; string v;  v is the variables.)
                    992:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.9       takayama  993:   ( v may be a ring object. )
1.1       maekawa   994:   $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
                    995:   $           [ [(x^2+y^2-4). (x y -1).] ] syz :: $
                    996:   $Example 2: [ [(x^2+y^2) (x y)]   (x,y)  [ [(x) -1 (y) -1] ] ] syz :: $
                    997:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
                    998:   $             [ [ (Dx) 1 ] ] ] syz pmat ; $
                    999:   $Example 4:  [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
                   1000:   $             [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
                   1001:   $Example 5:  [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
                   1002:   $              (x,y) ] syz pmat ;$
                   1003:   $Example 6:  [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
                   1004:   $              (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
                   1005:   $Example 7:  [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
                   1006:   $              [(x) (y)]] syz pmat ;$
                   1007: ]] putUsages
                   1008:
                   1009:
                   1010: %%%%%%%%%%%%%%%%%% package fs  %%%%%%%%%%%%%%%%%%%%%%%
                   1011: [(genericAnn)
                   1012:  [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
                   1013:    (L1, ..., Lm are annihilating ideal for f^s.)
                   1014:    (f is a polynomial of v1, ..., vn)
                   1015:    (<string> | <poly>  f, s, v1, ..., vn ; <poly>  L1, ..., Lm )
                   1016:    $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
                   1017:  ]
                   1018: ] putUsages ( genericAnn ) messagen-quiet
                   1019: /fs.verbose 0 def
                   1020: /genericAnn {
                   1021:   /arg2 set /arg1 set
                   1022:   [/in-genericAnn /f /vlist /s  /vvv /nnn /rrr
                   1023:    /v1  /ops /ggg /ggg0
                   1024:    ] pushVariables
                   1025:   [(CurrentRingp) (KanGBmessage)] pushEnv
                   1026:   [
                   1027:     /f arg1 def  /vlist arg2 def
                   1028:     f toString /f set
                   1029:     vlist { toString } map /vlist set
                   1030:     [(KanGBmessage) fs.verbose] system_variable
                   1031:     /s vlist 0 get def
                   1032:     /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
                   1033:          s nnn 2 add cat_n def
                   1034:     fs.verbose { vvv message } {  }ifelse
                   1035:     [vvv ring_of_differential_operators
                   1036:      [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
                   1037:
                   1038:     [ (_u*_t). f . sub  (_u*_v-1). ]
                   1039:     vlist rest { /v1 set
                   1040: %%D-clean   f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
                   1041:         f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
                   1042:         @@@.Dsymbol v1 2 cat_n . add } map
                   1043:     join
                   1044:     /ops set
                   1045:     ops {[[(h). (1).]] replace } map /ops set
                   1046:     fs.verbose { ops message  } {  }ifelse
                   1047:     [ops] groebner_sugar 0 get /ggg0 set
                   1048:     fs.verbose { ggg0 message } { } ifelse
                   1049:     ggg0 [(_u) (_v)] eliminatev
                   1050: %%D-clean        { [(_t).] [ (D_t).] [s .] distraction
                   1051:         { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction
                   1052:           [[s . << (0). s . sub (1). sub >>]] replace
                   1053:          } map /arg1 set
                   1054:   ] pop
                   1055:   popEnv
                   1056:   popVariables
                   1057:   arg1
                   1058: } def
                   1059:
                   1060: %% Find differential equations for  f^(m), r0 the minimal integral root.
                   1061: [(annfs)
                   1062:  [( [ f v m r0] annfs g )
                   1063:   (It returns the annihilating ideal of f^m where r0 must be smaller)
                   1064:   (or equal to the minimal integral root of the b-function.)
                   1065:   (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
                   1066:   (where r0 is the minial integral root of b.)
                   1067:   (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
                   1068:   (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
                   1069:   $           It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
                   1070:   (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
                   1071:   $           It returns the annihilating ideal of f^r0 and [r0, b-function]$
                   1072:   $           where r0 is the minimal integral root of the b-function.$
                   1073:   (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
                   1074:   (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
                   1075:   (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
                   1076:   (            (t,x1,x2,x3) -1 -2] annfs :: )
                   1077:   (           Note that the example 4 uses huge memory space.)
1.26      takayama 1078:   (   )
                   1079:   (Note: This implementation is stable but obsolete. )
                   1080:   (As to faster implementation, we refer to ann0 and ann of Risa/Asir )
                   1081:   (Visit  http://www.math.kobe-u.ac.jp/Asir )
1.1       maekawa  1082: ]] putUsages
                   1083: ( annfs ) messagen-quiet
                   1084: /annfs.verbose fs.verbose def
                   1085: /annfs.v [(x) (y) (z)] def
                   1086: /annfs.s (_s) def
                   1087: %% The first variable must be s.
                   1088: /annfs {
                   1089:   /arg1 set
                   1090:   [/in-annfs /aa /typev /setarg  /v /m /r0 /gg /ss /fs /gg2
                   1091:    /ans /vtmp /w2 /velim /bbb /rrr /r0
                   1092:   ] pushVariables
                   1093:   [(CurrentRingp) (KanGBmessage)] pushEnv
                   1094:   [
                   1095:
                   1096:     /aa arg1 def
                   1097:     aa isArray { } { ( << array >> annfs) error } ifelse
                   1098:     /setarg 0 def
                   1099:     aa { tag } map /typev set
                   1100:     /r0 [ ] def
                   1101:     /m  [ ]  def
                   1102:     /v annfs.v def
                   1103:     aa 0 << aa 0 get toString >> put
                   1104:     typev [ StringP ] eq
                   1105:     {  /f aa 0 get def
                   1106:        /setarg 1 def
                   1107:     } { } ifelse
                   1108:     typev [StringP StringP] eq
                   1109:     {  /f aa 0 get def
                   1110:        /v [ aa 1 get to_records pop ] def
                   1111:        /setarg 1 def
                   1112:     } { } ifelse
                   1113:     typev [StringP ArrayP] eq
                   1114:     {  /f aa 0 get def
                   1115:        /v aa 1 get def
                   1116:        /setarg 1 def
                   1117:     } { } ifelse
                   1118:     typev [StringP ArrayP IntegerP IntegerP] eq
                   1119:     {  /f aa 0 get def
                   1120:        /v aa 1 get def
                   1121:        /m aa 2 get def
                   1122:        /r0 aa 3 get def
                   1123:        /setarg 1 def
                   1124:     } { } ifelse
                   1125:     typev [StringP StringP IntegerP IntegerP] eq
                   1126:     {  /f aa 0 get def
                   1127:        /v [ aa 1 get to_records pop ] def
                   1128:        /m aa 2 get def
                   1129:        /r0 aa 3 get def
                   1130:        /setarg 1 def
                   1131:     } { } ifelse
                   1132:     setarg 1 eq { } { (annfs : wrong argument) error } ifelse
                   1133:
                   1134:     [annfs.s] v join /v set
                   1135:
                   1136:     /ss v 0 get def
                   1137:     annfs.verbose {
                   1138:        (f, v, s, f^{m}, m+r0 = ) messagen
                   1139:        [ f  (, ) v  (, )  ss  (, )
                   1140:          (f^) m (,) m (+)  r0 ] {messagen} map ( ) message
                   1141:     } { } ifelse
                   1142:
                   1143:     f v genericAnn /fs set
                   1144:
                   1145:     annfs.verbose {
                   1146:       (genericAnn is ) messagen fs message
                   1147:     } { } ifelse
                   1148:     [(KanGBmessage) annfs.verbose] system_variable
                   1149:
                   1150:     m isArray {
                   1151:       %% Now, let us find  the b-function. /vtmp /w2 /velim /bbb /rrr /r0
                   1152:       v rest { /vtmp set vtmp  @@@.Dsymbol vtmp 2 cat_n } map /velim set
                   1153:       velim { 1 } map /w2 set
                   1154:       annfs.verbose { w2 message } {  } ifelse
                   1155:       [v from_records ring_of_differential_operators
                   1156:        [w2] weight_vector 0] define_ring
                   1157:       [ fs { toString . } map [ f toString . ] join ]
                   1158:       groebner_sugar 0 get velim eliminatev 0 get /bbb set
                   1159:       [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
                   1160:       bbb toString . [[annfs.s . (s).]] replace /bbb set
                   1161:       annfs.verbose { bbb message } {  } ifelse
                   1162:       bbb findIntegralRoots  /rrr set
                   1163:       rrr 0 get /r0 set  %% minimal integral root.
                   1164:       annfs.verbose { rrr message } {  } ifelse
                   1165:       fs 0 get (ring) dc ring_def
                   1166:       fs { [[annfs.s . r0 toString .]] replace } map /ans set
                   1167:       /ans [ans [r0 bbb]] def
                   1168:       /annfs.label1 goto
                   1169:     } { } ifelse
                   1170:     m 0 ge {
                   1171:       (annfs works only for getting annihilating ideal for f^(negative))
                   1172:       error
                   1173:     } { } ifelse
                   1174:     r0 isArray {
                   1175:       [(Need to compute the minimal root of b-function) nl
                   1176:        (It has not been implemented.) ] cat
                   1177:       error
                   1178:     } {  } ifelse
                   1179:
                   1180:     [v from_records ring_of_differential_operators 0] define_ring
                   1181:     fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace}
                   1182:        map /gg set
                   1183:     annfs.verbose { gg message } { } ifelse
                   1184:
                   1185:     [ [f . << m r0 sub >> npower ] gg join
                   1186:       [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
                   1187:
                   1188:     gg2 { 0 get } map /ans set
                   1189:     /ans ans { dup (0). eq {pop} { } ifelse } map def
                   1190:
                   1191:     /annfs.label1
                   1192:     /arg1 ans def
                   1193:   ] pop
                   1194:   popEnv
                   1195:   popVariables
                   1196:   arg1
                   1197: } def
                   1198:
                   1199: /genericAnnWithL.s (s) def
                   1200: /annfs.verify 0 def
                   1201: /genericAnnWithL {
                   1202:   /arg1 set
                   1203:   [/in-genericAnnWithL /aa /typev /setarg  /v /m /r0 /gg /ss /fs /gg2
                   1204:    /ans /vtmp /w2 /velim /bbb /rrr /r0  /myL /mygb /jj
                   1205:   ] pushVariables
                   1206:   [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
                   1207:   [
                   1208:
                   1209:     /aa arg1 def
                   1210:     aa isArray { } { ( << array >> annfs) error } ifelse
                   1211:     /setarg 0 def
                   1212:     aa { tag } map /typev set
                   1213:     /r0 [ ] def
                   1214:     /m  [ ]  def
                   1215:     /v annfs.v def
                   1216:     aa 0 << aa 0 get toString >> put
                   1217:     typev [ StringP ] eq
                   1218:     {  /f aa 0 get def
                   1219:        /setarg 1 def
                   1220:     } { } ifelse
                   1221:     typev [StringP StringP] eq
                   1222:     {  /f aa 0 get def
                   1223:        /v [ aa 1 get to_records pop ] def
                   1224:        /setarg 1 def
                   1225:     } { } ifelse
                   1226:     typev [StringP ArrayP] eq
                   1227:     {  /f aa 0 get def
                   1228:        /v aa 1 get def
                   1229:        /setarg 1 def
                   1230:     } { } ifelse
                   1231:     setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse
                   1232:
                   1233:     [genericAnnWithL.s] v join /v set
                   1234:
                   1235:     /ss v 0 get def
                   1236:     annfs.verbose {
                   1237:        (f, v, s, f^{m}, m+r0 = ) messagen
                   1238:        [ f  (, ) v  (, )  ss  (, )
                   1239:          (f^) m (,) m (+)  r0 ] {messagen} map ( ) message
                   1240:     } { } ifelse
                   1241:
                   1242:     f v genericAnn /fs set
                   1243:
                   1244:     annfs.verbose {
                   1245:       (genericAnn is ) messagen fs message
                   1246:     } { } ifelse
                   1247:     [(KanGBmessage) annfs.verbose] system_variable
                   1248:
                   1249:     m isArray {
                   1250:       %% Now, let us find  the b-function. /vtmp /w2 /velim /bbb /rrr /r0
                   1251:       v rest { /vtmp set vtmp  @@@.Dsymbol vtmp 2 cat_n } map /velim set
                   1252:       velim { 1 } map /w2 set
                   1253:       annfs.verbose { w2 message } {  } ifelse
                   1254:       [v from_records ring_of_differential_operators
                   1255:        [w2] weight_vector 0] define_ring
                   1256:
                   1257:       [ [ f toString . ] fs { toString . } map join [(needBack)]]
                   1258:       groebner_sugar /mygb set
                   1259:       mygb 0 get velim eliminatev 0 get /bbb set
                   1260:       mygb 0 get bbb position /jj set
                   1261:       mygb 1 get jj get 0 get /myL set
                   1262:
                   1263:       annfs.verbose { bbb message } {  } ifelse
                   1264:
                   1265:       annfs.verify {
                   1266:         (Verifying L f - b belongs to genericAnn(f)) message
                   1267:         [(Homogenize) 0] system_variable
                   1268:         << myL f . mul bbb sub >>
                   1269:         [fs { toString . } map] groebner_sugar 0 get
                   1270:         reduction 0 get message
                   1271:         (Is it zero? Then it's fine.) message
                   1272:       } { } ifelse
                   1273:
                   1274:       /ans [bbb [myL fs] ] def
                   1275:       /annfs.label1 goto
                   1276:     } { } ifelse
                   1277:
                   1278:     /annfs.label1
                   1279:     /arg1 ans def
                   1280:   ] pop
                   1281:   popEnv
                   1282:   popVariables
                   1283:   arg1
                   1284: } def
                   1285:
                   1286:
                   1287: [(genericAnnWithL)
                   1288: [$[f v] genericAnnWithL [b [L I]]$
                   1289:  $String f,v; poly b,L; array of poly I;$
                   1290:  $f is a polynomial given by a string. v is the variables.$
                   1291:  $ v must not contain names  s, e.$
                   1292:  $b is the b-function (Bernstein-Sato polynomial) for f and$
                   1293:  $ L is the operator satisfying L f^{s+1} = b(s) f^s $
                   1294:  $ I is the annihilating ideal of f^s.$
                   1295:  $cf. bfunction, annfs, genericAnn.$
                   1296:  $Example 1:  [(x^2+y^2) (x,y)] genericAnnWithL ::$
                   1297:  $Example 2:  [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
                   1298:  $Example 3:  [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
                   1299: ]] putUsages
1.2       takayama 1300:
                   1301: /reduction*.noH 0 def
                   1302: /reduction* {
                   1303:   /arg1 set
                   1304:   [/in-reduction* /aa /typev /setarg /f /v
                   1305:    /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
1.3       takayama 1306:    /opt
1.2       takayama 1307:   ] pushVariables
                   1308:   [(CurrentRingp) (KanGBmessage)] pushEnv
                   1309:   [
                   1310:
                   1311:     /aa arg1 def
                   1312:     aa isArray { } { ( << array >> reduction*) error } ifelse
                   1313:     /setarg 0 def
                   1314:     /wv 0 def
                   1315:     aa { tag } map /typev set
                   1316:     typev [StringP ArrayP ArrayP] eq
                   1317:     typev [ArrayP ArrayP ArrayP] eq or
                   1318:     typev [PolyP ArrayP ArrayP] eq or
                   1319:     {  /h aa 0 get def
                   1320:        /f aa 1 get def
                   1321:        /v aa 2 get from_records def
                   1322:        /setarg 1 def
                   1323:     } { } ifelse
                   1324:     typev [StringP ArrayP ArrayP ArrayP] eq
                   1325:     typev [ArrayP ArrayP ArrayP ArrayP] eq or
                   1326:     typev [PolyP ArrayP ArrayP ArrayP] eq or
                   1327:     {  /h aa 0 get def
                   1328:        /f aa 1 get def
                   1329:        /v aa 2 get from_records def
                   1330:        /wv aa 3 get def
                   1331:        /setarg 1 def
                   1332:     } { } ifelse
                   1333:
                   1334:     setarg { } { (reduction* : Argument mismatch) error } ifelse
                   1335:
                   1336:     [(KanGBmessage) gb.verbose ] system_variable
                   1337:
                   1338:     %%% Start of the preprocess
                   1339:     f getRing /rr set
                   1340:
                   1341:
                   1342:     rr tag 0 eq {
                   1343:       %% Define our own ring
                   1344:       v isInteger {
                   1345:         (Error in reduction*: Specify variables) error
                   1346:       } {  } ifelse
                   1347:       wv isInteger {
                   1348:         [v ring_of_differential_operators
                   1349:         0] define_ring
                   1350:         /termorder 1 def
                   1351:       }{
                   1352:         [v ring_of_differential_operators
                   1353:          wv weight_vector
                   1354:         0] define_ring
                   1355:         wv gb.isTermOrder /termorder set
                   1356:       } ifelse
                   1357:     } {
                   1358:       %% Use the ring structre given by the input.
                   1359:       v isInteger not {
1.7       takayama 1360:         gb.warning {
                   1361:          (Warning : the given ring definition is not used.) message
                   1362:         } { } ifelse
1.2       takayama 1363:       } {  } ifelse
                   1364:       rr ring_def
                   1365:       /wv rr gb.getWeight def
                   1366:       wv gb.isTermOrder /termorder set
                   1367:     } ifelse
                   1368:     %%% Enf of the preprocess
                   1369:
                   1370:     f 0 get isArray {
                   1371:       /size f 0 get length def
                   1372:       f { { toString . } map } map /f set
                   1373:       f fromVectors /f set
                   1374:     }{
                   1375:       /size -1 def
                   1376:       f { toString . } map /f set
                   1377:     } ifelse
                   1378:
                   1379:     h isArray {
                   1380:       h { toString . } map /h set
                   1381:       [h] fromVectors 0 get /h set
                   1382:     }{
                   1383:       h toString . /h set
                   1384:     } ifelse
                   1385:     f { toString . } map /f set
1.3       takayama 1386:     getOptions /opt set
                   1387:     [(ReduceLowerTerms) 1] system_variable
1.2       takayama 1388:     reduction*.noH {
                   1389:       h f reduction-noH /ans set
                   1390:     } {
                   1391:       h f reduction /ans set
                   1392:     } ifelse
1.3       takayama 1393:     opt restoreOptions
1.2       takayama 1394:     size -1 eq not {
                   1395:       [size ans 0 get] toVectors /a0 set
                   1396:       [size ans 3 get] toVectors /a3 set
                   1397:       /ans [a0 ans 1 get ans 2 get a3] def
                   1398:     } { } ifelse
                   1399:     /arg1 ans def
                   1400:   ] pop
                   1401:   popEnv
                   1402:   popVariables
                   1403:   arg1
                   1404: } def
                   1405:
                   1406:
                   1407: [(reduction*)
                   1408: [([f base v] reduction* [h c0 syz input])
                   1409:  ([f base v weight] reduction* [h c0 syz input])
                   1410:  (reduction* is an user interface for reduction and reduction-noH.)
                   1411:  (If reduction*.noH is one, then reduction-noH will be called.)
                   1412:  (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
                   1413:  (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
                   1414:  (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
                   1415: ]] putUsages
1.5       takayama 1416:
                   1417:
                   1418:
                   1419: %%  2000, 6/7,  at Sevilla, Hernando Colon
                   1420: %% macros that deal with homogenized inputs.
                   1421: %%  Sample:  [ [(h+x). (x^3).] [(x). (x).]] /ff set
                   1422: %%           [(Homogenize_vec) 0] system_varialbe
                   1423: %%           (grade) (grave1v) switch_function
                   1424: %%  YA homogenization:  [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
                   1425: %%                          4+0         3+1      2+0    1+1
                   1426: /gb_h {
                   1427:   /arg1 set
                   1428:   [/in-gb_h /aa /typev /setarg /f /v
                   1429:    /gg /wv /termorder /vec /ans /rr /mm
1.23      takayama 1430:    /gb_h.opt  /groebnerOptions
1.5       takayama 1431:   ] pushVariables
                   1432:   [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
                   1433:   [
                   1434:
                   1435:     /aa arg1 def
1.6       takayama 1436:     gb.verbose { (Getting in gb_h) message } {  } ifelse
1.5       takayama 1437:     aa isArray { } { ( << array >> gb_h) error } ifelse
1.23      takayama 1438:     aa getAttributeList configureGroebnerOption /groebnerOptions set
1.5       takayama 1439:     /setarg 0 def
                   1440:     /wv 0 def
                   1441:     aa { tag } map /typev set
                   1442:     typev [ ArrayP ] eq
                   1443:     {  /f aa 0 get def
                   1444:        /v gb.v def
                   1445:        /setarg 1 def
                   1446:     } { } ifelse
                   1447:     typev [ArrayP StringP] eq
                   1448:     {  /f aa 0 get def
                   1449:        /v aa 1 get def
                   1450:        /setarg 1 def
                   1451:     } { } ifelse
1.10      takayama 1452:     typev [ArrayP RingP] eq
                   1453:     {  /f aa 0 get def
                   1454:        /v aa 1 get def
                   1455:        /setarg 1 def
                   1456:     } { } ifelse
1.5       takayama 1457:     typev [ArrayP ArrayP] eq
                   1458:     {  /f aa 0 get def
                   1459:        /v aa 1 get from_records def
                   1460:        /setarg 1 def
                   1461:     } { } ifelse
                   1462:     typev [ArrayP StringP ArrayP] eq
                   1463:     {  /f aa 0 get def
                   1464:        /v aa 1 get def
                   1465:        /wv aa 2 get def
                   1466:        /setarg 1 def
                   1467:     } { } ifelse
                   1468:     typev [ArrayP ArrayP ArrayP] eq
                   1469:     {  /f aa 0 get def
                   1470:        /v aa 1 get from_records def
                   1471:        /wv aa 2 get def
                   1472:        /setarg 1 def
                   1473:     } { } ifelse
                   1474:
                   1475:     setarg { } { (gb_h : Argument mismatch) error } ifelse
                   1476:
                   1477:     [(KanGBmessage) gb.verbose ] system_variable
                   1478:
                   1479:     %%% Start of the preprocess
1.10      takayama 1480:     v tag RingP eq {
                   1481:       /rr v def
                   1482:     }{
                   1483:       f getRing /rr set
                   1484:     } ifelse
1.5       takayama 1485:     %% To the normal form : matrix expression.
                   1486:     f gb.toMatrixOfString /f set
                   1487:     /mm gb.itWasMatrix def
                   1488:
                   1489:     rr tag 0 eq {
                   1490:       %% Define our own ring
                   1491:       v isInteger {
                   1492:         (Error in gb_h: Specify variables) error
                   1493:       } {  } ifelse
                   1494:       wv isInteger {
                   1495:         [v ring_of_differential_operators
                   1496:         0] define_ring
                   1497:         /termorder 1 def
                   1498:       }{
                   1499:         [v ring_of_differential_operators
                   1500:          wv weight_vector
                   1501:         0] define_ring
                   1502:         wv gb.isTermOrder /termorder set
                   1503:       } ifelse
                   1504:     } {
                   1505:       %% Use the ring structre given by the input.
                   1506:       v isInteger not {
1.7       takayama 1507:         gb.warning {
                   1508:          (Warning : the given ring definition is not used.) message
                   1509:         } { } ifelse
1.5       takayama 1510:       } {  } ifelse
                   1511:       rr ring_def
                   1512:       /wv rr gb.getWeight def
                   1513:       wv gb.isTermOrder /termorder set
                   1514:     } ifelse
                   1515:     getOptions /gb_h.opt set
                   1516:     (grade) (module1v) switch_function
1.6       takayama 1517:     [(Homogenize_vec) 0] system_variable
1.5       takayama 1518:     %%% End of the preprocess
                   1519:
1.23      takayama 1520:     groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
                   1521:     gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.5       takayama 1522:     termorder {
                   1523:       f { {. } map } map /f set
1.23      takayama 1524:       [f groebnerOptions] groebner 0 get /gg set %% Do not use sugar.
1.5       takayama 1525:     }{
                   1526:       f { {. } map} map /f set
                   1527:       f fromVectors /f set
1.23      takayama 1528:       [f groebnerOptions] groebner 0 get /gg set
1.5       takayama 1529:     }ifelse
                   1530:     wv isInteger {
                   1531:       /ans [gg gg {init} map] def
                   1532:     }{
                   1533:       /ans [gg gg {wv 0 get weightv init} map] def
                   1534:     }ifelse
                   1535:
                   1536:     %% Postprocess : recover the matrix expression.
                   1537:     mm {
                   1538:       ans { /tmp set [mm tmp] toVectors } map
                   1539:       /ans set
                   1540:     }{ }
                   1541:     ifelse
1.23      takayama 1542:     ans gg getAttributeList setAttributeList /ans set
1.5       takayama 1543:     gb_h.opt restoreOptions
1.6       takayama 1544:     gb.verbose { (Getting out of gb_h) message } {  } ifelse
1.5       takayama 1545:     %%
                   1546:
                   1547:     /arg1 ans def
                   1548:   ] pop
                   1549:   popEnv
                   1550:   popVariables
                   1551:   arg1
                   1552: } def
                   1553: (gb_h ) messagen-quiet
                   1554: [(gb_h)
                   1555:  [(a gb_h b)
                   1556:   (array a; array b;)
                   1557:   (b : [g ii];  array g; array in; g is a Grobner basis of f)
                   1558:   (             in the ring of homogenized differential operators.)
                   1559:   ( The input must be homogenized properly.)
                   1560:   ( Inproper homogenization may cause an infinite loop.)
                   1561:   ( Each element of vectors must be homogenized. If you are using )
                   1562:   ( non-term orders, all elements of vectors must have the same degree with)
                   1563:   ( a proper degree shift vector.)
                   1564:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                   1565:    $            to a ring. In the other cases, it returns the initial monominal.$
                   1566:   $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
                   1567:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                   1568:   (a : [f v];   array f; string v;  v is the variables. )
1.10      takayama 1569:   (a : [f r];   array f; ring r )
1.5       takayama 1570:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
                   1571:   (  )
                   1572:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
                   1573:   $             [ [ (Dx) 1 ] ] ] gb_h pmat ; $
                   1574:   $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
                   1575:   $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
                   1576:   $              [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
                   1577:   $             [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
                   1578:   $  Infinite loop: see by [(DebugReductionRed) 1] system_variable$
                   1579:   $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
                   1580:   $              [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
                   1581:   $             [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
                   1582:   $  This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1.23      takayama 1583:   $Example 5: [ [[(h+x) (x^3 + 2 h^3 + 2 x h^2)] [(x) (x)]] (x)] $
1.24      takayama 1584:   $            [(reduceOnly) 1] setAttributeList gb_h pmat $
1.5       takayama 1585:   (  )
                   1586:   (cf. gb, groebner, syz_h. )
                   1587: ]] putUsages
                   1588:
                   1589: /syz_h {
                   1590:   /arg1 set
                   1591:   [/in-syz_h /aa /typev /setarg /f /v
                   1592:    /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
                   1593:    /rr /mm
                   1594:    /syz_h.opt
                   1595:   ] pushVariables
                   1596:   [(CurrentRingp) (KanGBmessage)] pushEnv
                   1597:   [
                   1598:
                   1599:     /aa arg1 def
                   1600:     aa isArray { } { (<< array >> syz_h) error } ifelse
                   1601:     /setarg 0 def
                   1602:     /wv 0 def
                   1603:     aa { tag } map /typev set
                   1604:     typev [ ArrayP ] eq
                   1605:     {  /f aa 0 get def
                   1606:        /v syz.v def
                   1607:        /setarg 1 def
                   1608:     } { } ifelse
                   1609:     typev [ArrayP StringP] eq
                   1610:     {  /f aa 0 get def
                   1611:        /v aa 1 get def
                   1612:        /setarg 1 def
                   1613:     } { } ifelse
1.10      takayama 1614:     typev [ArrayP RingP] eq
                   1615:     {  /f aa 0 get def
                   1616:        /v aa 1 get def
                   1617:        /setarg 1 def
                   1618:     } { } ifelse
1.5       takayama 1619:     typev [ArrayP ArrayP] eq
                   1620:     {  /f aa 0 get def
                   1621:        /v aa 1 get from_records def
                   1622:        /setarg 1 def
                   1623:     } { } ifelse
                   1624:     typev [ArrayP StringP ArrayP] eq
                   1625:     {  /f aa 0 get def
                   1626:        /v aa 1 get def
                   1627:        /wv aa 2 get def
                   1628:        /setarg 1 def
                   1629:     } { } ifelse
                   1630:     typev [ArrayP ArrayP ArrayP] eq
                   1631:     {  /f aa 0 get def
                   1632:        /v aa 1 get from_records def
                   1633:        /wv aa 2 get def
                   1634:        /setarg 1 def
                   1635:     } { } ifelse
                   1636:
                   1637:     setarg { } { (syz_h : Argument mismatch) error } ifelse
                   1638:
                   1639:     [(KanGBmessage) syz.verbose ] system_variable
                   1640:
                   1641:
                   1642:
                   1643:     %%% Start of the preprocess
1.10      takayama 1644:     v tag RingP eq {
                   1645:        /rr v def
                   1646:     }{
                   1647:       f getRing /rr set
                   1648:     } ifelse
1.5       takayama 1649:     %% To the normal form : matrix expression.
                   1650:     f gb.toMatrixOfString /f set
                   1651:     /mm gb.itWasMatrix def
                   1652:     mm 0 gt {
                   1653:       /vectorInput 1 def
                   1654:     }{
                   1655:       /vectorInput 1 def
                   1656:     } ifelse
                   1657:
                   1658:     rr tag 0 eq {
                   1659:       %% Define our own ring
                   1660:       v isInteger {
                   1661:         (Error in syz_h: Specify variables) error
                   1662:       } {  } ifelse
                   1663:       wv isInteger {
                   1664:         [v ring_of_differential_operators
                   1665:         0] define_ring
                   1666:         /termorder 1 def
                   1667:       }{
                   1668:         [v ring_of_differential_operators
                   1669:          wv weight_vector
                   1670:         0] define_ring
                   1671:         wv gb.isTermOrder /termorder set
                   1672:       } ifelse
                   1673:     }{
                   1674:       %% Use the ring structre given by the input.
                   1675:       v isInteger not {
1.7       takayama 1676:         gb.warning {
                   1677:          (Warning : the given ring definition is not used.) message
                   1678:         } { } ifelse
1.5       takayama 1679:       } {  } ifelse
                   1680:       rr ring_def
                   1681:       /wv rr gb.getWeight def
                   1682:       wv gb.isTermOrder /termorder set
                   1683:     } ifelse
                   1684:
                   1685:     getOptions /syz_h.opt set
                   1686:     (grade) (module1v) switch_function
                   1687:     [(Homogenize_vec) 0] system_variable
                   1688:     %%% End of the preprocess
                   1689:
                   1690:     termorder {
                   1691:       f { {. } map } map /f set
                   1692:       [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
                   1693:       ggall 2 get /gg set
                   1694:     }{
                   1695:       f { {. } map  } map /f set
                   1696:       [f [(needBack) (needSyz)]] groebner /ggall set
                   1697:       ggall 2 get /gg set
                   1698:     }ifelse
                   1699:     vectorInput {
                   1700:       /vsize f 0 get length def  %% input vector size.
                   1701:       /gtmp ggall 0 get def
                   1702:        [vsize gtmp] toVectors /gtmp set
                   1703:        ggall 0 gtmp put
                   1704:     }{  } ifelse
                   1705:
                   1706:     syz_h.opt restoreOptions
                   1707:     %%
                   1708:
                   1709:       /arg1 [gg ggall] def
                   1710:   ] pop
                   1711:   popEnv
                   1712:   popVariables
                   1713:   arg1
                   1714: } def
                   1715: (syz_h ) messagen-quiet
                   1716:
                   1717: [(syz_h)
                   1718:  [(a syz_h [b c])
                   1719:   (array a; array b; array c)
                   1720:   (b is a set of generators of the syzygies of f in the ring of)
                   1721:   (homogenized differential operators.)
                   1722:   ( The input must be homogenized properly.)
                   1723:   ( Inproper homogenization may cause an infinite loop.)
                   1724:   ( Each element of vectors must be homogenized. If you are using )
                   1725:   ( non-term orders, all elements of vectors must have the same degree with)
                   1726:   ( a proper degree shift vector.)
                   1727:   (c = [gb, backward transformation, syzygy without dehomogenization].)
                   1728:   (See gb_h.)
                   1729:   $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
                   1730:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                   1731:   (a : [f v];   array f; string v;  v is the variables.)
1.10      takayama 1732:   (a : [f r];   array f; ring r )
1.5       takayama 1733:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
                   1734:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
                   1735:   $             [ [ (Dx) 1 ] ] ] syz_h pmat ; $
                   1736:   $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
                   1737:   $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
                   1738:   $              [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
                   1739:   $             [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
                   1740:   $  Infinite loop: see by [(DebugReductionRed) 1] system_variable$
                   1741:   $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
                   1742:   $              [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
                   1743:   $             [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
                   1744:   $  This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
                   1745:   $Example 5:  [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
                   1746:   $              [(x) (y)]] syz pmat ;$
                   1747: ]] putUsages
                   1748:
                   1749:
                   1750: /isSameIdeal {
                   1751:   /arg1 set
                   1752:   [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
                   1753:   [(CurrentRingp)] pushEnv
                   1754:   [
                   1755:     /aa arg1 def
                   1756:     %% comparison of hilbert series has not yet been implemented.
                   1757:     aa length 3 eq {    }
                   1758:     { ([ii jj vv] isSameIdeal) error } ifelse
1.6       takayama 1759:     gb.verbose { (Getting in isSameIdeal) message } { } ifelse
1.5       takayama 1760:     /ii aa 0 get def
                   1761:     /jj aa 1 get def
                   1762:     /vv aa 2 get def
                   1763:     ii length 0 eq jj length 0 eq and
                   1764:     { /ans 1 def /LLL.isSame goto } {  } ifelse
                   1765:     [ii vv] gb  /iigg set
                   1766:     [jj vv] gb  /jjgg set
                   1767:
                   1768:     iigg getRing ring_def
                   1769:
                   1770:     /ans 1 def
                   1771:     iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
                   1772:     /iigg set
                   1773:     jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
                   1774:     /jjgg set
                   1775:
                   1776:     gb.verbose { ( ii < jj ?) messagen } {  } ifelse
                   1777:     iigg length /n set
                   1778:     0 1 n 1 sub {
                   1779:       /k set
                   1780:       iigg  k get
                   1781:       jjgg  reduction-noH 0 get
                   1782:       (0). eq not { /ans 0 def /LLL.isSame goto} {  } ifelse
                   1783:       gb.verbose { (o) messagen } {  } ifelse
                   1784:     } for
                   1785:     gb.verbose { ( jj < ii ?) messagen } {  } ifelse
                   1786:     jjgg length /n set
                   1787:     0 1 n 1 sub {
                   1788:       /k set
                   1789:       jjgg k get
                   1790:       iigg reduction-noH 0 get
                   1791:       (0). eq not { /ans 0 def /LLL.isSame goto} {  } ifelse
                   1792:       gb.verbose { (o) messagen } {  } ifelse
                   1793:     } for
                   1794:     /LLL.isSame
                   1795:     gb.verbose { ( Done) message } {  } ifelse
                   1796:     /arg1 ans def
                   1797:   ] pop
                   1798:   popEnv
                   1799:   popVariables
                   1800:   arg1
                   1801: } def
                   1802: (isSameIdeal ) messagen-quiet
                   1803:
                   1804: [(isSameIdeal)
                   1805: [([ii jj vv] isSameIdeal bool)
                   1806:  (ii, jj : ideal, vv : variables)
                   1807:  (Note that ii and jj will be dehomogenized and compared in the ring)
                   1808:  (of differential operators. cf. isSameIdeal_h)
                   1809:  $Example 1: [ [(x^3) (y^2)]  [(x^2+y) (y)] (x,y)] isSameIdeal $
                   1810:  $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
                   1811:  $             [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
                   1812: ]] putUsages
                   1813:
                   1814: /isSameIdeal_h {
                   1815:   /arg1 set
1.6       takayama 1816:   [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
                   1817:    /isSameIdeal_h.opt
                   1818:    ] pushVariables
                   1819:   [(CurrentRingp) (Homogenize_vec)] pushEnv
1.5       takayama 1820:   [
                   1821:     /aa arg1 def
1.6       takayama 1822:     gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
1.5       takayama 1823:     %% comparison of hilbert series has not yet been implemented.
                   1824:     aa length 3 eq {    }
                   1825:     { ([ii jj vv] isSameIdeal_h) error } ifelse
                   1826:     /ii aa 0 get def
                   1827:     /jj aa 1 get def
                   1828:     /vv aa 2 get def
                   1829:     ii length 0 eq jj length 0 eq and
                   1830:     { /ans 1 def /LLL.isSame_h goto } {  } ifelse
                   1831:
                   1832:     [ii vv] gb_h  /iigg set
                   1833:     [jj vv] gb_h  /jjgg set
                   1834:
                   1835:     iigg getRing ring_def
                   1836:
1.6       takayama 1837:     getOptions /isSameIdeal_h.opt set
                   1838:     (grade) (module1v) switch_function
                   1839:     [(Homogenize_vec) 0] system_variable
1.5       takayama 1840:     /ans 1 def
                   1841:     iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
                   1842:     /iigg set
                   1843:     jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
                   1844:     /jjgg set
                   1845:
1.8       takayama 1846:     gb.verbose { (Comparing) message iigg message (and) message jjgg message }
                   1847:     {  } ifelse
1.5       takayama 1848:     gb.verbose { ( ii < jj ?) messagen } {  } ifelse
                   1849:     iigg length /n set
                   1850:     0 1 n 1 sub {
                   1851:       /k set
                   1852:       iigg  k get
                   1853:       jjgg  reduction 0 get
                   1854:       (0). eq not { /ans 0 def /LLL.isSame_h goto} {  } ifelse
                   1855:       gb.verbose { (o) messagen } {  } ifelse
                   1856:     } for
                   1857:     gb.verbose { ( jj < ii ?) messagen } {  } ifelse
                   1858:     jjgg length /n set
                   1859:     0 1 n 1 sub {
                   1860:       /k set
                   1861:       jjgg k get
                   1862:       iigg reduction 0 get
                   1863:       (0). eq not { /ans 0 def /LLL.isSame_h goto} {  } ifelse
                   1864:       gb.verbose { (o) messagen } {  } ifelse
                   1865:     } for
                   1866:     /LLL.isSame_h
                   1867:     gb.verbose { ( Done) message } {  } ifelse
1.6       takayama 1868:     isSameIdeal_h.opt restoreOptions
1.5       takayama 1869:     /arg1 ans def
                   1870:   ] pop
                   1871:   popEnv
                   1872:   popVariables
                   1873:   arg1
                   1874: } def
                   1875: (isSameIdeal_h ) messagen-quiet
                   1876:
                   1877: [(isSameIdeal_h)
                   1878: [([ii jj vv] isSameIdeal_h bool)
                   1879:  (ii, jj : ideal, vv : variables)
                   1880:  (Note that ii and jj will be compared in the ring)
                   1881:  (of homogenized differential operators. Each element of the vector must be)
                   1882:  (homogenized.)
                   1883:  $Example 1: [ [(x Dx - h^2) (Dx^2)]  [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
                   1884:  $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
                   1885:  $       [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
                   1886: ]] putUsages
                   1887:
1.15      takayama 1888: /gb.reduction {
                   1889:   /arg2 set
                   1890:   /arg1 set
                   1891:   [/in-gb.reduction /gbasis /flist /ans /gbasis2
                   1892:   ] pushVariables
                   1893:   [(CurrentRingp) (KanGBmessage)] pushEnv
                   1894:   [
                   1895:      /gbasis arg2  def
                   1896:      /flist  arg1  def
                   1897:      gbasis 0 get tag 6 eq { }
                   1898:      { (gb.reduction: the second argument must be a list of lists) error }
                   1899:      ifelse
                   1900:
                   1901:      gbasis length 1 eq {
                   1902:        gbasis getRing ring_def
                   1903:        /gbasis2 gbasis 0 get def
                   1904:      } {
                   1905:        [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22      takayama 1906:        /gbasis2 gbasis 0 get ___ def
1.15      takayama 1907:      } ifelse
                   1908:
1.5       takayama 1909:
1.22      takayama 1910:      flist ___ /flist set
1.15      takayama 1911:      flist tag 6 eq {
                   1912:        flist { gbasis2 reduction } map /ans set
                   1913:      }{
                   1914:        flist gbasis2 reduction /ans set
                   1915:      } ifelse
                   1916:      /arg1 ans def
                   1917:
                   1918:   ] pop
                   1919:   popEnv
                   1920:   popVariables
                   1921:   arg1
                   1922: } def
                   1923:
1.20      takayama 1924: /gb.reduction_noh {
                   1925:   /arg2 set
                   1926:   /arg1 set
                   1927:   [/in-gb.reduction_noh /gbasis /flist /ans /gbasis2
                   1928:   ] pushVariables
                   1929:   [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
                   1930:   [
                   1931:      /gbasis arg2  def
                   1932:      /flist  arg1  def
                   1933:      gbasis 0 get tag 6 eq { }
                   1934:      { (gb.reduction_noh: the second argument must be a list of lists) error }
                   1935:      ifelse
                   1936:
                   1937:      gbasis length 1 eq {
                   1938:        gbasis getRing ring_def
                   1939:        /gbasis2 gbasis 0 get def
                   1940:      } {
                   1941:        [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22      takayama 1942:        /gbasis2 gbasis 0 get ___ def
1.20      takayama 1943:      } ifelse
                   1944:
                   1945:
1.22      takayama 1946:      flist ___ /flist set
1.20      takayama 1947:      [(Homogenize) 0] system_variable
                   1948:      flist tag 6 eq {
                   1949:        flist { gbasis2 reduction } map /ans set
                   1950:      }{
                   1951:        flist gbasis2 reduction /ans set
                   1952:      } ifelse
                   1953:      /arg1 ans def
                   1954:
                   1955:   ] pop
                   1956:   popEnv
                   1957:   popVariables
                   1958:   arg1
                   1959: } def
                   1960:
1.15      takayama 1961: /gb.reduction.test {
                   1962:   [
                   1963:     [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
                   1964:     (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
                   1965:   gb /gg set
                   1966:
                   1967:   ((h-x-y)*Dx) [gg 0 get] gb.reduction /gg2 set
                   1968:   gg2 message
                   1969:   (-----------------------------) message
                   1970:
                   1971:     [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )]
                   1972:       (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
                   1973:    ((h-x-y)*Dx) ggg gb.reduction /gg4 set
                   1974:    gg4 message
                   1975:   (-----------------------------) message
                   1976:   [gg2 gg4]
                   1977: } def
                   1978: [(gb.reduction)
                   1979: [ (f basis gb.reduction r)
                   1980:   (f is reduced by basis by the normal form algorithm.)
                   1981:   (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
                   1982:   (r is the return value format of reduction;)
                   1983:   (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
                   1984:   (basis is given in the argument format of gb.)
1.16      takayama 1985:   $h[1,1](D)-homogenization is used.$
1.15      takayama 1986:   (cf. reduction, gb, ecartd.gb, gb.reduction.test )
                   1987:   $Example:$
                   1988:   $ [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )] $
                   1989:   $   (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
                   1990:   $ ((h-x-y)^2*Dx*Dy) ggg gb.reduction :: $
1.20      takayama 1991: ]] putUsages
                   1992:
                   1993: [(gb.reduction_noh)
                   1994: [ (f basis gb.reduction_noh r)
                   1995:   (f is reduced by basis by the normal form algorithm.)
                   1996:   (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
                   1997:   (r is the return value format of reduction;)
                   1998:   (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
                   1999:   (basis is given in the argument format of gb.)
                   2000:   (cf. gb.reduction, gb )
                   2001:   $Example:$
                   2002:   $ [[( 2*Dx + 1 ) ( 2*Dy + 1 )] $
                   2003:   $   (x,y) [[(Dx) 1 (Dy) 1]]] /ggg set $
                   2004:   $ ((1-x-y)^2*Dx*Dy) ggg gb.reduction_noh :: $
1.15      takayama 2005: ]] putUsages
1.1       maekawa  2006:
                   2007: ( ) message-quiet ;
                   2008:
1.21      takayama 2009: /hol_loaded 1 def
1.1       maekawa  2010:
                   2011:
                   2012:
                   2013:

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