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

Annotation of OpenXM/src/kan96xx/Doc/restall.sm1, Revision 1.1.1.1

1.1       maekawa     1: %% changed the following names.
                      2: %% complement ---> complement.oaku
                      3: %% syz ==> o.syz
                      4:
                      5: %%%%%%%%%%%%%%%%%%%%%%% restall.sm1 (Version 19980415) %%%%%%%%%%%%%%%%%%%%%%%
                      6: (restall.sm1 ... compute all the cohomology groups of the restriction) message-quiet
                      7: (                of a D-module to tt = (t_1,...,t_d) = (0,...,0).) message-quiet
                      8: (non-Schreyer Version: 19980415 by T.Oaku) message-quiet
                      9: (usage: [(P1)...] [(t1)...] bfm --> the b-function) message-quiet
                     10: (       [(P1)...] [(t1)...] k0 k1 deg restall --> cohomologies of restriction)
                     11: message-quiet
                     12: (       [(P1)...] [(t1)...] intbfm --> the b-function for integration) message-quiet
                     13: (       [(P1)...] [(t1)...] k0 k1 deg intall --> cohomologies of integration)
                     14: message-quiet
                     15: % History: Oct.23, Nov.1, Nov.11: bug fix for m2vec, Nov.13: bug fix for psi1
                     16: % Apr.15,1998 bug fix for truncation from below
                     17: %%%%%%%%%%%%%%%%%%%%%%%%%%%% Global variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                     18: /BFvarlist %% Set all the variables (except s and the parameters) here.
                     19:  [(x) (y) (z)]
                     20: def
                     21: /BFparlist %% Set the parameters here if any.
                     22:  [ ]
                     23: def
                     24: /BFs (s) def
                     25: /BFth (s) def
                     26: /BFu (u) def
                     27: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                     28: %% [(P1) ...] [(t1) ...] bfm --> the b-function along t1 = ... = 0.
                     29: %% the variables and parameters are assumed to be given by the global variables
                     30: %% BFvarlist and BFparlist
                     31:
                     32: /bfm {
                     33:   /arg2 set
                     34:   /arg1 set
                     35:   [ /ff /tt ] pushVariables
                     36:   [
                     37:     arg1 /ff set
                     38:     arg2 /tt set
                     39:     ff tt bfm1 bfm2 {(string) dc} map /arg1 set
                     40:   ] pop
                     41:   popVariables
                     42:   arg1
                     43: } def
                     44:
                     45: /bfm1 {
                     46:   /arg2 set
                     47:   /arg1 set
                     48:   [
                     49:     /ff /tt /d /nff /gg /gg0 /xvarlist /n /i /xtvarlist /xtusvarlist
                     50:     /sxtusvarlist /allvarlist /gg1 /si /gg1 /j /ui /uu /ss /su1
                     51:     /input /ggpsi0 /ggpsi /dxvarlist /sxvarlist /ggpsi1
                     52:     /sxallvarlist /sxpoly_weight /hh /bb /us_weight
                     53:   ] pushVariables
                     54:   [
                     55:     arg1 /ff set
                     56:     arg2 /tt set
                     57:     tt length /d set
                     58:     ff length /nff set
                     59:
                     60:     ff tt fwd /gg set
                     61:     gg {fw_symbol (string) dc} map /gg0 set
                     62:
                     63:     BFvarlist tt setminus /xvarlist set
                     64:     xvarlist length /n set
                     65:
                     66:     /uu                       %% uu = [u_1,...,u_d]
                     67:     [  1 1 d {/i set
                     68:         BFu i toString 2 cat_n
                     69:       } for
                     70:     ] def
                     71:     /ss                       %% ss = [s_1,...,s_d]
                     72:     [  1 1 d {/i set
                     73:         BFth i toString 2 cat_n
                     74:       } for
                     75:     ] def
                     76:
                     77:     tt xvarlist join /xtvarlist set
                     78:     uu ss join xtvarlist join /xtusvarlist set
                     79:     [BFth] xtusvarlist join /sxtusvarlist set
                     80:     sxtusvarlist BFparlist join /allvarlist set
                     81:
                     82:     sxtusvarlist setupDring
                     83:
                     84:     0 1 d 1 sub { /i set
                     85:       gg0 {tt i get fw_homogenize} map /gg1 set
                     86:       ss i get expand /si set
                     87:       gg1 {expand} map /gg1 set
                     88:       gg1 {[[BFs expand si]] replace} map /gg1 set
                     89:       gg1 {(string) dc} map /gg1 set
                     90:     } for
                     91:
                     92:     /us_weight [ [
                     93:       0 1 d 1 sub { /i set
                     94:         uu i get 1  ss i get 1
                     95:       } for ]
                     96:       [
                     97:         0 1 d 1 sub { /i set tt i get 1 } for
                     98:         0 1 n 1 sub { /j set
                     99:           xvarlist j get xtoDx 1
                    100:           xvarlist j get 1
                    101:         } for
                    102:       ] ] def
                    103:
                    104:     [ allvarlist listtostring ring_of_differential_operators
                    105:       us_weight weight_vector 0 ] define_ring
                    106:
                    107:     gg1 {expand} map /gg1 set
                    108:
                    109:     /su1 [ 0 1 d 1 sub { /i set  %% [(1-s1*u1).,...]
                    110:       ss i get expand /si set
                    111:       uu i get expand /ui set
                    112:       si ui mul (1). sub
                    113:       } for ] def
                    114:
                    115:     su1 gg1 join /input set
                    116:     input {[[(h). (1).]] replace homogenize} map /input set
                    117:     [input] groebner 0 get {[[(h). (1).]] replace} map /gg set
                    118:     gg uu eliminatev /gg set
                    119:     gg ss eliminatev /gg set
                    120:     gg reducedBase /gg set
                    121:
                    122:     gg /ggpsi0 set
                    123:     0 1 d 1 sub { /i set
                    124:       ggpsi0 {tt i get fw_psi} map /ggpsi0 set
                    125:       ss i get expand /si set
                    126:       ggpsi0 {[[BFth expand si]] replace} map /ggpsi0 set
                    127:     } for
                    128:     ggpsi0 {(string) dc} map /ggpsi set
                    129:
                    130:     xvarlist {xtoDx} map /dxvarlist set
                    131:     ss xvarlist join /sxvarlist set
                    132:     sxvarlist setupDring
                    133:
                    134:     ggpsi {expand [[(h). (1).]] replace homogenize} map /ggpsi set
                    135:     [ggpsi] groebner 0 get /ggpsi set
                    136:     ggpsi dxvarlist eliminatev /ggpsi1 set
                    137:     ggpsi1 {(string) dc} map /ggpsi1 set
                    138:
                    139:     /sxpoly_weight [
                    140:       [ 0 1 n 1 sub {/i set xvarlist i get 1} for ]
                    141:       [ 0 1 d 1 sub {/i set ss i get 1} for ]
                    142:     ] def
                    143:
                    144:     sxvarlist BFparlist join /sxallvarlist set
                    145:     [ sxallvarlist listtostring ring_of_polynomials
                    146:       sxpoly_weight weight_vector 0 ] define_ring
                    147:     ggpsi1 {expand} map /ggpsi1 set ;
                    148:     [ggpsi1] groebner 0 get {[[(h). (1).]] replace} map /hh set
                    149:     hh xvarlist eliminatev /bb set
                    150:     [bb {(string) dc} map ss] /arg1 set
                    151:   ] pop
                    152:   popVariables
                    153:   arg1
                    154: } def
                    155:
                    156: /bfm2 {
                    157:   /arg1 set
                    158:   [ /ff /ss /d /sspoly_weight /ssallvarlist /si /hh ] pushVariables
                    159:   [
                    160:     arg1 0 get /ff set
                    161:     arg1 1 get /ss set
                    162:     ss length /d set
                    163:
                    164:     /sspoly_weight [
                    165:       [ 0 1 d 1 sub {/i set ss i get 1} for ]
                    166:     ] def
                    167:
                    168:     [BFth] ss join BFparlist join /ssallvarlist set
                    169:     [ ssallvarlist listtostring ring_of_polynomials
                    170:       sspoly_weight weight_vector 0 ] define_ring
                    171:     ff {expand homogenize} map /ff set ;
                    172:     BFth expand /si set
                    173:     1 1 d 1 sub {/i set
                    174:       si << ss i get expand >> sub /si set
                    175:     } for
                    176:     ff {[[ss 0 get expand  si]] replace} map /ff set
                    177:     [ff] groebner 0 get {[[(h). (1).]] replace} map /hh set
                    178:     hh ss eliminatev /arg1 set
                    179:   ] pop
                    180:   popVariables
                    181:   arg1
                    182: } def
                    183:
                    184: %% V-Groebner basis by V-filtration (using the variable s)
                    185: /fwd {
                    186:  /arg2 set  %% bftt
                    187:  /arg1 set  %% BFequations
                    188:  [ /bfs /bftt /bfh /bf1 /ff /n /i /d /GG /gbase /o.syz
                    189:    /BFDvarlist /BFs_weight ] pushVariables
                    190:  [
                    191:   /ff arg1 def
                    192:   /bftt arg2 def
                    193:   /BFallvarlist
                    194:     [ BFs ] BFvarlist join BFparlist join
                    195:   def
                    196:   BFvarlist length /n set
                    197:   BFvarlist {xtoDx} map /BFDvarlist set
                    198:   /BFs_weight
                    199:     [ [ BFs 1 ]
                    200:       [ 0 1 n 1 sub
                    201:           { /i set BFDvarlist i get 1 }
                    202:         for
                    203:         0 1 n 1 sub
                    204:           { /i set BFvarlist i get 1 }
                    205:         for ]
                    206:     ] def
                    207:
                    208:   [ BFallvarlist listtostring ring_of_differential_operators
                    209:     BFs_weight weight_vector
                    210:   0] define_ring  /BFring set
                    211:
                    212:   /bfh  (h) BFring ,, def
                    213:   /bfs  BFs BFring ,, def
                    214:   /bf1  (1) BFring ,, def
                    215:   ff { bftt fwm_homogenize } map /ff set
                    216:   ff {expand} map /ff set
                    217:   ff {[[bfh bf1]] replace} map {homogenize} map /ff set
                    218:   [ff] groebner 0 get reducedBase /gbase set
                    219:   gbase /arg1 set
                    220:   ] pop
                    221:  popVariables
                    222:  arg1
                    223: } def
                    224:
                    225: %% The "b-function" w.r.t. (Dt1),...
                    226: %% (for integration w.r.t. (t1),...
                    227: %% [(P1)...] [(t1)...] intbfm
                    228:
                    229: /intbfm {
                    230:   /arg2 set /arg1 set
                    231:   [ ] pushVariables
                    232:   [
                    233:     arg1 /ff set
                    234:     arg2 /tt set
                    235:     BFvarlist setupDring
                    236:     ff {tt fourier} map /gg set
                    237:     gg tt bfm /arg1 set
                    238:   ] pop
                    239:   popVariables
                    240:   arg1
                    241: } def
                    242:
                    243: /intall {
                    244:   /arg5 set %% degmax
                    245:   /arg4 set %% k1
                    246:   /arg3 set %% k0
                    247:   /arg2 set %% [(t1) ... (td)]
                    248:   /arg1 set %% BFequations
                    249:   [ /ff /bftt /k0 /k1 /degmax /ffdx ] pushVariables
                    250:   [
                    251:     /ff arg1 def  /bftt arg2 def  /k0 arg3 def  /k1 arg4 def
                    252:     /degmax arg5 def
                    253:     BFvarlist setupDring
                    254:     ff {bftt fourier} map /ffdx set
                    255:     ffdx bftt k0 k1 degmax restall /arg1 set
                    256:   ] pop
                    257:   popVariables
                    258:   arg1
                    259: } def
                    260:
                    261: /intall1 {
                    262:   /arg5 set %% degmax
                    263:   /arg4 set %% k1
                    264:   /arg2 set %% [(t1) ... (td)]
                    265:   /arg1 set %% BFequations
                    266:   [ /ff /bftt /k0 /k1 /degmax /ffdx ] pushVariables
                    267:   [
                    268:     /ff arg1 def  /bftt arg2 def  /k1 arg4 def
                    269:     /degmax arg5 def
                    270:     BFvarlist setupDring
                    271:     ff {bftt fourier} map /ffdx set
                    272:     ffdx bftt k1 degmax restall1 /arg1 set
                    273:   ] pop
                    274:   popVariables
                    275:   arg1
                    276: } def
                    277:
                    278: %% (P) [(t_1),...,(t_d)] fourier
                    279: /fourier {
                    280:   /arg2 set /arg1 set
                    281:   [ /P /tt /d /i] pushVariables
                    282:   [
                    283:      arg1 /P set
                    284:      arg2 /tt set
                    285:      tt length /d set
                    286:      0 1 d 1 sub {/i set
                    287:        P << tt i get >> fourier1 /P set
                    288:      } for
                    289:      P /arg1 set
                    290:   ] pop
                    291:   popVariables
                    292:   arg1
                    293: } def
                    294:
                    295: %% (P) (t) fourier :  t --> -Dt, Dt --> t
                    296: /fourier1 {
                    297:   /arg2 set /arg1 set
                    298:   [/P /bft /bfDt /P /bftv /bfDtv /Pcoefs /degs /coefs /m /PP /i /ki /ci
                    299:     ] pushVariables
                    300:   [
                    301:     arg1 /P set
                    302:     arg2 /bft set
                    303:     bft xtoDx /bfDt set
                    304:     P expand /P set
                    305:     bft expand /bftv set
                    306:     bfDt expand /bfDtv set
                    307:     P bfDtv coefficients /Pcoefs set
                    308:     Pcoefs 0 get /degs set
                    309:     Pcoefs 1 get /coefs set
                    310:     coefs length /m set
                    311:     (0). /PP set
                    312:     0 1 m 1 sub { /i set
                    313:       degs i get /ki set
                    314:       coefs i get /ci set
                    315:       ci [[ bftv << (0). bfDtv sub >> ]] replace /ci set
                    316:       ci << bftv ki power >> mul /ci set
                    317:       PP ci add /PP set
                    318:     } for
                    319:     PP [[(h). (1).]] replace (string) dc /arg1 set
                    320:   ] pop
                    321:   popVariables
                    322:   arg1
                    323: } def
                    324:
                    325: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                    326: %% The cohomology groups of the restriction
                    327: %% [(P1)...] [(t1)...] k0 k1 degmax restall
                    328: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
                    329:
                    330: /restall {
                    331:   /arg5 set %% degmax
                    332:   /arg4 set %% k1
                    333:   /arg3 set %% k0
                    334:   /arg2 set %% [(t1) ... (td)]
                    335:   /arg1 set %% BFequations
                    336:   [
                    337:     /ff /bftt /k0 /k1 /degmax /syzlist /mveclist /cohomlist
                    338:     /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
                    339:     /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
                    340:     /psi1 /psi1ker /psi2image
                    341:     /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
                    342:     /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
                    343:   ] pushVariables
                    344:   [
                    345:     /ff arg1 def  /bftt arg2 def  /k0 arg3 def  /k1 arg4 def
                    346:     /degmax arg5 def
                    347:     bftt length /d set
                    348:   degmax 0 gt {
                    349:     (Computing a free resolution ... ) message
                    350:     ff bftt degmax syzygyV /GG set
                    351:     (A free resolution obtained.) message
                    352:   }{
                    353:     [[ff bftt fwd {[[BFs expand (1).]] replace (string) dc} map ] [ [ 0 ] ]]
                    354:     /GG set
                    355:   } ifelse
                    356:     GG 0 get /syzlist set
                    357:     GG 1 get /mveclist set
                    358:
                    359:     [ ] /cohomlist set
                    360:
                    361:   0 1 degmax {/ideg set
                    362:
                    363:     ideg 0 eq {
                    364:       [ (0) ] /gbase set
                    365:       [ 0 ] /m0vec set
                    366:       1 /r0 set
                    367:     }{
                    368:       syzlist  << ideg 1 sub >> get /gbase set
                    369:       m1vec /m0vec set
                    370:       r1 /r0 set
                    371:     } ifelse
                    372:     syzlist     ideg          get /o.syz   set
                    373:     mveclist    ideg          get /m1vec set
                    374:
                    375: %%                                       o.syz       gbase
                    376: %%                                D^{r2} --> D^{r1} --> D^{r0}
                    377: %% with weight vectors:           m2vec      m1vec      m0vec
                    378: %% which will induce a complex
                    379: %%                                     psi2              psi1
                    380: %%                        D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
                    381:
                    382:     gbase length /r1 set
                    383:     o.syz length /r2 set
                    384:
                    385:     ideg 0 eq {
                    386:       /syz1 [ 0 1 r2 1 sub {/i set
                    387:         [ o.syz i get ]
                    388:       } for ] def
                    389:       syz1 /o.syz set
                    390:     }{ } ifelse
                    391:
                    392: %% Computing the weight vector m2vec from m1vec and syz
                    393:   ideg degmax eq {
                    394:     /m2vec [
                    395:       0 1 r2 1 sub {/i set
                    396:         o.syz i get /syzi set
                    397:         0 /nonzero set
                    398:         0 1 r1 1 sub {/j set
                    399:           syzi j get expand /syzij set
                    400:           syzij (0). eq {  }{
                    401:             syzij bftt fwh_order  m1vec j get  add /maxtmp set
                    402:             nonzero 0 eq { maxtmp /max0 set }{
                    403:               maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
                    404:             } ifelse
                    405:             1 /nonzero set
                    406:           } ifelse
                    407:         } for
                    408:       max0 } for ] def
                    409:   }{
                    410:     mveclist << ideg 1 add >> get /m2vec set
                    411:   } ifelse
                    412:
                    413: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
                    414:     BFu /estr set
                    415:     /ee
                    416:       [ 1 1 d {/i set estr i toString 2 cat_n} for ]
                    417:     def
                    418:     [@@@.esymbol] ee join /eee set
                    419:
                    420: %% Setting up a ring that represents D_{Y->X}^{r1}
                    421:     eee length /neee set
                    422:     /eeemvec [ 1 1 neee {pop 1} for ] def
                    423:     eee [ ] BFvarlist eeemvec setupDringVshift
                    424:     bftt {xtoDx expand} map /bfDtt set
                    425:     [ ] /psi1 set
                    426:     [ ] /psi1index set
                    427:     [ ] /zerolist set
                    428:
                    429: %% converting gbase to a list of polynomials
                    430: %% Be careful to the current ring!
                    431:     ideg 2 lt {
                    432:       gbase {expand} map /gbase1 set
                    433:     }{
                    434:       /gbase1
                    435:         [ 0 1 r1 1 sub {/i set
                    436:             gbase i get {expand} map vector_to_poly
                    437:          } for ] def
                    438:       } ifelse
                    439:     gbase1 /gbase set
                    440:
                    441: %(ideg =) messagen ideg ::
                    442: %(Computing psi1) message
                    443: %%                        psi1
                    444: %% Computes  D_{Y->X}^{r1} -->  D_{Y->X}^{r0} induced by gbase
                    445: %% with weight  k0 - m1vec <= k <= k1 - m1vec
                    446:     0 1 r1 1 sub {/i set
                    447:       m1vec i get /m1i set
                    448:       ee {expand} map k0 m1i sub k1 m1i sub monomials /emonoi set
                    449:       bfDtt k0 m1i sub k1 m1i sub monomials /bfDttmonoi set
                    450:       emonoi length /nmono set
                    451:       0 1 nmono 1 sub {/j set
                    452:         @@@.esymbol expand i npower /eei set
                    453:         emonoi j get eei mul /eei set
                    454:         gbase i get /dtp set
                    455:         bfDttmonoi j get dtp mul /dtp set
                    456:         0 1 d 1 sub {/k set
                    457:           dtp [[bftt k get expand (0).]] replace /dtp set
                    458:           dtp [[bfDtt k get  ee k get expand]] replace /dtp set
                    459:         } for
                    460:         dtp [[(h). (1).]] replace /dtp set
                    461:         dtp << ee {expand} map >> m0vec k0 Vtruncate_below /dtp set
                    462:         dtp (0). eq {
                    463:           zerolist [eei] join /zerolist set
                    464:         }{
                    465:           psi1index [eei] join /psi1index set
                    466:           psi1 [dtp] join /psi1 set
                    467:         } ifelse
                    468:       } for
                    469:     } for
                    470:
                    471: %(ideg =) messagen ideg ::
                    472: %(psi1 obtained.) message
                    473: %(Computing psi1ker) message
                    474:
                    475: %% Computing psi1ker := Ker psi1 :
                    476:     psi1 length 0 eq {
                    477:       [ ] /psi1ker set
                    478:     }{
                    479:       psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
                    480:       [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
                    481:       psi1kervec length /pn set
                    482:       psi1index length /pn0 set
                    483:       [ ] /psi1ker set
                    484:       0 1 pn 1 sub {/i set
                    485:         psi1kervec i get /psi1i set
                    486:         (0). /psi1keri set
                    487:         0 1 pn0 1 sub {/j set
                    488:           psi1index j get psi1i j get mul psi1keri add /psi1keri set
                    489:         } for
                    490:         psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
                    491:       } for
                    492:     } ifelse
                    493:     zerolist psi1ker join /psi1ker set
                    494: % Is it all right to use reducedBase here?
                    495: %    psi1ker length 0 eq { }{
                    496: %      psi1ker reducedBase /psi1ker set
                    497: %    } ifelse
                    498: %(ideg =) messagen ideg ::
                    499: %(psi1ker obtained.) message
                    500: %(Computing psi2image ...) message
                    501:
                    502: %%                                     psi2
                    503: %% Computes the image of  D_{Y->X}^{r2} -->  D_{Y->X}^{r1} induced by syz
                    504: %% with weight  k0 - m2vec <= k <= k1 - m2vec
                    505:     /psi2image [
                    506:       0 1 r2 1 sub {/i set
                    507:         o.syz i get {expand} map vector_to_poly /syzi set
                    508:         m2vec i get /m2i set
                    509:         bfDtt k0 m2i sub k1 m2i sub monomials /bfDttmonoi set
                    510:         bfDttmonoi length /nmono set
                    511:         0 1 nmono 1 sub {/j set
                    512:           bfDttmonoi j get syzi mul /syzij set
                    513:           0 1 d 1 sub {/k set
                    514:             syzij [[bftt k get expand (0).]] replace /syzij set
                    515:             syzij [[bfDtt k get ee k get expand]] replace /syzij set
                    516:           } for
                    517:           syzij [[(h). (1).]] replace /syzij set
                    518:           syzij << ee {expand} map >> m1vec k0 Vtruncate_below /syzij set
                    519:           syzij (0). eq { }{syzij} ifelse
                    520:         } for
                    521:       } for
                    522:     ] def
                    523:
                    524: %(psi2image obtained.) message
                    525: %(ideg = ) messagen ideg ::
                    526: %(psi1ker = ) message psi1ker ::
                    527: %(psi2image =) message psi2image ::
                    528:
                    529: %% Computes the quotient module  psi1ker/psi2image
                    530:     psi1ker length /nker set
                    531:     nker 0 eq {
                    532:       [0 [ ]] /cohom set
                    533:     }{
                    534:       psi2image length /nim set
                    535:       psi1ker psi2image join /psiall set
                    536:       psiall {homogenize} map /psiall set
                    537:       [psiall [(needSyz)]] groebner 2 get /psisyz set
                    538:       psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
                    539:       cohom {remove0} map /cohom set
                    540:       cohom length 0 eq {
                    541:         [nker [ ]] /cohom set
                    542:       }{
                    543:         cohom {homogenize} map /cohom set
                    544:         [cohom] groebner 0 get reducedBase /cohom set
                    545:         cohom {[[(h). (1).]] replace} map /cohom set
                    546:         [nker cohom] trimModule /cohom set
                    547:       } ifelse
                    548:     } ifelse
                    549:     cohomlist [cohom] join /cohomlist set
                    550:     0 ideg sub print (-th cohomology:  ) messagen
                    551:     cohom ::
                    552:   } for
                    553:
                    554:   cohomlist /arg1 set
                    555:   ] pop
                    556:   popVariables
                    557:   arg1
                    558: } def
                    559:
                    560: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                    561: %% The cohomology groups of the restriction without truncation from below
                    562: %% [(P1)...] [(t1)...] k1 degmax restall
                    563: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
                    564:
                    565: /restall1 {
                    566:   /arg5 set %% degmax
                    567:   /arg4 set %% k1
                    568:   /arg2 set %% [(t1) ... (td)]
                    569:   /arg1 set %% BFequations
                    570:   [
                    571:     /ff /bftt /k1 /degmax /syzlist /mveclist /cohomlist
                    572:     /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
                    573:     /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
                    574:     /psi1 /psi1ker /psi2image
                    575:     /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
                    576:     /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
                    577:   ] pushVariables
                    578:   [
                    579:     /ff arg1 def  /bftt arg2 def  /k1 arg4 def  /degmax arg5 def
                    580:     bftt length /d set
                    581:   degmax 0 gt {
                    582:     (Computing a free resolution ... ) message
                    583:     ff bftt degmax syzygyV /GG set
                    584:     (A free resolution obtained.) message
                    585:   }{
                    586:     [[ff bftt fwd {[[BFs expand (1).]] replace (string) dc} map ] [ [ 0 ] ]]
                    587:     /GG set
                    588:   } ifelse
                    589:     GG 0 get /syzlist set
                    590:     GG 1 get /mveclist set
                    591:
                    592:     [ ] /cohomlist set
                    593:
                    594:   0 1 degmax {/ideg set
                    595:
                    596:     ideg 0 eq {
                    597:       [ (0) ] /gbase set
                    598:       [ 0 ] /m0vec set
                    599:       1 /r0 set
                    600:     }{
                    601:       syzlist  << ideg 1 sub >> get /gbase set
                    602:       m1vec /m0vec set
                    603:       r1 /r0 set
                    604:     } ifelse
                    605:     syzlist     ideg          get /o.syz   set
                    606:     mveclist    ideg          get /m1vec set
                    607:
                    608: %%                                       o.syz       gbase
                    609: %%                                D^{r2} --> D^{r1} --> D^{r0}
                    610: %% with weight vectors:           m2vec      m1vec      m0vec
                    611: %% which will induce a complex
                    612: %%                                     psi2              psi1
                    613: %%                        D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
                    614:
                    615:     gbase length /r1 set
                    616:     o.syz length /r2 set
                    617:
                    618:     ideg 0 eq {
                    619:       /syz1 [ 0 1 r2 1 sub {/i set
                    620:         [ o.syz i get ]
                    621:       } for ] def
                    622:       syz1 /o.syz set
                    623:     }{ } ifelse
                    624:
                    625: %% Computing the weight vector m2vec from m1vec and syz
                    626:   ideg degmax eq {
                    627:     /m2vec [
                    628:       0 1 r2 1 sub {/i set
                    629:         o.syz i get /syzi set
                    630:         0 /nonzero set
                    631:         0 1 r1 1 sub {/j set
                    632:           syzi j get expand /syzij set
                    633:           syzij (0). eq {  }{
                    634:             syzij bftt fwh_order  m1vec j get  add /maxtmp set
                    635:             nonzero 0 eq { maxtmp /max0 set }{
                    636:               maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
                    637:             } ifelse
                    638:             1 /nonzero set
                    639:           } ifelse
                    640:         } for
                    641:       max0 } for ] def
                    642:   }{
                    643:     mveclist << ideg 1 add >> get /m2vec set
                    644:   } ifelse
                    645:
                    646: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
                    647:     BFu /estr set
                    648:     /ee
                    649:       [ 1 1 d {/i set estr i toString 2 cat_n} for ]
                    650:     def
                    651:     [@@@.esymbol] ee join /eee set
                    652:
                    653: %% Setting up a ring that represents D_{Y->X}^{r1}
                    654:     eee length /neee set
                    655:     /eeemvec [ 1 1 neee {pop 1} for ] def
                    656:     eee [ ] BFvarlist eeemvec setupDringVshift
                    657:     bftt {xtoDx expand} map /bfDtt set
                    658:     [ ] /psi1 set
                    659:     [ ] /psi1index set
                    660:     [ ] /zerolist set
                    661:
                    662: %% converting gbase to a list of polynomials
                    663: %% Be careful to the current ring!
                    664:     ideg 2 lt {
                    665:       gbase {expand} map /gbase1 set
                    666:     }{
                    667:       /gbase1
                    668:         [ 0 1 r1 1 sub {/i set
                    669:             gbase i get {expand} map vector_to_poly
                    670:          } for ] def
                    671:       } ifelse
                    672:     gbase1 /gbase set
                    673:
                    674: %(ideg =) messagen ideg ::
                    675: %(Computing psi1) message
                    676: %%                        psi1
                    677: %% Computes  D_{Y->X}^{r1} -->  D_{Y->X}^{r0} induced by gbase
                    678: %% with weight  k <= k1 - m1vec
                    679:     0 1 r1 1 sub {/i set
                    680:       m1vec i get /m1i set
                    681:       ee {expand} map  0  k1 m1i sub monomials /emonoi set
                    682:       bfDtt  0  k1 m1i sub monomials /bfDttmonoi set
                    683:       emonoi length /nmono set
                    684:       0 1 nmono 1 sub {/j set
                    685:         @@@.esymbol expand i npower /eei set
                    686:         emonoi j get eei mul /eei set
                    687:         gbase i get /dtp set
                    688:         bfDttmonoi j get dtp mul /dtp set
                    689:         0 1 d 1 sub {/k set
                    690:           dtp [[bftt k get expand (0).]] replace /dtp set
                    691:           dtp [[bfDtt k get  ee k get expand]] replace /dtp set
                    692:         } for
                    693:         dtp [[(h). (1).]] replace /dtp set
                    694:         dtp (0). eq {
                    695:           zerolist [eei] join /zerolist set
                    696:         }{
                    697:           psi1index [eei] join /psi1index set
                    698:           psi1 [dtp] join /psi1 set
                    699:         } ifelse
                    700:       } for
                    701:     } for
                    702:
                    703: %(ideg =) messagen ideg ::
                    704: %(psi1 obtained.) message
                    705: %(Computing psi1ker) message
                    706:
                    707: %% Computing psi1ker := Ker psi1 :
                    708:     psi1 length 0 eq {
                    709:       [ ] /psi1ker set
                    710:     }{
                    711:       psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
                    712:       [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
                    713:       psi1kervec length /pn set
                    714:       psi1index length /pn0 set
                    715:       [ ] /psi1ker set
                    716:       0 1 pn 1 sub {/i set
                    717:         psi1kervec i get /psi1i set
                    718:         (0). /psi1keri set
                    719:         0 1 pn0 1 sub {/j set
                    720:           psi1index j get psi1i j get mul psi1keri add /psi1keri set
                    721:         } for
                    722:         psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
                    723:       } for
                    724:     } ifelse
                    725:     zerolist psi1ker join /psi1ker set
                    726: % Is it all right to use reducedBase here?
                    727: %    psi1ker length 0 eq { }{
                    728: %      psi1ker reducedBase /psi1ker set
                    729: %    } ifelse
                    730: %(ideg =) messagen ideg ::
                    731: %(psi1ker obtained.) message
                    732: %(Computing psi2image ...) message
                    733:
                    734: %%                                     psi2
                    735: %% Computes the image of  D_{Y->X}^{r2} -->  D_{Y->X}^{r1} induced by syz
                    736: %% with weight  m2vec <= k <= k1 - m2vec
                    737:     /psi2image [
                    738:       0 1 r2 1 sub {/i set
                    739:         o.syz i get {expand} map vector_to_poly /syzi set
                    740:         m2vec i get /m2i set
                    741:         bfDtt  0  k1 m2i sub monomials /bfDttmonoi set
                    742:         bfDttmonoi length /nmono set
                    743:         0 1 nmono 1 sub {/j set
                    744:           bfDttmonoi j get syzi mul /syzij set
                    745:           0 1 d 1 sub {/k set
                    746:             syzij [[bftt k get expand (0).]] replace /syzij set
                    747:             syzij [[bfDtt k get ee k get expand]] replace /syzij set
                    748:           } for
                    749:           syzij [[(h). (1).]] replace /syzij set
                    750:           syzij (0). eq { }{syzij} ifelse
                    751:         } for
                    752:       } for
                    753:     ] def
                    754:
                    755: %(psi2image obtained.) message
                    756: %(ideg = ) messagen ideg ::
                    757: %(psi1ker = ) message psi1ker ::
                    758: %(psi2image =) message psi2image ::
                    759:
                    760: %% Computes the quotient module  psi1ker/psi2image
                    761:     psi1ker length /nker set
                    762:     nker 0 eq {
                    763:       [0 [ ]] /cohom set
                    764:     }{
                    765:       psi2image length /nim set
                    766:       psi1ker psi2image join /psiall set
                    767:       psiall {homogenize} map /psiall set
                    768:       [psiall [(needSyz)]] groebner 2 get /psisyz set
                    769:       psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
                    770:       cohom {remove0} map /cohom set
                    771:       cohom length 0 eq {
                    772:         [nker [ ]] /cohom set
                    773:       }{
                    774:         cohom {homogenize} map /cohom set
                    775:         [cohom] groebner 0 get reducedBase /cohom set
                    776:         cohom {[[(h). (1).]] replace} map /cohom set
                    777:         [nker cohom] trimModule /cohom set
                    778:       } ifelse
                    779:     } ifelse
                    780:     cohomlist [cohom] join /cohomlist set
                    781:     0 ideg sub print (-th cohomology:  ) messagen
                    782:     cohom ::
                    783:   } for
                    784:
                    785:   cohomlist /arg1 set
                    786:   ] pop
                    787:   popVariables
                    788:   arg1
                    789: } def
                    790:
                    791:
                    792: % Reduce the module representation  A^r/[P_1,...,P_m]
                    793: % by trimming unnecessary higher degree terms
                    794: % [r [P1,...,p_m]] reduceModule --> [r1, [Q_1,...,Q_m1]]
                    795: % The current ring must have @@@.esymbol as the highest degree variable.
                    796: /trimModule {
                    797:   /arg1 set
                    798:   [ /r /ff /ffins /nff /i /ei /j /fj /fjin /qij /fjdeg ] pushVariables
                    799:   [
                    800:     arg1 0 get /r set
                    801:     arg1 1 get /ff set
                    802:     ff {homogenize} map /ff set
                    803:     [ff] groebner 0 get reducedBase {[[(h). (1).]] replace} map /ff set
                    804:     ff {init [[(h). (1).]] replace} map /ffins set
                    805:     ff length /nff set
                    806:
                    807:     r 1 sub -1 0 {/i set
                    808:       @@@.esymbol . i npower /ei set
                    809:       0 1 nff 1 sub {/j set
                    810:         0 /eifound set
                    811:         ff j get /fj set
                    812:         ffins j get /fjin set
                    813:         ei [fjin] reduction 0 get /qij set
                    814:         qij (0). eq {
                    815:           1 /eifound set
                    816:           1 break
                    817:         }{ } ifelse
                    818:       } for
                    819:       eifound 0 eq break
                    820:     } for
                    821:     << eifound 1 eq >> << i 0 eq >> and {
                    822:       0 /r set
                    823:     }{
                    824:       i 1 add /r set
                    825:     } ifelse
                    826:     /gg [ 0 1 nff 1 sub {/j set
                    827:       ff j get /fj set
                    828:       fj @@@.esymbol . coefficients 0 get 0 get (integer) dc /fjdeg set
                    829:       fjdeg r lt {fj}{ } ifelse
                    830:     } for ] def
                    831:     [r gg] /arg1 set
                    832:   ] pop
                    833:   popVariables
                    834:   arg1
                    835: } def
                    836:
                    837: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                    838: % syzygyV.sm1 ... free resolution adapted to the V-filtration
                    839: %                 w.r.t. tt = (t_1,...,t_d) using h-homogenization.
                    840: % usage:  Equations tt deg syzygyV
                    841: % Oct. 21, 1997 ---  by T.Oaku
                    842: % Version 19971021
                    843: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                    844: %% Computing a free resolution compatible with the V-filtration
                    845: %% w.r.t. tt
                    846: /syzygyV {
                    847:   /arg3 set  %% rdegmax
                    848:   /arg2 set  %% tt
                    849:   /arg1 set  %% ff
                    850:   [
                    851:     /ff /tt /rdegmax /ttxx /aa /d /i /syzlist /rdeg
                    852:     /nff /mvec /estr /ee /edeg /dffi /r0 /syzpoly
                    853:     /syzi /syzij /syzpolyi /j
                    854:     /gbase /o.syz /syzlist /mvecist
                    855:     /r1 /m1vec /gbi /nonzero /gbijc /gbijd /gbij /maxtmp /max0 /gbase1
                    856:     /m0vec
                    857:   ] pushVariables
                    858:   [
                    859:     arg1 /ff set
                    860:     arg2 /tt set
                    861:     arg3 /rdegmax set
                    862:
                    863:     BFvarlist /ttxx set
                    864:     BFparlist /aa set
                    865:     tt length /d set
                    866:
                    867:     ttxx tt setminus /xx set
                    868:
                    869:     [ ] /syzlist set
                    870:     [ ] /mveclist set
                    871:
                    872: %% start the loop (the counter rdeg represents the degree of the resolution)
                    873:   0 1 rdegmax {/rdeg set
                    874:     ff length /nff set
                    875:
                    876: %%  r is the number of graduation variables;
                    877: %%  ff is a list of r0-vectors;
                    878: %%  r = r0 from the 2nd step (i.e. for rdeg >= 1);
                    879: %%  ee = [(u_1),...,(u_r)] or [@@@.esymbol] (in the 1st step).
                    880: %%  From
                    881: %%                     ff
                    882: %%  ... <--- D_X^{r0} <--- D_X^{nff},
                    883: %%  computes
                    884: %%                   gbase          syz
                    885: %%  ... <--- D_X^{r0} <--- D_X^{r1} <--- D_X^{r2}.
                    886: %%           m0vec         m1vec         m2vec
                    887:
                    888:     rdeg 0 eq {
                    889:       1 /r set
                    890:       [@@@.esymbol] /ee set
                    891:       [ 0 ] /mvec set
                    892:       [ 0 ] /mvec0 set
                    893:     }{
                    894:       r1 /r set
                    895:       r1 /r0 set
                    896:       m1vec /mvec set
                    897:       BFu /estr set
                    898:       /ee
                    899:         [ 1 1 r {/i set
                    900:           estr i toString 2 cat_n} for ]
                    901:       def
                    902:     } ifelse
                    903:
                    904: %%  (Set up a ring with mvec = ) messagen mvec ::
                    905:     ee tt xx mvec setupDringVshift
                    906:
                    907:     rdeg 0 eq {
                    908:       0 /edeg set
                    909:       0 1 nff 1 sub {/i set
                    910:         ff i get expand /ffi set
                    911:         ffi @@@.esymbol . coefficients 0 get 0 get (integer) dc /dffi set
                    912:         dffi edeg gt { dffi /edeg set}{ } ifelse
                    913:       } for
                    914:       edeg 1 add /r0 set     %% the input ff is a list of r0-vectors
                    915:       /m0vec [ 1 1 r0 {pop 0} for ] def
                    916:     }{
                    917:       o.syz length /nff set
                    918:       /syzpoly [ 0 1 nff 1 sub {/i set
                    919:         o.syz i get /syzi set
                    920:         (0). /syzpolyi set
                    921:         0 1 r1 1 sub {/j set
                    922:           syzi j get (string) dc expand /syzij set
                    923:           syzij << ee j get expand >> mul /syzij set
                    924:           syzpolyi syzij add /syzpolyi set
                    925:         } for
                    926:         syzpolyi
                    927:       } for ] def
                    928:       syzpoly {(string) dc} map /ff set
                    929:      } ifelse
                    930:
                    931:      mveclist [m0vec] join /mveclist set
                    932:
                    933:     ff {expand [[(h). (1).]] replace homogenize} map /ff set
                    934:     [ff] groebner 0 get reducedBase /gbase set
                    935:     [gbase [(needSyz)]] groebner 2 get /o.syz set
                    936:
                    937:     gbase length /r1 set
                    938:     o.syz length /nff set
                    939:
                    940:     0 rdeg eq {
                    941:       gbase {tt fwh_order} map /m1vec set
                    942:     }{
                    943:        /m1vec [
                    944:         0 1 r1 1 sub {/i set
                    945:           gbase i get /gbi set
                    946:           0 /nonzero set
                    947:           0 1 r0 1 sub {/j set
                    948:             gbi << ee j get expand >> coefficients /gbijc set
                    949:             gbijc 0 get 0 get (integer) dc /gbijd set
                    950:             gbijd 0 eq {  }{
                    951:               gbijc 1 get 0 get /gbij set
                    952:               gbij tt fwh_order  m0vec j get  add /maxtmp set
                    953:               nonzero 0 eq { maxtmp /max0 set }{
                    954:                 maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
                    955:               } ifelse
                    956:               1 /nonzero set
                    957:             } ifelse
                    958:           } for
                    959:         max0 } for ] def
                    960:     } ifelse
                    961:
                    962:     rdeg 0 eq {
                    963:       gbase {[[(h). (1).]] replace (string) dc} map /gbase1 set
                    964:     }{
                    965:       /gbase1 [ 0 1 r1 1 sub {/i set
                    966:         gbase i get /gbi set
                    967:         [ 0 1 r0 1 sub {/j set
                    968:           gbi << ee j get expand >> coefficients /gbijc set
                    969:           gbijc 0 get 0 get (integer) dc /gbijd set
                    970:           gbijd 0 eq { (0) }{
                    971:             gbijc 1 get 0 get [[(h). (1).]] replace (string) dc
                    972:           } ifelse
                    973:         } for ]
                    974:       } for ] def
                    975:     } ifelse
                    976:
                    977:     syzlist [gbase1] join /syzlist set
                    978:     m1vec /m0vec set
                    979:
                    980:     o.syz length 0 eq {
                    981:       syzlist [o.syz] join /syzlist set
                    982:       mveclist [m1vec] join /mveclist set
                    983:       1 break
                    984:     }{ } ifelse
                    985:   } for
                    986:   [syzlist mveclist] /arg1 set
                    987:   ] pop
                    988:   popVariables
                    989:   arg1
                    990: } def
                    991: %%%%%%%%%%%%%%%%%%%%%%%%% Libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                    992: %% set up a ring for the shifted V-weight given by mvec:
                    993: %% ee tt xx mvec setupDringVshift
                    994: %% ee = [e_1,...,e_r], tt = [t_1,...,t_d], xx = [x_1,...,x_n]
                    995: %% BFparlist = [a_1,...,a_m] (global variable)
                    996:
                    997: /setupDringVshift {
                    998:   /arg4 set /arg3 set /arg2 set /arg1 set
                    999:   [
                   1000:     /ee /xx /tt /aa /mvec /allvarlist /allDvarlist /r /n /m /d /i /j /k
                   1001: %    /Dee /Dxx /Dtt /Daa /dnm /rdnm /mat1 /mat2 /mat3 /mat4
                   1002:   ] pushVariables
                   1003:   [
                   1004:     arg1 /ee set
                   1005:     arg2 /tt set
                   1006:     arg3 /xx set
                   1007:     arg4 /mvec set
                   1008:     BFparlist /aa set
                   1009:
                   1010:     /allvarlist
                   1011:       ee tt join xx join aa join [(H)] join
                   1012:     def
                   1013:
                   1014:     ee length /r set
                   1015:     tt length /d set
                   1016:     xx length /n set
                   1017:     aa length /m set
                   1018:
                   1019:     d n add m add /dnm set
                   1020:     r dnm add /rdnm set
                   1021:
                   1022:     ee {xtoDx} map /Dee set
                   1023:     tt {xtoDx} map /Dtt set
                   1024:     xx {xtoDx} map /Dxx set
                   1025:     aa {xtoDx} map /Daa set
                   1026:
                   1027:     /allDvarlist
                   1028:       Dee Dtt join Dxx join Daa join [(h)] join
                   1029:     def
                   1030:
                   1031:     allvarlist reverse  /mat1 set allDvarlist reverse /mat2 set
                   1032:     [0 1 1 1  rdnm 1 add  1 1 1  dnm 1 add]                /mat3 set
                   1033:     [
                   1034:       [ 0 1 r 1 sub {/i set mvec i get} for %%[(e_1) mvec_1...(e_r) mvec_r
                   1035:         1 1 d {pop -1} for                  %% (t_1) -1 ...   (t_d) -1
                   1036:         1 1 n {pop 0 } for                  %% (x_1) 0  ...   (x_n) 0
                   1037:         1 1 m {pop 0 } for                  %% (a_1) 0  ...   (a_m) 0
                   1038:                    0                        %% (H) 0
                   1039:         1 1 r {pop 0 } for                  %% (E_1) 0  ...   (E_d) 0
                   1040:         1 1 d {pop 1 } for                  %% (Dt_1) 1 ...   (Dt_d) 1
                   1041:         1 1 n {pop 0 } for                  %% (Dx_1) 0 ...   (Dx_n) 0
                   1042:         1 1 m {pop 0 } for                  %% (Da_1) 0 ...   (Da_m) 0
                   1043:                    0                        %% (h) 0 ]
                   1044:       ]
                   1045:       [ 1 1 r {pop 1 } for                  %%[(e_1) 1  ...   (e_r) 1
                   1046:         1 1 d {pop 1 } for                  %% (t_1) 1  ...   (t_d) 1
                   1047:         1 1 n {pop 1 } for                  %% (x_1) 1  ...   (x_n) 1
                   1048:         1 1 m {pop 0 } for                  %% (a_1) 0  ...   (a_m) 0
                   1049:                    0                        %% (H) 0
                   1050:         1 1 r {pop 0 } for                  %% (E_1) 0  ...   (E_d) 0
                   1051:         1 1 d {pop 1 } for                  %% (Dt_1) 1 ...   (Dt_d) 1
                   1052:         1 1 n {pop 1 } for                  %% (Dx_1) 1 ...   (Dx_n) 1
                   1053:         1 1 m {pop 0 } for                  %% (Da_1) 0 ...   (Da_m) 0
                   1054:                    0                        %% (h) 0 ]
                   1055:       ]
                   1056:       [ 1 1 r {pop 0 } for                  %%[(e_1) 0  ...   (e_r) 0
                   1057:         1 1 d {pop 0 } for                  %% (t_1) 0  ...   (t_d) 0
                   1058:         1 1 n {pop 0 } for                  %% (x_1) 0  ...   (x_n) 0
                   1059:         1 1 m {pop 1 } for                  %% (a_1) 1  ...   (a_m) 1
                   1060:                    0                        %% (H) 0
                   1061:         1 1 r {pop 0 } for                  %% (E_1) 0  ...   (E_d) 0
                   1062:         1 1 d {pop 0 } for                  %% (Dt_1) 0 ...   (Dt_d) 0
                   1063:         1 1 n {pop 0 } for                  %% (Dx_1) 0 ...   (Dx_n) 0
                   1064:         1 1 m {pop 0 } for                  %% (Da_1) 0 ...   (Da_m) 0
                   1065:                    0                        %% (h) 0 ]
                   1066:       ]
                   1067:       rdnm 1 sub -1 0 {/i set
                   1068:         [
                   1069:           0 1 rdnm {pop 0} for
                   1070:           0 1 rdnm 1 sub {/j set
                   1071:             i j eq { -1 }{ 0 } ifelse
                   1072:           } for
                   1073:           0
                   1074:         ]
                   1075:       } for
                   1076:       rdnm 1 sub -1 0 {/i set
                   1077:         [
                   1078:           0 1 rdnm 1 sub {/j set
                   1079:             i j eq { -1 }{ 0 } ifelse
                   1080:           } for
                   1081:           0
                   1082:           0 1 rdnm {pop 0} for
                   1083:         ]
                   1084:       } for
                   1085:       [ 0 1 rdnm {pop 0} for
                   1086:         0 1 rdnm 1 sub {pop 0} for
                   1087:         1
                   1088:       ]
                   1089:     ]                                                          /mat4 set
                   1090:     mat1 mat2 mat3 mat4 [(mpMult) (diff)] set_up_ring@
                   1091:     (red@) (module1) switch_function
                   1092:     (grade) (module1) switch_function
                   1093:   ] pop
                   1094:   popVariables
                   1095: } def
                   1096:
                   1097: /remove0 {
                   1098:   /arg1 set
                   1099:   arg1 (0). eq
                   1100:   { } {arg1} ifelse
                   1101: } def
                   1102:
                   1103: %% return a list of monomials of degree m with m0 <= m <= m1
                   1104: %% usage: [(t1) ... (td)] m monomials
                   1105: /monomials {
                   1106:   /arg3 set  %% m1 (integer)
                   1107:   /arg2 set  %% m0 (integer)
                   1108:   /arg1 set  %% [(t1)., ... ,(td).] (polynonmial list)
                   1109:   [/bftt /m /m0 /m1 /d /i /mns0 /j /n /Mn /k ] pushVariables
                   1110:   [
                   1111:     arg1 /bftt set
                   1112:     arg2 /m0 set
                   1113:     arg3 /m1 set
                   1114:
                   1115:     bftt length /d set
                   1116:     d 0 eq { /mns [ ] def}{
                   1117:     d 1 eq {
                   1118:      /mns [ m0 1 m1 { /i set
                   1119:         i -1 gt {bftt 0 get i npower}{ } ifelse
                   1120:      } for ] def
                   1121:     }
                   1122:     {
                   1123:      /mns [ 0 1 m1 { /i set
                   1124:       bftt rest i i monomials /mns0 set
                   1125:       mns0 length /n set
                   1126:       0 1 n 1 sub { /j set
                   1127:         mns0 j get /Mn set
                   1128:           m0 i sub /m set
                   1129:           m 0 lt { 0 /m set }{ } ifelse
                   1130:           m 1 m1 i sub { /k set
                   1131:             << bftt 0 get k npower >> Mn mul
                   1132:           } for
                   1133:       } for
                   1134:      } for ] def
                   1135:     } ifelse } ifelse
                   1136:     mns /arg1 set
                   1137:   ] pop
                   1138:   popVariables
                   1139:   arg1
                   1140: } def
                   1141:
                   1142: %% projection to the first m componets of a vector
                   1143: %% [P1,...,Pm,...] m proj ---> [P1,...,Pm]
                   1144: /proj {
                   1145:   /arg2 set
                   1146:   /arg1 set
                   1147:   [/n /m /vec /projvec] pushVariables
                   1148:   [
                   1149:     arg2 /m set
                   1150:     arg1 /vec set
                   1151:     vec length /n set
                   1152:
                   1153:     /projvec [
                   1154:       vec aload
                   1155:       0 1 << n m sub >> { pop pop } for
                   1156:     ] def
                   1157:
                   1158:     projvec /arg1 set
                   1159:   ] pop
                   1160:   popVariables
                   1161:   arg1
                   1162: } def
                   1163:
                   1164: /notidentical {
                   1165:   /arg2 set
                   1166:   /arg1 set
                   1167:   arg1 arg2 eq
                   1168:   { } {arg1} ifelse
                   1169: } def
                   1170:
                   1171: %% [u1,...] [v1,...] setminus --> [u1,...] \setminus [v1,...]
                   1172: /setminus {
                   1173:   /arg2 set /arg1 set
                   1174:   [ /Set1 /Set2 /n2 /i ] pushVariables
                   1175:   [
                   1176:     arg1 /Set1 set  arg2 /Set2 set
                   1177:     Set2 length /n2 set
                   1178:     0 1 n2 1 sub {/i set
                   1179:        Set1  Set2 i get  complement.oaku /Set1 set
                   1180:     } for
                   1181:     Set1 /arg1 set
                   1182:   ] pop
                   1183:   popVariables
                   1184:   arg1
                   1185: } def
                   1186:
                   1187: %% (list arg1) \setminus {(an element arg2)}
                   1188: /complement.oaku {
                   1189:   /arg2 set /arg1 set
                   1190:   arg1 { arg2 notidentical } map
                   1191: } def
                   1192:
                   1193: %% convert a polynomial to one in the current ring
                   1194: /reexpand {
                   1195:   /arg1 set
                   1196:   arg1 {(string) dc expand} map
                   1197: } def
                   1198:
                   1199: %% Op (poly) [(t1) (t2) ...] fwh_order ---> FW-ord(Op) (integer)
                   1200: %% The current ring must be adapted to the V-filtration!
                   1201: /fwh_order {
                   1202:  /arg2 set  %% bftt (string list)
                   1203:  /arg1 set  %% Op (poly)
                   1204:  [/Op /bftt /fws /m /fwsDt /k /d /i /tt /dtt] pushVariables
                   1205:  [
                   1206:   arg1 /Op set
                   1207:   arg2 /bftt set
                   1208:   Op init /fws set
                   1209:   bftt length /d set
                   1210:   0 /k set
                   1211:   0 /m set
                   1212:   0 1 d 1 sub { /i set
                   1213:     /tt bftt i get expand def
                   1214:     /dtt bftt i get xtoDx expand def
                   1215:     fws dtt coefficients 0 get 0 get (integer) dc m add /m set
                   1216:     fws tt  coefficients 0 get 0 get (integer) dc k add /k set
                   1217:   } for
                   1218:   m k sub (integer) data_conversion /arg1 set
                   1219:  ] pop
                   1220:  popVariables
                   1221:  arg1
                   1222: } def
                   1223:
                   1224: %% FW-homogenization
                   1225: %% Op (string) [(t1) (t2) ...] fw_homogenize ---> h(Op) (string)
                   1226: /fwm_homogenize {
                   1227:   /arg2 set  %% bft (string list)
                   1228:   /arg1 set  %% an operator (string)
                   1229:   [ /bftt /bft /bfDt /bfht /bfhDt /Op /degs /m /mn /d /i ] pushVariables
                   1230:   [
                   1231:     /Op arg1 expand def
                   1232:     /bftt arg2 def
                   1233:     bftt length /d set
                   1234:
                   1235:     0 1 d 1 sub { /i set
                   1236:       bftt i get /bft set
                   1237:       bft xtoDx /bfDt set
                   1238:       BFs (^(-1)*) bft 3 cat_n /bfht set
                   1239:       BFs (*) bfDt 3 cat_n /bfhDt set
                   1240:       Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
                   1241:         /Op set
                   1242:     } for
                   1243:     Op BFs expand coefficients 0 get
                   1244:         {(integer) data_conversion} map /degs set
                   1245:     degs << degs length 1 sub >> get /m set
                   1246:     0 m sub /mn set
                   1247:     << BFs expand mn powerZ >> Op mul /Op set
                   1248:     Op (string) data_conversion /arg1 set
                   1249:   ] pop
                   1250:   popVariables
                   1251:   arg1
                   1252: } def
                   1253:
                   1254: %% FW-principal part of an operator (FW-homogeneous)
                   1255: %%  fw_psi  from bfunc.sm1
                   1256: %%  Op (poly) fw_symbol --->  FW-symbol(Op)  (poly)
                   1257: /fw_symbol {
                   1258:   [[(h). (1).]] replace (s). coefficients 1 get 0 get
                   1259: } def
                   1260:
                   1261: %% FW-homogenization
                   1262: %% Op (string) (t) fw_homogenize ---> h(Op) (string)
                   1263: /fw_homogenize {
                   1264:   /arg2 set  %% bft (string)
                   1265:   /arg1 set  %% an operator (string)
                   1266:   [ /bft /bfDt /bfht /bfhDt /Op /degs /m /mn ] pushVariables
                   1267:   [
                   1268:     /Op arg1 expand def
                   1269:     /bft arg2 def
                   1270:     bft xtoDx /bfDt set
                   1271:     BFs (^(-1)*) bft 3 cat_n /bfht set
                   1272:     BFs (*) bfDt 3 cat_n /bfhDt set
                   1273:     Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
                   1274:       /Op set
                   1275:     Op BFs expand coefficients 0 get
                   1276:       {(integer) data_conversion} map /degs set
                   1277:     degs << degs length 1 sub >> get /m set
                   1278:     0 m sub /mn set
                   1279:     << BFs expand mn powerZ >> Op mul /Op set
                   1280:     Op (string) data_conversion /arg1 set
                   1281:   ] pop
                   1282:   popVariables
                   1283:   arg1
                   1284: } def
                   1285:
                   1286: %% get the FW-order
                   1287: %% Op (poly) (t) fw_order ---> FW-ord(Op) (integer)
                   1288: %% Op should be FW-homogenized.
                   1289: /fw_order {
                   1290:  /arg2 set  %% bft (string)
                   1291:  /arg1 set  %% Op (poly)
                   1292:  [/Op /bft /fws /m /fwsDt /k /tt /dtt] pushVariables
                   1293:  [
                   1294:   arg1 /Op set
                   1295:   arg2 /bft set
                   1296:   Op fw_symbol /fws set
                   1297:   /tt bft expand def
                   1298:   /dtt bft xtoDx  expand def
                   1299:   fws [[BFs expand  (1).]] replace /fws set
                   1300:   fws dtt coefficients 0 get 0 get /m set
                   1301:   fws dtt coefficients 1 get 0 get /fwsDt set
                   1302:   fwsDt tt coefficients 0 get 0 get /k set
                   1303:   m k sub (integer) data_conversion /arg1 set
                   1304:  ] pop
                   1305:  popVariables
                   1306:  arg1
                   1307: } def
                   1308:
                   1309: %% psi(P)(s)
                   1310: %% Op (poly) (t) (string) fw_psi ---> psi(P) (poly)
                   1311: %% Op should be FW-homogeneous.
                   1312: /fw_psi {
                   1313:  /arg2 set  %% bft (string)
                   1314:  /arg1 set  %% Op  (polynomial)
                   1315:  [/bft /bfDt /P /tt /dtt /k /Q /i /m /kk /PPt /PPC /kk /Ss] pushVariables
                   1316:  [
                   1317:   arg2 /bft set
                   1318:   arg1 fw_symbol /P set
                   1319:   /bfDt bft xtoDx def
                   1320:   /tt bft expand def  /dtt bfDt expand def
                   1321:   P bft fw_order /k set
                   1322:     << 1 1 k >>
                   1323:     {pop tt P mul /P set }
                   1324:     for
                   1325:     << -1 -1 k >>
                   1326:     {pop dtt P mul /P set }
                   1327:     for
                   1328:   (0) expand /Q set
                   1329:   P dtt coefficients 0 get length /m set
                   1330:   0 1 << m 1 sub >>
                   1331:   {
                   1332:     /i set
                   1333:     P dtt coefficients 0 get i get /kk set
                   1334:     kk (integer) data_conversion /kk set
                   1335:     P dtt coefficients 1 get i get /PPt set
                   1336:     PPt tt coefficients 1 get 0 get /PPC set
                   1337:     BFth expand /Ss set
                   1338:     0 1 << kk 1 sub >> {
                   1339:       pop
                   1340:       PPC Ss mul /PPC set
                   1341:       Ss (1) expand sub /Ss set
                   1342:     } for
                   1343:     Q PPC add /Q set
                   1344:   } for
                   1345:   Q  /arg1 set
                   1346:  ] pop
                   1347:  popVariables
                   1348:  arg1
                   1349: } def
                   1350:
                   1351: %% get the FW-order
                   1352: %% Op (poly) [(t1) (t2) ...] fwm_order ---> FW-ord(Op) (integer)
                   1353: %% Op should be FW-homogenized.
                   1354: /fwm_order {
                   1355:  /arg2 set  %% bftt (string list)
                   1356:  /arg1 set  %% Op (poly)
                   1357:  [/Op /bftt /fws /m /fwsDt /k /d /i /tt /dtt] pushVariables
                   1358:  [
                   1359:   arg1 /Op set
                   1360:   arg2 /bftt set
                   1361:   Op fw_symbol /fws set
                   1362:   fws init /fws set
                   1363:   fws [[BFs expand  (1).]] replace /fws set
                   1364:   bftt length /d set
                   1365:   0 /k set
                   1366:   0 /m set
                   1367:   0 1 d 1 sub { /i set
                   1368:     /tt bftt i get expand def
                   1369:     /dtt bftt i get xtoDx expand def
                   1370:     fws dtt coefficients 0 get 0 get (integer) dc m add /m set
                   1371:     fws tt  coefficients 0 get 0 get (integer) dc k add /k set
                   1372:   } for
                   1373:   m k sub (integer) data_conversion /arg1 set
                   1374:  ] pop
                   1375:  popVariables
                   1376:  arg1
                   1377: } def
                   1378:
                   1379: %% (x1) --> (Dx1)
                   1380: /xtoDx {
                   1381:   /arg1 set
                   1382:   @@@.Dsymbol arg1 2 cat_n
                   1383: } def
                   1384:
                   1385: %% [(x1) (x2) (x3)] ---> (x1,x2,x3)
                   1386: /listtostring {
                   1387:   /arg1 set
                   1388:   [/n /j /ary /str] pushVariables
                   1389:   [
                   1390:     /ary arg1 def
                   1391:     /n ary length def
                   1392:     arg1 0 get /str set
                   1393:     n 1 gt
                   1394:       { str (,) 2 cat_n /str set }{ }
                   1395:     ifelse
                   1396:     1 1 n 1 sub {
                   1397:       /j set
                   1398:       j n 1 sub eq
                   1399:         {str << ary j get >>  2 cat_n /str set}
                   1400:         {str << ary j get >>  (,) 3 cat_n /str set}
                   1401:       ifelse
                   1402:     } for
                   1403:     /arg1 str def
                   1404:   ] pop
                   1405:   popVariables
                   1406:   arg1
                   1407: } def
                   1408:
                   1409: %% converting a vector of polynomials [P1 P2 ...] to P1 + P2*e +...
                   1410: /vector_to_poly {
                   1411:   /arg1 set
                   1412:   [/aVec /nVec /eForm /j /aVecj ] pushVariables
                   1413:   [
                   1414:     arg1 /aVec set
                   1415:     aVec length /nVec set
                   1416:     (0). /eForm  set
                   1417:     0 1 nVec 1 sub {
                   1418:       /j set
                   1419:       aVec j get /aVecj set
                   1420:       @@@.esymbol . j npower aVecj mul eForm add /eForm set
                   1421:     } for
                   1422:   eForm /arg1 set
                   1423:   ] pop
                   1424:   popVariables
                   1425:   arg1
                   1426: } def
                   1427:
                   1428: %% setup the ring of differential operators with the variables varlist
                   1429: %% and parameters BFparlist
                   1430: %% varlist setupBFring
                   1431: /setupDring {
                   1432:   /arg1 set
                   1433:   [ /varlist /bft /allvarlist /n /dvarlist /D_weight /i
                   1434:   ] pushVariables
                   1435:   [
                   1436:     arg1 /varlist set
                   1437:     /allvarlist
                   1438:       varlist BFparlist join
                   1439:     def
                   1440:     varlist length /n set
                   1441:     varlist {xtoDx} map /dvarlist set
                   1442:     /D_weight
                   1443:     [ [ 0 1 n 1 sub
                   1444:           { /i set dvarlist i get 1 }
                   1445:         for ]
                   1446:       [
                   1447:         0 1 n 1 sub
                   1448:           { /i set varlist i get 1 }
                   1449:         for ]
                   1450:     ] def
                   1451:
                   1452:     [ allvarlist listtostring ring_of_differential_operators
                   1453:       D_weight weight_vector
                   1454:     0] define_ring
                   1455:
                   1456:   ] pop
                   1457:   popVariables
                   1458: } def
                   1459:
                   1460: %% var (poly) m (integer) ---> var^m (poly)
                   1461: /powerZ {
                   1462:   /arg2 set %% m
                   1463:   /arg1 set %% Var
                   1464:   [ /m /var /varstr /pow /nvar] pushVariables
                   1465:   [
                   1466:     arg1 /var set
                   1467:     arg2 /m set
                   1468:     var (string) data_conversion /varstr set
                   1469:     m -1 gt
                   1470:       { var m npower /pow set}
                   1471:       { varstr (^(-1)) 2 cat_n expand /nvar set
                   1472:         nvar << 0 m sub >> npower /pow set
                   1473:        }
                   1474:     ifelse
                   1475:     pow /arg1 set
                   1476:   ] pop
                   1477:   popVariables
                   1478:   arg1
                   1479: } def
                   1480:
                   1481:
                   1482: %% added on April 14, 1998:
                   1483: %% P [(Dt1). (Dt2). ...] mvec k Vtruncate_below
                   1484: %% --> the part of P of degree >= mvec - k w.r.t. [(Dt1). ..]
                   1485:
                   1486: /Vtruncate_below {
                   1487:   /arg4 set /arg3 set /arg2 set /arg1 set
                   1488:   [/P /bftt /k /Q /InP /DegP /edegP /mvec /i] pushVariables
                   1489:   [
                   1490:     arg1 /P set
                   1491:     arg2 /bftt set
                   1492:     arg3 /mvec set
                   1493:     arg4 /k set
                   1494:     (0). /Q set
                   1495:     {
                   1496:       P (0). eq {exit} {  } ifelse
                   1497:       P init /InP set
                   1498:       InP bftt total_degree /DegP set
                   1499:       InP @@@.esymbol . coefficients 0 get 0 get (integer) dc /i set
                   1500:       DegP << k mvec i get sub >> lt {  } {InP Q add /Q set } ifelse
                   1501:       P InP sub /P set
                   1502:     } loop
                   1503:     Q /arg1 set
                   1504:   ] pop
                   1505:   popVariables
                   1506:   arg1
                   1507: } def
                   1508:
                   1509: %% P (monomial) [(t1). ,...] total_deg
                   1510: %% --> the total degree (integer) of P w.r.t. [(t1).,..]
                   1511: /total_degree {
                   1512:   /arg2 set /arg1 set
                   1513:   [/P /bftt /d /j /PC /tdeg ] pushVariables
                   1514:   [
                   1515:     arg1 /P set
                   1516:     arg2 /bftt set
                   1517:     bftt length /d set
                   1518:     0 /tdeg set
                   1519:     0 1 d 1 sub {/j set
                   1520:       P << bftt j get >> coefficients /PC set
                   1521:       PC 0 get 0 get (integer) dc  tdeg add /tdeg set
                   1522:       PC 1 get 0 get /P set
                   1523:     } for
                   1524:     tdeg /arg1 set
                   1525:   ] pop
                   1526:   popVariables
                   1527:   arg1
                   1528: } def
                   1529:

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