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

Annotation of OpenXM/src/kan96xx/Doc/ecart.sm1, Revision 1.18

1.18    ! takayama    1: % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.17 2003/09/20 22:10:04 takayama Exp $
1.1       takayama    2: %[(parse) (hol.sm1) pushfile] extension
                      3: %[(parse) (appell.sm1) pushfile] extension
                      4:
                      5: (ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet
                      6: /ecart.begin { beginEcart } def
                      7: /ecart.end   { endEcart } def
                      8: /ecart.autoHomogenize 1 def
                      9: /ecart.needSyz 0 def
1.8       takayama   10: /ecartd.begin {
                     11:   ecart.begin
                     12:   [(EcartAutomaticHomogenization) 1] system_variable
                     13: } def
                     14: /ecartd.end {
                     15:   ecart.end
                     16:   [(EcartAutomaticHomogenization) 0] system_variable
                     17: } def
1.1       takayama   18:
1.15      takayama   19: /ecart.setOpt {
                     20:   /arg1 set
                     21:   [/in-ecart.setOpt /opt /i /n /ans] pushVariables
                     22:   [
                     23:     /opt arg1 def
                     24:     /ans [ ] def
                     25:     /n opt length def
                     26:     0 2 n 1 sub {
                     27:       /i set
                     28:       opt i get tag StringP eq not {
                     29:          (ecart.setOpt : [keyword value keyword value ....] ) error
                     30:       } {  } ifelse
                     31:      {  % start of the loop
                     32: % Global:  degreeShift
                     33:       opt i get (degreeShift) eq {
                     34:         /degreeShift opt i 1 add get def
                     35:         exit
                     36:       } {  } ifelse
                     37: % Global:  hdShift
                     38:       opt i get (startingShift) eq {
                     39:         /hdShift opt i 1 add get def
                     40:         exit
                     41:       } {  } ifelse
                     42: % Global:  hdShift
                     43:       opt i get (noAutoHomogenize) eq {
                     44:         /hdShift -1 def
                     45:         exit
                     46:       } {  } ifelse
1.16      takayama   47: % Global:  ecart.useSugar
                     48:       opt i get (sugar) eq {
                     49:         /ecart.useSugar opt i 1 add get def
                     50:         exit
                     51:       } {  } ifelse
                     52:
1.15      takayama   53:       ans [opt i get opt i 1 add get ]  append /ans set
                     54:       exit
                     55:      } loop
                     56:     } for
                     57:
                     58:     ecart.gb.verbose {
                     59:       (ecart.setOpt:) message
                     60:       (degreeShift=) messagen degreeShift message
                     61:       $hdShift(startingShift)=$ messagen hdShift message
1.16      takayama   62:       (sugar=) messagen ecart.useSugar message
1.15      takayama   63:       (Other options=) messagen ans message
                     64:     } {  } ifelse
                     65:
                     66:     /arg1 ans def
                     67:   ] pop
                     68:   popVariables
                     69:   arg1
                     70: } def
                     71:
1.1       takayama   72: /ecart.dehomogenize {
                     73:  /arg1 set
                     74:  [/in.ecart.dehomogenize /ll /rr] pushVariables
                     75:  [
                     76:    /ll arg1 def
                     77:    ll tag 6 eq {
                     78:      ll { ecart.dehomogenize } map /ll set
                     79:    } {
                     80:      ll (0). eq {
                     81:      } {
                     82:        ll getRing /rr set
                     83:        ll [ [ (H) rr ,, (1) rr ,, ]
                     84:             [ (h) rr ,, (1) rr ,, ]] replace
                     85:        /ll set
                     86:      } ifelse
                     87:    } ifelse
                     88:    /arg1 ll def
                     89:  ] pop
                     90:  popVariables
                     91:  arg1
                     92: } def
                     93: [(ecart.dehomogenize)
                     94:  [(obj ecart.dehomogenize r)
                     95:   (h->1, H->1)
                     96: ]] putUsages
                     97:
                     98: /ecart.dehomogenizeH {
                     99:  /arg1 set
                    100:  [/in.ecart.dehomogenize /ll /rr] pushVariables
                    101:  [
                    102:    /ll arg1 def
                    103:    ll tag 6 eq {
                    104:      ll { ecart.dehomogenize } map /ll set
                    105:    } {
                    106:      ll (0). eq {
                    107:      } {
                    108:        ll getRing /rr set
                    109:        ll [ [ (H) rr ,, (1) rr ,, ] ] replace
                    110:        /ll set
                    111:      } ifelse
                    112:    } ifelse
                    113:    /arg1 ll def
                    114:  ] pop
                    115:  popVariables
                    116:  arg1
                    117: } def
                    118: [(ecart.dehomogenizeH)
                    119:  [(obj ecart.dehomogenizeH r)
                    120:   (H->1, h is not changed.)
                    121: ]] putUsages
                    122:
                    123: /ecart.homogenize01 {
                    124:  /arg1 set
1.11      takayama  125:  [/in.ecart.homogenize01 /ll /ll0] pushVariables
1.1       takayama  126:  [
                    127:    /ll arg1 def
1.11      takayama  128:    ll tag ArrayP eq {
                    129:      ll 0 get tag ArrayP eq not {
                    130:        [(degreeShift) [ ] ll ] homogenize   /arg1 set
                    131:      } {
                    132:        ll { ecart.homogenize01 } map /arg1 set
                    133:      } ifelse
                    134:    } {
                    135:        [(degreeShift) [ ] ll ] homogenize   /arg1 set
1.12      takayama  136:    } ifelse
1.1       takayama  137:  ] pop
                    138:  popVariables
                    139:  arg1
                    140: } def
                    141: [(ecart.homogenize01)
                    142:  [(obj ecart.homogenize01 r)
                    143:   (Example:  )
                    144:   (  [(x1,x2) ring_of_differential_operators )
                    145:   (   [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
                    146:   (    [(h) 1 (Dx1) 1 (Dx2) 1] )
                    147:   (    [(Dx1) 1 (Dx2) 1]   )
                    148:   (    [(x1) -1 (x2) -1])
1.18    ! takayama  149:   (   ] ecart.weight_vector )
1.1       takayama  150:   (   0  )
1.11      takayama  151:   (   [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
1.1       takayama  152:   (  ] define_ring)
                    153:   ( ecart.begin)
                    154:   ( [[1 -4 -2 5]] appell4 0 get /eqs set)
                    155:   ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
1.11      takayama  156:   ( {ecart.homogenize01} map /eqs2 set)
1.1       takayama  157:   ( [eqs2] groebner )
                    158: ]] putUsages
                    159:
                    160: /ecart.homogenize01_with_shiftVector {
                    161:  /arg2.set
                    162:  /arg1 set
1.11      takayama  163:  [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
1.1       takayama  164:  [
                    165:    /sv arg2 def
                    166:    /ll arg1 def
1.11      takayama  167:    ll tag ArrayP eq {
                    168:      ll 0 get tag ArrayP eq not {
                    169:        [(degreeShift) sv ll ] homogenize   /arg1 set
                    170:      } {
                    171:        ll { ecart.homogenize01_with_shiftVector } map /arg1 set
                    172:      } ifelse
                    173:    } {
                    174:        [(degreeShift) sv ll ] homogenize   /arg1 set
1.12      takayama  175:    } ifelse
1.1       takayama  176:  ] pop
                    177:  popVariables
                    178:  arg1
                    179: } def
                    180: [(ecart.dehomogenize01_with_degreeShift)
                    181:  [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
1.11      takayama  182:   (cf. homogenize)
1.1       takayama  183: ]] putUsages
                    184:
                    185: %% Aux functions to return the default weight vectors.
                    186: /ecart.wv1 {
                    187:   /arg1 set
                    188:   [/in.ecart.wv1 /v] pushVariables
                    189:   [
                    190:     /v arg1 def
                    191:     [(H) (h) v to_records pop] /v set
                    192:     v { 1 } map /v set
                    193:     /arg1 v def
                    194:   ] pop
                    195:   popVariables
                    196:   arg1
                    197: } def
                    198: /ecart.wv2 {
                    199:   /arg1 set
                    200:   [/in.ecart.wv2 /v] pushVariables
                    201:   [
                    202:     /v arg1 def
                    203:     [v to_records pop] /v set
                    204:     v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
                    205:     [(h) 1 ] v join /v set
                    206:     /arg1 v def
                    207:   ] pop
                    208:   popVariables
                    209:   arg1
                    210: } def
                    211:
1.7       takayama  212: /ecart.gb {ecartd.gb}  def
                    213:
                    214: [(ecart.gb)
                    215:  [(a ecart.gb b)
                    216:   (array a; array b;)
                    217:   $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
                    218:   (             in the ring of differential operators.)
                    219:   (The computation is done by using Ecart division algorithm and )
                    220:   (the double homogenization.)
                    221:   (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
                    222:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                    223:    $            to a ring. In the other cases, it returns the initial monominal.$
                    224:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    225:   (a : [f v];   array f; string v;  v is the variables. )
                    226:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.15      takayama  227:   $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$
1.11      takayama  228:   (                array ds; ds is the degree shift for the ring. )
1.15      takayama  229:   $a : [f v w [(degreeShift) ds (startingShift) hdShift]]; array f; string v; array of array w; w is the weight matirx.$
1.11      takayama  230:   (        array ds; ds is the degree shift for the ring. )
                    231:   (        array hsShift is the degree shift for the homogenization. cf.homogenize )
1.15      takayama  232:   $a : [f v w [(degreeShift) ds (noAutoHomogenize) 1]]; array f; string v; array of array w; w is the weight matirx.$
1.11      takayama  233:   (       No automatic homogenization.)
1.16      takayama  234:   $  [(degreeShift) ds (noAutoHomogenize) 1 (sugar) 1] -->use the sugar strate $
1.7       takayama  235:   (  )
                    236:   $cf. ecarth.gb (homogenized),  ecartd.gb (dehomogenize) $
                    237:   ( )
                    238:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
                    239:   $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
                    240:   (Example 2: )
                    241:   $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.9       takayama  242:   $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb  /ff set ff pmat ;$
                    243:   (To set the current ring to the ring in which ff belongs )
                    244:   (      ff getRing ring_def  )
1.7       takayama  245:   (  )
                    246:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
                    247:   $             [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
1.10      takayama  248:   (   This example will cause an error on order.)
1.7       takayama  249:   (  )
                    250:   $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
                    251:   $             [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
1.10      takayama  252:   (   This example will cause an error on order.)
1.7       takayama  253:   (  )
                    254:   $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.15      takayama  255:   $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  $
                    256:   $             [(degreeShift) [[0 1] [-3 1]]] ] ecart.gb pmat ; $
1.7       takayama  257:   (  )
                    258:   (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
                    259:   (    ecart.dehomogenize, ecart.dehomogenizeH)
                    260:   ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
                    261:   (                                                          define_ring )
                    262:   (/ecart.autoHomogenize 0 def )
                    263:   (               not to dehomogenize and homogenize)
                    264: ]] putUsages
                    265:
1.1       takayama  266: /ecart.gb.verbose 1 def
1.12      takayama  267: %ecarth.gb  s(H)-homogenized outputs.  GG's original version of ecart gb.
1.7       takayama  268: /ecarth.gb {
1.1       takayama  269:   /arg1 set
1.7       takayama  270:   [/in-ecarth.gb /aa /typev /setarg /f /v
1.1       takayama  271:    /gg /wv /vec /ans /rr /mm
                    272:    /degreeShift  /env2 /opt /ans.gb
1.12      takayama  273:    /hdShift
1.17      takayama  274:    /ecart.useSugar
1.1       takayama  275:   ] pushVariables
                    276:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    277:   [
                    278:     /aa arg1 def
1.13      takayama  279:     aa isArray { } { ( << array >> ecarth.gb) error } ifelse
1.1       takayama  280:     /setarg 0 def
                    281:     /wv 0 def
                    282:     /degreeShift 0 def
1.12      takayama  283:     /hdShift 0 def
1.1       takayama  284:     /opt [(weightedHomogenization) 1] def
1.17      takayama  285:     /ecart.useSugar 0 def
1.1       takayama  286:     aa { tag } map /typev set
                    287:     typev [ ArrayP ] eq
                    288:     {  /f aa 0 get def
                    289:        /v gb.v def
                    290:        /setarg 1 def
                    291:     } { } ifelse
                    292:     typev [ArrayP StringP] eq
                    293:     {  /f aa 0 get def
                    294:        /v aa 1 get def
                    295:        /setarg 1 def
                    296:     } { } ifelse
                    297:     typev [ArrayP RingP] eq
                    298:     {  /f aa 0 get def
                    299:        /v aa 1 get def
                    300:        /setarg 1 def
                    301:     } { } ifelse
                    302:     typev [ArrayP ArrayP] eq
                    303:     {  /f aa 0 get def
                    304:        /v aa 1 get from_records def
                    305:        /setarg 1 def
                    306:     } { } ifelse
                    307:     typev [ArrayP StringP ArrayP] eq
                    308:     {  /f aa 0 get def
                    309:        /v aa 1 get def
                    310:        /wv aa 2 get def
                    311:        /setarg 1 def
                    312:     } { } ifelse
                    313:     typev [ArrayP ArrayP ArrayP] eq
                    314:     {  /f aa 0 get def
                    315:        /v aa 1 get from_records def
                    316:        /wv aa 2 get def
                    317:        /setarg 1 def
                    318:     } { } ifelse
1.15      takayama  319:
1.1       takayama  320:     typev [ArrayP StringP ArrayP ArrayP] eq
                    321:     {  /f aa 0 get def
                    322:        /v aa 1 get def
                    323:        /wv aa 2 get def
1.15      takayama  324:        opt aa 3 get ecart.setOpt join /opt set
1.12      takayama  325:        /setarg 1 def
                    326:     } { } ifelse
1.1       takayama  327:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    328:     {  /f aa 0 get def
                    329:        /v aa 1 get from_records def
                    330:        /wv aa 2 get def
1.15      takayama  331:        opt aa 3 get ecart.setOpt join /opt set
1.13      takayama  332:        /setarg 1 def
                    333:     } { } ifelse
1.1       takayama  334:
                    335:     /env1 getOptions def
                    336:
1.12      takayama  337:     ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } {  } ifelse
                    338:     setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
1.1       takayama  339:
                    340:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    341:
                    342:     %%% Start of the preprocess
                    343:     v tag RingP eq {
                    344:        /rr v def
                    345:     }{
                    346:       f getRing /rr set
                    347:     } ifelse
                    348:     %% To the normal form : matrix expression.
                    349:     f gb.toMatrixOfString /f set
                    350:     /mm gb.itWasMatrix def
                    351:
                    352:     rr tag 0 eq {
                    353:       %% Define our own ring
                    354:       v isInteger {
                    355:         (Error in gb: Specify variables) error
                    356:       } {  } ifelse
                    357:       wv isInteger {
                    358:         [v ring_of_differential_operators
1.18    ! takayama  359: %         [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector
1.3       takayama  360:          gb.characteristic
1.1       takayama  361:          opt
                    362:         ] define_ring
                    363:       }{
                    364:        degreeShift isInteger {
                    365:          [v ring_of_differential_operators
1.18    ! takayama  366: %          [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
        !           367:           wv ecart.weight_vector
1.3       takayama  368:           gb.characteristic
1.1       takayama  369:           opt
                    370:          ] define_ring
                    371:
                    372:        }{
                    373:          [v ring_of_differential_operators
1.18    ! takayama  374: %          [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
        !           375:           wv  ecart.weight_vector
1.3       takayama  376:           gb.characteristic
1.1       takayama  377:           [(degreeShift) degreeShift] opt join
                    378:           ] define_ring
                    379:
                    380:        } ifelse
                    381:       } ifelse
                    382:     } {
                    383:       %% Use the ring structre given by the input.
                    384:       v isInteger not {
                    385:         gb.warning {
                    386:          (Warning : the given ring definition is not used.) message
                    387:         } { } ifelse
                    388:       } {  } ifelse
                    389:       rr ring_def
                    390:       /wv rr gb.getWeight def
                    391:
                    392:     } ifelse
                    393:     %%% Enf of the preprocess
                    394:
                    395:     ecart.gb.verbose {
1.6       takayama  396:       (The first and the second weight vectors for automatic homogenization: )
1.1       takayama  397:        message
                    398:        v ecart.wv1 message
                    399:        v ecart.wv2 message
                    400:        degreeShift isInteger { }
                    401:        {
                    402:          (The degree shift is ) messagen
                    403:          degreeShift message
                    404:        } ifelse
                    405:     } { } ifelse
                    406:
1.5       takayama  407:     %%BUG: case of v is integer
                    408:     v ecart.checkOrder
                    409:
1.1       takayama  410:     ecart.begin
                    411:
                    412:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.13      takayama  413:
1.12      takayama  414:
                    415:     hdShift tag 1 eq {
                    416:      ecart.autoHomogenize not hdShift -1 eq or {
                    417: % No automatic h-s-homogenization.
                    418:        f { {. } map} map /f set
                    419:      } {
                    420: % Automatic h-s-homogenization without degreeShift
1.13      takayama  421:     (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
                    422:       message
1.12      takayama  423:        f { {. ecart.dehomogenize} map} map /f set
                    424:        f ecart.homogenize01 /f set
                    425:      } ifelse
                    426:    } {
                    427: % Automatic h-s-homogenization with degreeShift
1.13      takayama  428:     (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
                    429:       message
1.12      takayama  430:        f { {. ecart.dehomogenize} map} map /f set
                    431:        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
                    432:    }ifelse
                    433:
1.17      takayama  434:     ecart.useSugar {
                    435:       ecart.needSyz {
                    436:         [f [(needSyz)] gb.options join ] groebner_sugar /gg set
                    437:       } {
                    438:         [f gb.options] groebner_sugar 0 get /gg set
                    439:       } ifelse
                    440:     } {
                    441:       ecart.needSyz {
                    442:         [f [(needSyz)] gb.options join ] groebner /gg set
                    443:       } {
                    444:         [f gb.options] groebner 0 get /gg set
                    445:       } ifelse
1.1       takayama  446:     } ifelse
                    447:
                    448:     ecart.needSyz {
                    449:       mm {
                    450:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
1.11      takayama  451:        } { /ans.gb gg 0 get def } ifelse
                    452:        /ans [gg 2 get , ans.gb , gg 1 get , f ] def
                    453: %      ans pmat ;
1.1       takayama  454:     } {
                    455:       wv isInteger {
                    456:         /ans [gg gg {init} map] def
                    457:       }{
1.10      takayama  458:        degreeShift isInteger {
                    459:          /ans [gg gg {wv 0 get weightv init} map] def
                    460:        } {
                    461:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    462:        } ifelse
1.1       takayama  463:       }ifelse
                    464:
                    465:       %% Postprocess : recover the matrix expression.
                    466:       mm {
                    467:         ans { /tmp set [mm tmp] toVectors } map
                    468:         /ans set
                    469:       }{ }
                    470:       ifelse
                    471:     } ifelse
                    472:
                    473:     ecart.end
                    474:
                    475:     %%
                    476:     env1 restoreOptions  %% degreeShift changes "grade"
                    477:
                    478:     /arg1 ans def
                    479:   ] pop
                    480:   popEnv
                    481:   popVariables
                    482:   arg1
                    483: } def
1.7       takayama  484: (ecarth.gb ) messagen-quiet
1.1       takayama  485:
1.7       takayama  486: [(ecarth.gb)
                    487:  [(a ecarth.gb b)
1.1       takayama  488:   (array a; array b;)
                    489:   $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
                    490:   (             in the ring of differential operators.)
1.12      takayama  491:   (The computation is done by using Ecart division algorithm.)
                    492:   $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$
                    493:   (they are not dehomogenized.)
1.1       takayama  494:   (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
                    495:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                    496:    $            to a ring. In the other cases, it returns the initial monominal.$
                    497:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    498:   (a : [f v];   array f; string v;  v is the variables. )
                    499:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.15      takayama  500:   $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$
1.1       takayama  501:   (                array ds; ds is the degree shift )
                    502:   (  )
                    503:   (/ecart.autoHomogenize 0 def )
                    504:   (               not to dehomogenize and homogenize)
                    505:   ( )
                    506:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7       takayama  507:   $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1       takayama  508:   (Example 2: )
                    509:   (To put H and h=1, type in, e.g., )
                    510:   $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.7       takayama  511:   $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
1.1       takayama  512:   (  )
                    513:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
1.7       takayama  514:   $             [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
1.1       takayama  515:   (  )
                    516:   $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.7       takayama  517:   $             [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1       takayama  518:   (  )
                    519:   $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.15      takayama  520:   $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $
                    521:   $            [(degreeShift) [[0 1] [-3 1] ]]  ] ecarth.gb pmat ; $
1.1       takayama  522:   (  )
1.7       takayama  523:   (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
1.1       takayama  524:   (    ecart.dehomogenize, ecart.dehomogenizeH)
                    525:   ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
                    526:   (                                                          define_ring )
                    527: ]] putUsages
                    528:
                    529:
                    530: /ecart.syz {
                    531:   /arg1 set
                    532:   [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
                    533:   [
                    534:     /ff arg1 def
                    535:     /ecart.save.needSyz ecart.needSyz def
                    536:     /ecart.needSyz 1 def
                    537:     ff ecart.gb /ff.ans set
                    538:     /ecart.needSyz ecart.save.needSyz def
                    539:     /arg1 ff.ans def
                    540:   ] pop
                    541:   popVariables
                    542:   arg1
                    543: } def
                    544: (ecart.syz ) messagen-quiet
                    545:
                    546: [(ecart.syz)
                    547:  [(a ecart.syz b)
                    548:   (array a; array b;)
                    549:   $b : [syzygy gb tmat input];  gb = tmat * input $
                    550:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
1.8       takayama  551:   $             [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
1.1       takayama  552:   $ ff 0 get ff 3 get mul pmat $
                    553:   $ ff 2 get  ff 3 get mul [ff 1 get ] transpose sub pmat ; $
                    554:   (  )
1.9       takayama  555:   (To set the current ring to the ring in which ff belongs )
                    556:   (      ff getRing ring_def  )
1.1       takayama  557:   $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.8       takayama  558:   $             [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ]  [[0 1] [-3 1] ] ] ecart.syz pmat ; $
1.1       takayama  559:   (  )
                    560:   (cf. ecart.gb)
                    561:   (    /ecart.autoHomogenize 0 def )
                    562: ]] putUsages
1.2       takayama  563:
1.3       takayama  564:
                    565: /ecartn.begin {
                    566:   (red@) (standard) switch_function
                    567: %%  (red@) (ecart) switch_function
                    568:   [(Ecart) 1] system_variable
                    569:   [(CheckHomogenization) 0] system_variable
                    570:   [(ReduceLowerTerms) 0] system_variable
                    571:   [(AutoReduce) 0] system_variable
                    572:   [(EcartAutomaticHomogenization) 0] system_variable
                    573: } def
                    574: /ecartn.gb {
                    575:   /arg1 set
                    576:   [/in-ecartn.gb /aa /typev /setarg /f /v
                    577:    /gg /wv /vec /ans /rr /mm
                    578:    /degreeShift  /env2 /opt /ans.gb
                    579:   ] pushVariables
                    580:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    581:   [
                    582:     /aa arg1 def
1.13      takayama  583:     aa isArray { } { ( << array >> ecartn.gb) error } ifelse
1.3       takayama  584:     /setarg 0 def
                    585:     /wv 0 def
                    586:     /degreeShift 0 def
                    587:     /opt [(weightedHomogenization) 1] def
                    588:     aa { tag } map /typev set
                    589:     typev [ ArrayP ] eq
                    590:     {  /f aa 0 get def
                    591:        /v gb.v def
                    592:        /setarg 1 def
                    593:     } { } ifelse
                    594:     typev [ArrayP StringP] eq
                    595:     {  /f aa 0 get def
                    596:        /v aa 1 get def
                    597:        /setarg 1 def
                    598:     } { } ifelse
                    599:     typev [ArrayP RingP] eq
                    600:     {  /f aa 0 get def
                    601:        /v aa 1 get def
                    602:        /setarg 1 def
                    603:     } { } ifelse
                    604:     typev [ArrayP ArrayP] eq
                    605:     {  /f aa 0 get def
                    606:        /v aa 1 get from_records def
                    607:        /setarg 1 def
                    608:     } { } ifelse
                    609:     typev [ArrayP StringP ArrayP] eq
                    610:     {  /f aa 0 get def
                    611:        /v aa 1 get def
                    612:        /wv aa 2 get def
                    613:        /setarg 1 def
                    614:     } { } ifelse
                    615:     typev [ArrayP ArrayP ArrayP] eq
                    616:     {  /f aa 0 get def
                    617:        /v aa 1 get from_records def
                    618:        /wv aa 2 get def
                    619:        /setarg 1 def
                    620:     } { } ifelse
1.15      takayama  621:
1.3       takayama  622:     typev [ArrayP StringP ArrayP ArrayP] eq
                    623:     {  /f aa 0 get def
                    624:        /v aa 1 get def
                    625:        /wv aa 2 get def
1.15      takayama  626:        opt aa 3 get ecart.setOpt join /opt set
1.3       takayama  627:        /setarg 1 def
                    628:     } { } ifelse
                    629:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    630:     {  /f aa 0 get def
                    631:        /v aa 1 get from_records def
                    632:        /wv aa 2 get def
1.15      takayama  633:        opt aa 3 get ecart.setOpt join /opt set
1.3       takayama  634:        /setarg 1 def
                    635:     } { } ifelse
                    636:
                    637:     /env1 getOptions def
                    638:
                    639:     setarg { } { (ecart.gb : Argument mismatch) error } ifelse
                    640:
                    641:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    642:
                    643:     %%% Start of the preprocess
                    644:     v tag RingP eq {
                    645:        /rr v def
                    646:     }{
                    647:       f getRing /rr set
                    648:     } ifelse
                    649:     %% To the normal form : matrix expression.
                    650:     f gb.toMatrixOfString /f set
                    651:     /mm gb.itWasMatrix def
                    652:
                    653:     rr tag 0 eq {
                    654:       %% Define our own ring
                    655:       v isInteger {
                    656:         (Error in gb: Specify variables) error
                    657:       } {  } ifelse
                    658:       wv isInteger {
                    659:         [v ring_of_differential_operators
1.18    ! takayama  660:          [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector
1.3       takayama  661:          gb.characteristic
                    662:          opt
                    663:         ] define_ring
                    664:       }{
                    665:        degreeShift isInteger {
                    666:          [v ring_of_differential_operators
1.18    ! takayama  667:           [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
1.3       takayama  668:           gb.characteristic
                    669:           opt
                    670:          ] define_ring
                    671:
                    672:        }{
                    673:          [v ring_of_differential_operators
1.18    ! takayama  674:           [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
1.3       takayama  675:           gb.characteristic
                    676:           [(degreeShift) degreeShift] opt join
                    677:           ] define_ring
                    678:
                    679:        } ifelse
                    680:       } ifelse
                    681:     } {
                    682:       %% Use the ring structre given by the input.
                    683:       v isInteger not {
                    684:         gb.warning {
                    685:          (Warning : the given ring definition is not used.) message
                    686:         } { } ifelse
                    687:       } {  } ifelse
                    688:       rr ring_def
                    689:       /wv rr gb.getWeight def
                    690:
                    691:     } ifelse
                    692:     %%% Enf of the preprocess
                    693:
                    694:     ecart.gb.verbose {
                    695:       (The first and the second weight vectors are automatically set as follows)
                    696:        message
                    697:        v ecart.wv1 message
                    698:        v ecart.wv2 message
                    699:        degreeShift isInteger { }
                    700:        {
                    701:          (The degree shift is ) messagen
                    702:          degreeShift message
                    703:        } ifelse
                    704:     } { } ifelse
                    705:
1.5       takayama  706:     %%BUG: case of v is integer
                    707:     v ecart.checkOrder
                    708:
1.3       takayama  709:     ecartn.begin
                    710:
                    711:     ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
                    712:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
                    713:     ecart.autoHomogenize {
                    714:       (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
                    715:       message
                    716:     } { } ifelse
                    717:     ecart.autoHomogenize {
                    718:       f { {. ecart.dehomogenize} map} map /f set
                    719:       f ecart.homogenize01 /f set
                    720:     }{
                    721:       f { {. } map } map /f set
                    722:     } ifelse
                    723:     ecart.needSyz {
                    724:       [f [(needSyz)] gb.options join ] groebner /gg set
                    725:     } {
                    726:       [f gb.options] groebner 0 get /gg set
                    727:     } ifelse
                    728:
                    729:     ecart.needSyz {
                    730:       mm {
                    731:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
                    732:       } { /ans.gb gg 0 get def } ifelse
                    733:       /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11      takayama  734: %      ans pmat ;
1.3       takayama  735:     } {
                    736:       wv isInteger {
                    737:         /ans [gg gg {init} map] def
                    738:       }{
1.10      takayama  739:        degreeShift isInteger {
                    740:          /ans [gg gg {wv 0 get weightv init} map] def
                    741:        } {
                    742:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    743:        } ifelse
1.3       takayama  744:       }ifelse
                    745:
                    746:       %% Postprocess : recover the matrix expression.
                    747:       mm {
                    748:         ans { /tmp set [mm tmp] toVectors } map
                    749:         /ans set
                    750:       }{ }
                    751:       ifelse
                    752:     } ifelse
                    753:
                    754:     ecart.end
                    755:
                    756:     %%
                    757:     env1 restoreOptions  %% degreeShift changes "grade"
                    758:
                    759:     /arg1 ans def
                    760:   ] pop
                    761:   popEnv
                    762:   popVariables
                    763:   arg1
                    764: } def
                    765: (ecartn.gb[gb by non-ecart division] ) messagen-quiet
1.4       takayama  766:
                    767: /ecartd.gb {
                    768:   /arg1 set
                    769:   [/in-ecart.gb /aa /typev /setarg /f /v
                    770:    /gg /wv /vec /ans /rr /mm
                    771:    /degreeShift  /env2 /opt /ans.gb
1.11      takayama  772:    /hdShift
1.16      takayama  773:    /ecart.useSugar
1.4       takayama  774:   ] pushVariables
                    775:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    776:   [
                    777:     /aa arg1 def
1.13      takayama  778:     aa isArray { } { ( << array >> ecartd.gb) error } ifelse
1.4       takayama  779:     /setarg 0 def
                    780:     /wv 0 def
                    781:     /degreeShift 0 def
1.11      takayama  782:     /hdShift 0 def
1.16      takayama  783:     /ecart.useSugar 0 def
1.4       takayama  784:     /opt [(weightedHomogenization) 1] def
                    785:     aa { tag } map /typev set
                    786:     typev [ ArrayP ] eq
                    787:     {  /f aa 0 get def
                    788:        /v gb.v def
                    789:        /setarg 1 def
                    790:     } { } ifelse
                    791:     typev [ArrayP StringP] eq
                    792:     {  /f aa 0 get def
                    793:        /v aa 1 get def
                    794:        /setarg 1 def
                    795:     } { } ifelse
                    796:     typev [ArrayP RingP] eq
                    797:     {  /f aa 0 get def
                    798:        /v aa 1 get def
                    799:        /setarg 1 def
                    800:     } { } ifelse
                    801:     typev [ArrayP ArrayP] eq
                    802:     {  /f aa 0 get def
                    803:        /v aa 1 get from_records def
                    804:        /setarg 1 def
                    805:     } { } ifelse
                    806:     typev [ArrayP StringP ArrayP] eq
                    807:     {  /f aa 0 get def
                    808:        /v aa 1 get def
                    809:        /wv aa 2 get def
                    810:        /setarg 1 def
                    811:     } { } ifelse
                    812:     typev [ArrayP ArrayP ArrayP] eq
                    813:     {  /f aa 0 get def
                    814:        /v aa 1 get from_records def
                    815:        /wv aa 2 get def
                    816:        /setarg 1 def
                    817:     } { } ifelse
1.15      takayama  818:
1.4       takayama  819:     typev [ArrayP StringP ArrayP ArrayP] eq
                    820:     {  /f aa 0 get def
                    821:        /v aa 1 get def
                    822:        /wv aa 2 get def
1.15      takayama  823:        opt aa 3 get ecart.setOpt join /opt set
1.4       takayama  824:        /setarg 1 def
                    825:     } { } ifelse
                    826:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    827:     {  /f aa 0 get def
                    828:        /v aa 1 get from_records def
                    829:        /wv aa 2 get def
1.15      takayama  830:        opt aa 3 get ecart.setOpt join /opt set
1.13      takayama  831:        /setarg 1 def
                    832:     } { } ifelse
1.4       takayama  833:
                    834:     /env1 getOptions def
                    835:
                    836:     setarg { } { (ecart.gb : Argument mismatch) error } ifelse
                    837:
                    838:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    839:     $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message
                    840:
                    841:     %%% Start of the preprocess
                    842:     v tag RingP eq {
                    843:        /rr v def
                    844:     }{
                    845:       f getRing /rr set
                    846:     } ifelse
                    847:     %% To the normal form : matrix expression.
                    848:     f gb.toMatrixOfString /f set
                    849:     /mm gb.itWasMatrix def
                    850:
                    851:     rr tag 0 eq {
                    852:       %% Define our own ring
                    853:       v isInteger {
                    854:         (Error in gb: Specify variables) error
                    855:       } {  } ifelse
                    856:       wv isInteger {
                    857:         (Give an weight vector such that x < 1) error
                    858:       }{
                    859:        degreeShift isInteger {
                    860:          [v ring_of_differential_operators
1.18    ! takayama  861:            wv ecart.weight_vector
1.4       takayama  862:           gb.characteristic
                    863:           opt
                    864:          ] define_ring
                    865:
                    866:        }{
                    867:          [v ring_of_differential_operators
1.18    ! takayama  868:            wv ecart.weight_vector
1.4       takayama  869:           gb.characteristic
                    870:           [(degreeShift) degreeShift] opt join
                    871:           ] define_ring
                    872:
                    873:        } ifelse
                    874:       } ifelse
                    875:     } {
                    876:       %% Use the ring structre given by the input.
                    877:       v isInteger not {
                    878:         gb.warning {
                    879:          (Warning : the given ring definition is not used.) message
                    880:         } { } ifelse
                    881:       } {  } ifelse
                    882:       rr ring_def
                    883:       /wv rr gb.getWeight def
                    884:
                    885:     } ifelse
                    886:     %%% Enf of the preprocess
                    887:
                    888:     ecart.gb.verbose {
                    889:        degreeShift isInteger { }
                    890:        {
                    891:          (The degree shift is ) messagen
                    892:          degreeShift message
                    893:        } ifelse
                    894:     } { } ifelse
                    895:
1.5       takayama  896:     %%BUG: case of v is integer
                    897:     v ecart.checkOrder
                    898:
1.8       takayama  899:     ecartd.begin
1.4       takayama  900:
                    901:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
                    902:
1.11      takayama  903:     hdShift tag 1 eq {
1.12      takayama  904:      ecart.autoHomogenize not hdShift -1 eq  or {
1.11      takayama  905: % No automatic h-homogenization.
                    906:        f { {. } map} map /f set
                    907:      } {
                    908: % Automatic h-homogenization without degreeShift
1.13      takayama  909:        (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
1.11      takayama  910:        f { {. ecart.dehomogenize} map} map /f set
                    911:        f ecart.homogenize01 /f set
                    912:        f { { [[(H). (1).]] replace } map } map /f set
                    913:      } ifelse
                    914:    } {
                    915: % Automatic h-homogenization with degreeShift
1.13      takayama  916:        (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
1.11      takayama  917:        f { {. ecart.dehomogenize} map} map /f set
                    918:        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
                    919:        f { { [[(H). (1).]] replace } map } map /f set
                    920:    }ifelse
1.4       takayama  921:
1.16      takayama  922:     ecart.useSugar {
                    923:       ecart.needSyz {
                    924:         [f [(needSyz)] gb.options join ] groebner_sugar /gg set
                    925:       } {
                    926:         [f gb.options] groebner_sugar 0 get /gg set
                    927:       } ifelse
                    928:     } {
                    929:       ecart.needSyz {
                    930:         [f [(needSyz)] gb.options join ] groebner /gg set
                    931:       } {
                    932:         [f gb.options] groebner 0 get /gg set
                    933:       } ifelse
1.4       takayama  934:     } ifelse
                    935:
                    936:     ecart.needSyz {
                    937:       mm {
                    938:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
                    939:       } { /ans.gb gg 0 get def } ifelse
                    940:       /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11      takayama  941: %      ans pmat ;
1.4       takayama  942:     } {
                    943:       wv isInteger {
                    944:         /ans [gg gg {init} map] def
                    945:       }{
1.11      takayama  946: %% Get the initial ideal
1.10      takayama  947:        degreeShift isInteger {
                    948:          /ans [gg gg {wv 0 get weightv init} map] def
                    949:        } {
                    950:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    951:        } ifelse
1.4       takayama  952:       }ifelse
                    953:
                    954:       %% Postprocess : recover the matrix expression.
                    955:       mm {
                    956:         ans { /tmp set [mm tmp] toVectors } map
                    957:         /ans set
                    958:       }{ }
                    959:       ifelse
                    960:     } ifelse
                    961:
1.8       takayama  962:     ecartd.end
1.4       takayama  963:
                    964:     %%
                    965:     env1 restoreOptions  %% degreeShift changes "grade"
                    966:
                    967:     /arg1 ans def
                    968:   ] pop
                    969:   popEnv
                    970:   popVariables
                    971:   arg1
                    972: } def
                    973: (ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
1.2       takayama  974:
1.5       takayama  975: /ecart.checkOrder {
                    976:   /arg1 set
                    977:   [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
                    978:   [
                    979:     /vv arg1 def
                    980:     vv isArray
                    981:     { } { [vv to_records pop] /vv set } ifelse
                    982:     vv {toString} map /vv set
                    983:     vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
                    984:     % Starting the checks.
                    985:     0 1 vv length 1 sub {
                    986:        /i set
                    987:        vv i get . dd i get . mul /tt set
                    988:        tt @@@.hsymbol . add init tt eq { }
                    989:        { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
                    990:     } for
                    991:
                    992:     0 1 vv length 1 sub {
                    993:        /i set
                    994:        vv i get . /tt set
                    995:        tt (1). add init (1). eq { }
1.6       takayama  996:        { [vv i get ( is larger than 1 ) ] cat error} ifelse
1.5       takayama  997:     } for
                    998:     /arg1 1 def
                    999:   ] pop
                   1000:   popVariables
                   1001:   arg1
                   1002: } def
                   1003: [(ecart.checkOrder)
                   1004:  [(v ecart.checkOrder bool checks if the given order is relevant)
                   1005:   (for the ecart division.)
                   1006:   (cf. ecartd.gb, ecart.gb, ecartn.gb)
                   1007:  ]
                   1008: ] putUsages
                   1009:
                   1010: /ecart.wv_last {
                   1011:   /arg1 set
                   1012:   [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
                   1013:   [
                   1014:     /vv arg1 def
                   1015:     vv isArray
                   1016:     { } { [vv to_records pop] /vv set } ifelse
                   1017:     vv {toString} map /vv set
                   1018:     vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
                   1019:     vv {  -1 } map
                   1020:     dd {   1 } map join /arg1 set
                   1021:   ] pop
                   1022:   popVariables
                   1023:   arg1
                   1024: } def
                   1025: [(ecart.wv_last)
                   1026:  [(v ecart.wv_last wt )
                   1027:   (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
                   1028:   (Use this weight vector as the last weight vector for ecart division)
                   1029:   (if ecart.checkOrder complains about the order given.)
                   1030:  ]
                   1031: ] putUsages
1.13      takayama 1032:
                   1033: /ecart.mimimalBase.test {
                   1034:  [
                   1035:     [    (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
                   1036:     [    (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
                   1037:     [    (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
                   1038:     [    (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
                   1039:     [    (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
                   1040:     [  (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
                   1041:     [  (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
                   1042:     [  (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
                   1043:   ]
                   1044:   /ff set
                   1045:
                   1046:   /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
                   1047:   /shift [ [1 0 1 0 0] ] def
                   1048:   /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
                   1049:
1.15      takayama 1050:   [ff (t,x,y) weight [(degreeShift) shift (startingShift) nmshift]] ecart.minimalBase
1.13      takayama 1051:
                   1052:
                   1053: }  def
                   1054: /test {ecart.mimimalBase.test} def
                   1055:
                   1056: %(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
                   1057: /ecart.minimalBase.D1 {
                   1058:   /arg1 set
                   1059:   [/in-ecart.minimalBase.D1  /tt /v]  pushVariables
                   1060:   [
                   1061:     /v arg1 def
                   1062:     [ v to_records pop] /v set
                   1063:     v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
                   1064:     v [(h) 1] join /arg1 set
                   1065:   ] pop
                   1066:   popVariables
                   1067:   arg1
                   1068: } def
                   1069:
                   1070: % [0 1 2] 1 ecart.removeElem [0 2]
                   1071: /ecart.removeElem {
                   1072:   /arg2 set
                   1073:   /arg1 set
                   1074:   [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
                   1075:   [
                   1076:     /v arg1 def
                   1077:     /q arg2 def
                   1078:     /ans v length 1 sub newVector def
                   1079:     /j 0 def
                   1080:     0 1 v length 1 sub {
                   1081:       /i set
                   1082:       i q eq not {
                   1083:         ans j  v i get put
                   1084:         /j j 1 add def
                   1085:       } {  } ifelse
                   1086:     } for
                   1087:   ] pop
                   1088:   popVariables
                   1089:   arg1
                   1090: } def
                   1091:
1.14      takayama 1092: /ecart.isZeroRow {
                   1093:   /arg1 set
                   1094:   [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables
                   1095:   [
                   1096:      /aa arg1 def
                   1097:      aa length /n set
                   1098:      /yes 1 def
                   1099:      0 1 n 1 sub {
                   1100:        /i set
                   1101:        aa i get (0). eq {
                   1102:        } {
                   1103:          /yes 0 def
                   1104:        } ifelse
                   1105:      } for
                   1106:      /arg1 yes def
                   1107:   ] pop
                   1108:   popVariables
                   1109:   arg1
                   1110: } def
                   1111:
                   1112: /ecart.removeZeroRow {
                   1113:   /arg1 set
                   1114:   [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables
                   1115:   [
                   1116:      /aa arg1 def
                   1117:      aa length /n set
                   1118:      /ans [ ] def
                   1119:      0 1 n 1 sub {
                   1120:        /i set
                   1121:        aa i get ecart.isZeroRow {
                   1122:        } {
                   1123:          ans aa i get append /ans set
                   1124:        } ifelse
                   1125:      } for
                   1126:      /arg1 ans def
                   1127:   ] pop
                   1128:   popVariables
                   1129:   arg1
                   1130: } def
                   1131:
                   1132: /ecart.gen_input {
                   1133:   /arg1 set
                   1134:   [/in-ecart.gen_input  /aa /typev /setarg /f /v
                   1135:    /gg /wv /vec /ans /rr /mm
                   1136:    /degreeShift  /env2 /opt /ss0
                   1137:    /hdShift /ff
                   1138:    ] pushVariables
                   1139:   [
                   1140:     /aa arg1 def
                   1141:     aa isArray { } { ( << array >> ecart.gen_input) error } ifelse
                   1142:     /setarg 0 def
                   1143:     /wv 0 def
                   1144:     /degreeShift 0 def
                   1145:     /hdShift 0 def
1.15      takayama 1146:     /opt [ ] def
1.14      takayama 1147:     aa { tag } map /typev set
1.15      takayama 1148:     typev [ArrayP StringP ArrayP ArrayP] eq
1.14      takayama 1149:     {  /f aa 0 get def
                   1150:        /v aa 1 get def
                   1151:        /wv aa 2 get def
1.15      takayama 1152:        opt aa 3 get ecart.setOpt join /opt set
1.14      takayama 1153:        /setarg 1 def
                   1154:     } { } ifelse
1.15      takayama 1155:     typev [ArrayP ArrayP ArrayP ArrayP] eq
1.14      takayama 1156:     {  /f aa 0 get def
                   1157:        /v aa 1 get from_records def
                   1158:        /wv aa 2 get def
1.15      takayama 1159:        opt aa 3 get ecart.setOpt join /opt set
1.14      takayama 1160:        /setarg 1 def
                   1161:     } { } ifelse
                   1162:     setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
                   1163:
                   1164:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                   1165:
                   1166:     f 0 get tag ArrayP eq {  }
                   1167:     {  f { /tt set [ tt ] } map /f set } ifelse
                   1168:
1.15      takayama 1169:     [f v wv [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join]
1.14      takayama 1170:     ecart.gb /ff set
                   1171:     ff getRing ring_def
                   1172:
                   1173:     ff 0 get { {toString } map } map /ff set
                   1174:
1.15      takayama 1175:     [ff v wv
                   1176:       [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join
                   1177:     ] /arg1 set
1.14      takayama 1178:   ] pop
                   1179:   popVariables
                   1180:   arg1
                   1181: } def
                   1182: [(ecart.gen_input)
1.18    ! takayama 1183: [$[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]] ]  ecart.gen_input $
        !          1184:  $               [gg_h v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] $
1.14      takayama 1185:  (It generates the input for the minimal filtered free resolution.)
                   1186:  (Current ring is changed to the ring of gg_h.)
                   1187:  (cf. ecart.minimalBase)
                   1188:   $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
                   1189:   $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
1.15      takayama 1190:   $          [(degreeShift) [ [0] ] $
                   1191:   $           (startingShift) [ [0] [0] ]] ] ecart.gen_input /gg set gg pmat $
1.14      takayama 1192: ]] putUsages
                   1193:
                   1194:
1.13      takayama 1195: [(ecart.minimalBase)
1.18    ! takayama 1196: [$[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]]  ecart.minimalBase $
1.14      takayama 1197:  (  [mbase gr_of_mbase )
1.18    ! takayama 1198:  $     [syz v ecart.weight_vector [(degreeShift) new_uv_shift_m (startingShift) [new_D_shift_n new_uv_shift_m]]]$
1.14      takayama 1199:  (     gr_of_syz ])
                   1200:  (mbase is the minimal generators of ff in D^h in the sense of filtered minimal)
                   1201:  (generators.)
                   1202:   $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
                   1203:   $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
1.15      takayama 1204:   $           [(degreeShift) [ [0] ] $
                   1205:   $            (startingShift) [ [0] [0] ] ] ] ecart.gen_input /gg0 set $
1.14      takayama 1206:   $         gg0 ecart.minimalBase /ss0 set $
                   1207:   $         ss0 2 get ecart.minimalBase /ss1 set $
                   1208:   $         ss1 2 get ecart.minimalBase /ss2 set $
                   1209:   $     (---------  minimal filtered resolution -------) message $
                   1210:   $     ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat  $
                   1211:   $     (---------  degree shift (n,m) n:D-shift m:uv-shift  -------) message $
1.15      takayama 1212:   $     gg0       3 get 3 get message $
                   1213:   $     ss0 2 get 3 get 3 get message $
                   1214:   $     ss1 2 get 3 get 3 get message $
                   1215:   $     ss2 2 get 3 get 3 get message ; $
1.14      takayama 1216:
1.13      takayama 1217: ]] putUsages
                   1218: /ecart.minimalBase {
                   1219:   /arg1 set
                   1220:   [/in-ecart.minimalBase /ai1 /ai  /aa /typev /setarg /f /v
                   1221:    /gg /wv /vec /ans /rr /mm
                   1222:    /degreeShift  /env2 /opt /ss0
                   1223:    /hdShift
                   1224:     /degreeShiftD /degreeShiftUV
                   1225:     /degreeShiftDnew /degreeShiftUVnew
                   1226:     /tt
                   1227:     /ai1_gr  /ai_gr
                   1228:     /s /r /p /q /i /j /k
                   1229:      /ai1_new /ai_new /ai_new2
                   1230:    ] pushVariables
                   1231:   [
                   1232:     /aa arg1 def
                   1233:     aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
                   1234:     /setarg 0 def
                   1235:     /wv 0 def
                   1236:     /degreeShift 0 def
                   1237:     /hdShift 0 def
1.15      takayama 1238:     /opt [ ] def
1.13      takayama 1239:     aa { tag } map /typev set
1.15      takayama 1240:     typev [ArrayP StringP ArrayP ArrayP] eq
1.13      takayama 1241:     {  /f aa 0 get def
                   1242:        /v aa 1 get def
                   1243:        /wv aa 2 get def
1.15      takayama 1244:        opt aa 3 get ecart.setOpt join /opt set
1.13      takayama 1245:        /setarg 1 def
                   1246:     } { } ifelse
1.15      takayama 1247:     typev [ArrayP ArrayP ArrayP ArrayP] eq
1.13      takayama 1248:     {  /f aa 0 get def
                   1249:        /v aa 1 get from_records def
                   1250:        /wv aa 2 get def
1.15      takayama 1251:        opt aa 3 get ecart.setOpt join /opt set
1.13      takayama 1252:        /setarg 1 def
                   1253:     } { } ifelse
                   1254:     setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
                   1255:
                   1256:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                   1257:
                   1258:     f 0 get tag ArrayP eq {  }
                   1259:     {  f { /tt set [ tt ] } map /f set } ifelse
1.15      takayama 1260:     [f v wv [(degreeShift) degreeShift (noAutoHomogenize) 1] opt join] ecart.syz /ss0 set
1.13      takayama 1261:
                   1262:     ss0 getRing ring_def
                   1263:     /degreeShiftD  hdShift 0 get def
                   1264:     /degreeShiftUV hdShift 1 get def
                   1265: %      -- ai --> D^r -- ai1 --> D^rr
                   1266:     /ai1  f  { { . } map } map def
                   1267:     /ai  ss0 0 get def
                   1268:
                   1269:    {
                   1270:     /degreeShiftUVnew
                   1271:        ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all  } map
                   1272:     def
                   1273:     (degreeShiftUVnew=) messagen degreeShiftUVnew message
                   1274:
                   1275:     /degreeShiftDnew
                   1276:        ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ]  ord_ws_all}
                   1277:             map
                   1278:     def
                   1279:     (degreeShiftDnew=) messagen degreeShiftDnew message
                   1280:
                   1281:     ai {[wv 0 get weightv  degreeShiftUVnew] init} map /ai_gr set
                   1282:
                   1283: %C  Note 2003.8.26
                   1284:
1.14      takayama 1285:     ai [ ] eq {
                   1286:       exit
                   1287:     } {  } ifelse
                   1288:
1.13      takayama 1289:     /s ai length def
                   1290:     /r ai 0 get length def
                   1291:
                   1292:     /itIsMinimal 1 def
                   1293:     0 1 s 1 sub {
                   1294:       /i set
                   1295:       0 1 r 1 sub {
                   1296:         /j set
                   1297:
                   1298:         [(isConstantAll) ai_gr i get j get] gbext
                   1299:         ai_gr i get j get (0). eq not and
                   1300:         {
                   1301:            /itIsMinimal 0 def
                   1302:            /p i def /q j def
                   1303:         } {  } ifelse
                   1304:       } for
                   1305:     } for
                   1306:
                   1307:
                   1308:     itIsMinimal { exit } { } ifelse
                   1309:
                   1310: %    construct new ai and ai1 (A_i and A_{i-1})
                   1311:      /ai1_new  r 1 sub newVector def
                   1312:      /j 0 def
                   1313:      0 1 r 1 sub {
                   1314:        /i set
                   1315:        i q eq not {
                   1316:           ai1_new j ai1 i get put
                   1317:           /j  j 1 add def
                   1318:        } { } ifelse
                   1319:      } for
                   1320:
                   1321:      /ai_new [s  r] newMatrix def
                   1322:      0 1 s 1 sub {
                   1323:        /j set
                   1324:        0 1 r 1 sub {
                   1325:          /k set
                   1326:          ai_new [j k]
                   1327:             << ai p get q get >> << ai j get k get >> mul
                   1328:             << ai j get q get >> << ai p get k get >> mul
                   1329:             sub
                   1330:          put
                   1331:        } for
                   1332:      } for
                   1333:
                   1334: % remove 0 column
                   1335:      /ai_new2 [s 1 sub r 1 sub] newMatrix def
                   1336:      /j 0 def
                   1337:      0 1 s 1 sub {
                   1338:        /i set
                   1339:        i p eq not {
                   1340:           ai_new2 j << ai_new i get q ecart.removeElem >> put
                   1341:           /j  j 1 add def
                   1342:        } { } ifelse
                   1343:      } for
                   1344:
                   1345: %   ( ) error
1.14      takayama 1346:      /ai1 ai1_new  def
                   1347:      /ai ai_new2  ecart.removeZeroRow def
1.13      takayama 1348:
                   1349:    } loop
1.14      takayama 1350:    /arg1
                   1351:      [  ai1
                   1352:         ai1 {[wv 0 get weightv  degreeShift 0 get] init} map %Getting gr of A_{i-1}
1.15      takayama 1353:         [ai v wv [(degreeShift) [degreeShiftUVnew] (startingShift) [degreeShiftDnew degreeShiftUVnew]]]
1.14      takayama 1354:         ai {[wv 0 get weightv  degreeShiftUVnew] init} map %Getting gr of A_i
                   1355:      ]
                   1356:    def
1.13      takayama 1357:   ] pop
                   1358:   popVariables
                   1359:   arg1
                   1360: } def
                   1361:
1.15      takayama 1362: /ecart.minimalResol {
                   1363:   /arg1 set
                   1364:   [/in-ecart.minimalResol /aa /ans /gg0 /ansds /ans_gr /c] pushVariables
                   1365:   [
                   1366:      /aa arg1 def
                   1367:      /ans [ ] def
                   1368:      /ansds [ ] def
                   1369:      /ans_gr [ ] def
                   1370:      /c 0 def
                   1371:
                   1372:     (---- ecart.gen_input ----) message
                   1373:      aa ecart.gen_input /gg0 set
                   1374:      ansds gg0 3 get 3 get append /ansds set
                   1375:      (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set
                   1376:      gg0 ecart.minimalBase /ssi set
                   1377:      ansds ssi 2 get 3 get 3 get append /ansds set
                   1378:      ans ssi 0 get  append /ans set
                   1379:      ans_gr ssi 1 get append /ans_gr set
                   1380:      {
                   1381:        ssi 3 get [ ] eq { exit } { } ifelse
                   1382:        (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set
                   1383:        ssi 2 get ecart.minimalBase /ssi_new set
                   1384:        ans ssi_new 0 get append /ans set
                   1385:        ansds ssi_new 2 get 3 get 3 get append /ansds set
                   1386:        ans_gr ssi_new 1 get append /ans_gr set
                   1387:        /ssi ssi_new def
                   1388:      } loop
                   1389:      /arg1 [ans ansds ans_gr] def
                   1390:   ] pop
                   1391:   popVariables
                   1392:   arg1
                   1393: } def
                   1394:
                   1395: (ecart.minimalResol) message
                   1396:
                   1397: [(ecart.minimalResol)
                   1398: [
                   1399:
1.18    ! takayama 1400:  $[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]]  ecart.minimalResol $
1.15      takayama 1401:  (  [resol degree_shifts gr_of_resol_by_uv_shift_m] )
                   1402:   $Example1: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
                   1403:   $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
                   1404:   $           [(degreeShift) [ [0] ] $
                   1405:   $            (startingShift) [ [0] [0] ] ] ] ecart.minimalResol /gg set gg pmat $
                   1406: ]] putUsages
1.18    ! takayama 1407:
        !          1408: %% for ecart.weight_vector
        !          1409: /ecart.eliminationOrderTemplate  { %% esize >= 1
        !          1410: %% if esize == 0, it returns reverse lexicographic order.
        !          1411: %%  m esize eliminationOrderTemplate mat
        !          1412:   /arg2 set /arg1 set
        !          1413:   [/m  /esize /m1 /m2 /k /om /omtmp] pushVariables
        !          1414:   [
        !          1415:     /m arg1 def  /esize arg2 def
        !          1416:     /m1 m esize sub 1 sub def
        !          1417:     /m2 esize 1 sub def
        !          1418:      [esize 0 gt
        !          1419:       {
        !          1420:        [1 1 esize
        !          1421:         { pop 1 } for
        !          1422:         esize 1 << m 1 sub >>
        !          1423:         { pop 0 } for
        !          1424:        ]  %% 1st vector
        !          1425:       }
        !          1426:       { } ifelse
        !          1427:
        !          1428:       m esize gt
        !          1429:       {
        !          1430:        [1 1  esize
        !          1431:         { pop 0 } for
        !          1432:         esize 1 << m 1 sub >>
        !          1433:         { pop 1 } for
        !          1434:        ]  %% 2nd vector
        !          1435:       }
        !          1436:       { } ifelse
        !          1437:
        !          1438:       m1 0 gt
        !          1439:       {
        !          1440:          m 1 sub -1 << m m1 sub >>
        !          1441:          {
        !          1442:               /k set
        !          1443:               m  k  evec_neg
        !          1444:          } for
        !          1445:       }
        !          1446:       { } ifelse
        !          1447:
        !          1448:       m2 0 gt
        !          1449:       {
        !          1450:          << esize 1 sub >> -1 1
        !          1451:          {
        !          1452:               /k set
        !          1453:               m  k  evec_neg
        !          1454:          } for
        !          1455:       }
        !          1456:       { } ifelse
        !          1457:
        !          1458:     ] /om set
        !          1459:      om [ 0 << m 2 idiv >> 1 sub] 0 put
        !          1460:      om [ << m 2 idiv >> 1 add  << m 2 idiv >> 1 sub] 0 put
        !          1461:     /arg1 om def
        !          1462:    ] pop
        !          1463:    popVariables
        !          1464:    arg1
        !          1465: } def
        !          1466:
        !          1467: %note  2003.09.29
        !          1468: /ecart.elimination_order {
        !          1469: %% [x-list d-list params]  (x,y,z) elimination_order
        !          1470: %%  vars                    evars
        !          1471: %% [x-list d-list params order]
        !          1472:   /arg2 set  /arg1 set
        !          1473:   [/vars /evars /univ /order /perm /univ0 /compl /m /omtmp] pushVariables
        !          1474:   /vars arg1 def /evars [arg2 to_records pop] def
        !          1475:   [
        !          1476:     /univ vars 0 get reverse
        !          1477:           vars 1 get reverse join
        !          1478:     def
        !          1479:
        !          1480:     << univ length 2 sub >>
        !          1481:     << evars length >>
        !          1482:     ecart.eliminationOrderTemplate /order set
        !          1483:
        !          1484:     [[1]] order oplus [[1]] oplus /order set
        !          1485:
        !          1486:     /m order length 2 sub def
        !          1487:     /omtmp [1 1 m 2 add { pop 0 } for ] def
        !          1488:     omtmp << m 2 idiv >> 1 put
        !          1489:     order  omtmp append /order set
        !          1490:     % order pmat
        !          1491:
        !          1492:     /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
        !          1493:
        !          1494:     /compl
        !          1495:       [univ 0 get] evars join evars univ0 complement join
        !          1496:     def
        !          1497:     compl univ
        !          1498:     getPerm /perm set
        !          1499:     %%perm :: univ :: compl ::
        !          1500:
        !          1501:     order perm permuteOrderMatrix /order set
        !          1502:
        !          1503:
        !          1504:     vars [order] join /arg1 set
        !          1505:   ] pop
        !          1506:   popVariables
        !          1507:   arg1
        !          1508: } def
        !          1509:
        !          1510: /ecart.define_ring {
        !          1511:    /arg1 set
        !          1512:    [/rp /param /foo] pushVariables
        !          1513:    [/rp arg1 def
        !          1514:
        !          1515:      rp 0 get length 3 eq {
        !          1516:        rp 0  [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
        !          1517:              ( ) ecart.elimination_order put
        !          1518:      } { } ifelse
        !          1519:
        !          1520:     [
        !          1521:       rp 0 get 0 get             %% x-list
        !          1522:       rp 0 get 1 get             %% d-list
        !          1523:       rp 0 get 2 get /param set
        !          1524:       param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
        !          1525:       param                      %% parameters.
        !          1526:       rp 0 get 3 get             %% order matrix.
        !          1527:       rp length 2 eq
        !          1528:       { [  ] }                   %% null optional argument.
        !          1529:       { rp 2 get }
        !          1530:       ifelse
        !          1531:     ]  /foo set
        !          1532:     foo aload pop set_up_ring@
        !          1533:    ] pop
        !          1534:    popVariables
        !          1535:    [(CurrentRingp)] system_variable
        !          1536: } def
        !          1537: /ecart.weight_vector {
        !          1538:   /arg2 set  /arg1 set
        !          1539:   [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
        !          1540:   /vars arg1 def /w-vectors arg2 def
        !          1541:   [
        !          1542:     /univ vars 0 get reverse
        !          1543:           vars 1 get reverse join
        !          1544:     def
        !          1545:     [
        !          1546:     0 1 << w-vectors length 1 sub >>
        !          1547:     {
        !          1548:       /k set
        !          1549:       univ w-vectors k get w_to_vec
        !          1550:     } for
        !          1551:     ] /order1 set
        !          1552:     %% order1 ::
        !          1553:
        !          1554:     vars ( ) ecart.elimination_order 3 get /order2 set
        !          1555:     vars [ << order1 order2 join >> ] join /arg1 set
        !          1556:   ] pop
        !          1557:   popVariables
        !          1558:   arg1
        !          1559: } def
        !          1560:
        !          1561: %% end of for ecart.define_ring
        !          1562:
1.5       takayama 1563:
1.2       takayama 1564: ( ) message-quiet
1.5       takayama 1565:

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