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

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

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