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

1.13    ! takayama    1: % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.12 2003/08/26 05:06:00 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:
                     19: /ecart.dehomogenize {
                     20:  /arg1 set
                     21:  [/in.ecart.dehomogenize /ll /rr] pushVariables
                     22:  [
                     23:    /ll arg1 def
                     24:    ll tag 6 eq {
                     25:      ll { ecart.dehomogenize } map /ll set
                     26:    } {
                     27:      ll (0). eq {
                     28:      } {
                     29:        ll getRing /rr set
                     30:        ll [ [ (H) rr ,, (1) rr ,, ]
                     31:             [ (h) rr ,, (1) rr ,, ]] replace
                     32:        /ll set
                     33:      } ifelse
                     34:    } ifelse
                     35:    /arg1 ll def
                     36:  ] pop
                     37:  popVariables
                     38:  arg1
                     39: } def
                     40: [(ecart.dehomogenize)
                     41:  [(obj ecart.dehomogenize r)
                     42:   (h->1, H->1)
                     43: ]] putUsages
                     44:
                     45: /ecart.dehomogenizeH {
                     46:  /arg1 set
                     47:  [/in.ecart.dehomogenize /ll /rr] pushVariables
                     48:  [
                     49:    /ll arg1 def
                     50:    ll tag 6 eq {
                     51:      ll { ecart.dehomogenize } map /ll set
                     52:    } {
                     53:      ll (0). eq {
                     54:      } {
                     55:        ll getRing /rr set
                     56:        ll [ [ (H) rr ,, (1) rr ,, ] ] replace
                     57:        /ll set
                     58:      } ifelse
                     59:    } ifelse
                     60:    /arg1 ll def
                     61:  ] pop
                     62:  popVariables
                     63:  arg1
                     64: } def
                     65: [(ecart.dehomogenizeH)
                     66:  [(obj ecart.dehomogenizeH r)
                     67:   (H->1, h is not changed.)
                     68: ]] putUsages
                     69:
                     70: /ecart.homogenize01 {
                     71:  /arg1 set
1.11      takayama   72:  [/in.ecart.homogenize01 /ll /ll0] pushVariables
1.1       takayama   73:  [
                     74:    /ll arg1 def
1.11      takayama   75:    ll tag ArrayP eq {
                     76:      ll 0 get tag ArrayP eq not {
                     77:        [(degreeShift) [ ] ll ] homogenize   /arg1 set
                     78:      } {
                     79:        ll { ecart.homogenize01 } map /arg1 set
                     80:      } ifelse
                     81:    } {
                     82:        [(degreeShift) [ ] ll ] homogenize   /arg1 set
1.12      takayama   83:    } ifelse
1.1       takayama   84:  ] pop
                     85:  popVariables
                     86:  arg1
                     87: } def
                     88: [(ecart.homogenize01)
                     89:  [(obj ecart.homogenize01 r)
                     90:   (Example:  )
                     91:   (  [(x1,x2) ring_of_differential_operators )
                     92:   (   [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
                     93:   (    [(h) 1 (Dx1) 1 (Dx2) 1] )
                     94:   (    [(Dx1) 1 (Dx2) 1]   )
                     95:   (    [(x1) -1 (x2) -1])
                     96:   (   ] weight_vector )
                     97:   (   0  )
1.11      takayama   98:   (   [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
1.1       takayama   99:   (  ] define_ring)
                    100:   ( ecart.begin)
                    101:   ( [[1 -4 -2 5]] appell4 0 get /eqs set)
                    102:   ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
1.11      takayama  103:   ( {ecart.homogenize01} map /eqs2 set)
1.1       takayama  104:   ( [eqs2] groebner )
                    105: ]] putUsages
                    106:
                    107: /ecart.homogenize01_with_shiftVector {
                    108:  /arg2.set
                    109:  /arg1 set
1.11      takayama  110:  [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
1.1       takayama  111:  [
                    112:    /sv arg2 def
                    113:    /ll arg1 def
1.11      takayama  114:    ll tag ArrayP eq {
                    115:      ll 0 get tag ArrayP eq not {
                    116:        [(degreeShift) sv ll ] homogenize   /arg1 set
                    117:      } {
                    118:        ll { ecart.homogenize01_with_shiftVector } map /arg1 set
                    119:      } ifelse
                    120:    } {
                    121:        [(degreeShift) sv ll ] homogenize   /arg1 set
1.12      takayama  122:    } ifelse
1.1       takayama  123:  ] pop
                    124:  popVariables
                    125:  arg1
                    126: } def
                    127: [(ecart.dehomogenize01_with_degreeShift)
                    128:  [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
1.11      takayama  129:   (cf. homogenize)
1.1       takayama  130: ]] putUsages
                    131:
                    132: %% Aux functions to return the default weight vectors.
                    133: /ecart.wv1 {
                    134:   /arg1 set
                    135:   [/in.ecart.wv1 /v] pushVariables
                    136:   [
                    137:     /v arg1 def
                    138:     [(H) (h) v to_records pop] /v set
                    139:     v { 1 } map /v set
                    140:     /arg1 v def
                    141:   ] pop
                    142:   popVariables
                    143:   arg1
                    144: } def
                    145: /ecart.wv2 {
                    146:   /arg1 set
                    147:   [/in.ecart.wv2 /v] pushVariables
                    148:   [
                    149:     /v arg1 def
                    150:     [v to_records pop] /v set
                    151:     v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
                    152:     [(h) 1 ] v join /v set
                    153:     /arg1 v def
                    154:   ] pop
                    155:   popVariables
                    156:   arg1
                    157: } def
                    158:
1.7       takayama  159: /ecart.gb {ecartd.gb}  def
                    160:
                    161: [(ecart.gb)
                    162:  [(a ecart.gb b)
                    163:   (array a; array b;)
                    164:   $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
                    165:   (             in the ring of differential operators.)
                    166:   (The computation is done by using Ecart division algorithm and )
                    167:   (the double homogenization.)
                    168:   (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
                    169:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                    170:    $            to a ring. In the other cases, it returns the initial monominal.$
                    171:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    172:   (a : [f v];   array f; string v;  v is the variables. )
                    173:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
                    174:   (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
1.11      takayama  175:   (                array ds; ds is the degree shift for the ring. )
                    176:   (a : [f v w ds hdShift]; array f; string v; array of array w; w is the weight matirx.)
                    177:   (        array ds; ds is the degree shift for the ring. )
                    178:   (        array hsShift is the degree shift for the homogenization. cf.homogenize )
                    179:   $a : [f v w ds (no)]; array f; string v; array of array w; w is the weight matirx.$
                    180:   (       No automatic homogenization.)
1.7       takayama  181:   (  )
                    182:   $cf. ecarth.gb (homogenized),  ecartd.gb (dehomogenize) $
                    183:   ( )
                    184:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
                    185:   $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
                    186:   (Example 2: )
                    187:   $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.9       takayama  188:   $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb  /ff set ff pmat ;$
                    189:   (To set the current ring to the ring in which ff belongs )
                    190:   (      ff getRing ring_def  )
1.7       takayama  191:   (  )
                    192:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
                    193:   $             [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
1.10      takayama  194:   (   This example will cause an error on order.)
1.7       takayama  195:   (  )
                    196:   $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
                    197:   $             [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
1.10      takayama  198:   (   This example will cause an error on order.)
1.7       takayama  199:   (  )
                    200:   $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
                    201:   $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  [[0 1] [-3 1] ] ] ecart.gb pmat ; $
                    202:   (  )
                    203:   (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
                    204:   (    ecart.dehomogenize, ecart.dehomogenizeH)
                    205:   ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
                    206:   (                                                          define_ring )
                    207:   (/ecart.autoHomogenize 0 def )
                    208:   (               not to dehomogenize and homogenize)
                    209: ]] putUsages
                    210:
1.1       takayama  211: /ecart.gb.verbose 1 def
1.12      takayama  212: %ecarth.gb  s(H)-homogenized outputs.  GG's original version of ecart gb.
1.7       takayama  213: /ecarth.gb {
1.1       takayama  214:   /arg1 set
1.7       takayama  215:   [/in-ecarth.gb /aa /typev /setarg /f /v
1.1       takayama  216:    /gg /wv /vec /ans /rr /mm
                    217:    /degreeShift  /env2 /opt /ans.gb
1.12      takayama  218:    /hdShift
1.1       takayama  219:   ] pushVariables
                    220:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    221:   [
                    222:     /aa arg1 def
1.13    ! takayama  223:     aa isArray { } { ( << array >> ecarth.gb) error } ifelse
1.1       takayama  224:     /setarg 0 def
                    225:     /wv 0 def
                    226:     /degreeShift 0 def
1.12      takayama  227:     /hdShift 0 def
1.1       takayama  228:     /opt [(weightedHomogenization) 1] def
                    229:     aa { tag } map /typev set
                    230:     typev [ ArrayP ] eq
                    231:     {  /f aa 0 get def
                    232:        /v gb.v def
                    233:        /setarg 1 def
                    234:     } { } ifelse
                    235:     typev [ArrayP StringP] eq
                    236:     {  /f aa 0 get def
                    237:        /v aa 1 get def
                    238:        /setarg 1 def
                    239:     } { } ifelse
                    240:     typev [ArrayP RingP] eq
                    241:     {  /f aa 0 get def
                    242:        /v aa 1 get def
                    243:        /setarg 1 def
                    244:     } { } ifelse
                    245:     typev [ArrayP ArrayP] eq
                    246:     {  /f aa 0 get def
                    247:        /v aa 1 get from_records def
                    248:        /setarg 1 def
                    249:     } { } ifelse
                    250:     typev [ArrayP StringP ArrayP] eq
                    251:     {  /f aa 0 get def
                    252:        /v aa 1 get def
                    253:        /wv aa 2 get def
                    254:        /setarg 1 def
                    255:     } { } ifelse
                    256:     typev [ArrayP ArrayP ArrayP] eq
                    257:     {  /f aa 0 get def
                    258:        /v aa 1 get from_records def
                    259:        /wv aa 2 get def
                    260:        /setarg 1 def
                    261:     } { } ifelse
                    262:     typev [ArrayP StringP ArrayP ArrayP] eq
                    263:     {  /f aa 0 get def
                    264:        /v aa 1 get def
                    265:        /wv aa 2 get def
                    266:        /degreeShift aa 3 get def
                    267:        /setarg 1 def
                    268:     } { } ifelse
1.12      takayama  269:
                    270:     typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
                    271:     {  /f aa 0 get def
                    272:        /v aa 1 get def
                    273:        /wv aa 2 get def
                    274:        /degreeShift aa 3 get def
                    275:        /hdShift aa 4 get def
                    276:        /setarg 1 def
                    277:     } { } ifelse
1.1       takayama  278:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    279:     {  /f aa 0 get def
                    280:        /v aa 1 get from_records def
                    281:        /wv aa 2 get def
                    282:        /degreeShift aa 3 get def
                    283:        /setarg 1 def
                    284:     } { } ifelse
1.12      takayama  285:     typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
                    286:     {  /f aa 0 get def
                    287:        /v aa 1 get from_records def
                    288:        /wv aa 2 get def
                    289:        /degreeShift aa 3 get def
                    290:        /hdShift aa 4 get def
                    291:        /setarg 1 def
                    292:     } { } ifelse
                    293:     typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
                    294:     {  /f aa 0 get def
                    295:        /v aa 1 get from_records def
                    296:        /wv aa 2 get def
                    297:        /degreeShift aa 3 get def
                    298:        aa 4 get (no) eq {
                    299:          /hdShift -1 def
                    300:        } {
                    301:          (Unknown keyword for the 5th argument) error
                    302:        } ifelse
                    303:        /setarg 1 def
                    304:     } { } ifelse
1.13    ! takayama  305:     typev [ArrayP StringP ArrayP ArrayP StringP] eq
        !           306:     {  /f aa 0 get def
        !           307:        /v aa 1 get  def
        !           308:        /wv aa 2 get def
        !           309:        /degreeShift aa 3 get def
        !           310:        aa 4 get (no) eq {
        !           311:          /hdShift -1 def
        !           312:        } {
        !           313:          (Unknown keyword for the 5th argument) error
        !           314:        } ifelse
        !           315:        /setarg 1 def
        !           316:     } { } ifelse
1.1       takayama  317:
                    318:     /env1 getOptions def
                    319:
1.12      takayama  320:     ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } {  } ifelse
                    321:     setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
1.1       takayama  322:
                    323:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    324:
                    325:     %%% Start of the preprocess
                    326:     v tag RingP eq {
                    327:        /rr v def
                    328:     }{
                    329:       f getRing /rr set
                    330:     } ifelse
                    331:     %% To the normal form : matrix expression.
                    332:     f gb.toMatrixOfString /f set
                    333:     /mm gb.itWasMatrix def
                    334:
                    335:     rr tag 0 eq {
                    336:       %% Define our own ring
                    337:       v isInteger {
                    338:         (Error in gb: Specify variables) error
                    339:       } {  } ifelse
                    340:       wv isInteger {
                    341:         [v ring_of_differential_operators
1.6       takayama  342: %         [ v ecart.wv1 v ecart.wv2 ] weight_vector
1.3       takayama  343:          gb.characteristic
1.1       takayama  344:          opt
                    345:         ] define_ring
                    346:       }{
                    347:        degreeShift isInteger {
                    348:          [v ring_of_differential_operators
1.6       takayama  349: %          [v ecart.wv1 v ecart.wv2] wv join weight_vector
                    350:           wv weight_vector
1.3       takayama  351:           gb.characteristic
1.1       takayama  352:           opt
                    353:          ] define_ring
                    354:
                    355:        }{
                    356:          [v ring_of_differential_operators
1.6       takayama  357: %          [v ecart.wv1 v ecart.wv2] wv join weight_vector
                    358:           wv  weight_vector
1.3       takayama  359:           gb.characteristic
1.1       takayama  360:           [(degreeShift) degreeShift] opt join
                    361:           ] define_ring
                    362:
                    363:        } ifelse
                    364:       } ifelse
                    365:     } {
                    366:       %% Use the ring structre given by the input.
                    367:       v isInteger not {
                    368:         gb.warning {
                    369:          (Warning : the given ring definition is not used.) message
                    370:         } { } ifelse
                    371:       } {  } ifelse
                    372:       rr ring_def
                    373:       /wv rr gb.getWeight def
                    374:
                    375:     } ifelse
                    376:     %%% Enf of the preprocess
                    377:
                    378:     ecart.gb.verbose {
1.6       takayama  379:       (The first and the second weight vectors for automatic homogenization: )
1.1       takayama  380:        message
                    381:        v ecart.wv1 message
                    382:        v ecart.wv2 message
                    383:        degreeShift isInteger { }
                    384:        {
                    385:          (The degree shift is ) messagen
                    386:          degreeShift message
                    387:        } ifelse
                    388:     } { } ifelse
                    389:
1.5       takayama  390:     %%BUG: case of v is integer
                    391:     v ecart.checkOrder
                    392:
1.1       takayama  393:     ecart.begin
                    394:
                    395:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.13    ! takayama  396:
1.12      takayama  397:
                    398:     hdShift tag 1 eq {
                    399:      ecart.autoHomogenize not hdShift -1 eq or {
                    400: % No automatic h-s-homogenization.
                    401:        f { {. } map} map /f set
                    402:      } {
                    403: % Automatic h-s-homogenization without degreeShift
1.13    ! takayama  404:     (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
        !           405:       message
1.12      takayama  406:        f { {. ecart.dehomogenize} map} map /f set
                    407:        f ecart.homogenize01 /f set
                    408:      } ifelse
                    409:    } {
                    410: % Automatic h-s-homogenization with degreeShift
1.13    ! takayama  411:     (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
        !           412:       message
1.12      takayama  413:        f { {. ecart.dehomogenize} map} map /f set
                    414:        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
                    415:    }ifelse
                    416:
1.1       takayama  417:     ecart.needSyz {
                    418:       [f [(needSyz)] gb.options join ] groebner /gg set
                    419:     } {
                    420:       [f gb.options] groebner 0 get /gg set
                    421:     } ifelse
                    422:
                    423:     ecart.needSyz {
                    424:       mm {
                    425:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
1.11      takayama  426:        } { /ans.gb gg 0 get def } ifelse
                    427:        /ans [gg 2 get , ans.gb , gg 1 get , f ] def
                    428: %      ans pmat ;
1.1       takayama  429:     } {
                    430:       wv isInteger {
                    431:         /ans [gg gg {init} map] def
                    432:       }{
1.10      takayama  433:        degreeShift isInteger {
                    434:          /ans [gg gg {wv 0 get weightv init} map] def
                    435:        } {
                    436:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    437:        } ifelse
1.1       takayama  438:       }ifelse
                    439:
                    440:       %% Postprocess : recover the matrix expression.
                    441:       mm {
                    442:         ans { /tmp set [mm tmp] toVectors } map
                    443:         /ans set
                    444:       }{ }
                    445:       ifelse
                    446:     } ifelse
                    447:
                    448:     ecart.end
                    449:
                    450:     %%
                    451:     env1 restoreOptions  %% degreeShift changes "grade"
                    452:
                    453:     /arg1 ans def
                    454:   ] pop
                    455:   popEnv
                    456:   popVariables
                    457:   arg1
                    458: } def
1.7       takayama  459: (ecarth.gb ) messagen-quiet
1.1       takayama  460:
1.7       takayama  461: [(ecarth.gb)
                    462:  [(a ecarth.gb b)
1.1       takayama  463:   (array a; array b;)
                    464:   $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
                    465:   (             in the ring of differential operators.)
1.12      takayama  466:   (The computation is done by using Ecart division algorithm.)
                    467:   $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$
                    468:   (they are not dehomogenized.)
1.1       takayama  469:   (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
                    470:    $            ii is the initial ideal in case of w is given or <<a>> belongs$
                    471:    $            to a ring. In the other cases, it returns the initial monominal.$
                    472:   (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
                    473:   (a : [f v];   array f; string v;  v is the variables. )
                    474:   (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
                    475:   (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
                    476:   (                array ds; ds is the degree shift )
                    477:   (  )
                    478:   (/ecart.autoHomogenize 0 def )
                    479:   (               not to dehomogenize and homogenize)
                    480:   ( )
                    481:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7       takayama  482:   $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1       takayama  483:   (Example 2: )
                    484:   (To put H and h=1, type in, e.g., )
                    485:   $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.7       takayama  486:   $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
1.1       takayama  487:   (  )
                    488:   $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
1.7       takayama  489:   $             [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
1.1       takayama  490:   (  )
                    491:   $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  492:   $             [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1       takayama  493:   (  )
                    494:   $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.7       takayama  495:   $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  [[0 1] [-3 1] ] ] ecarth.gb pmat ; (buggy infinite loop)$
1.1       takayama  496:   (  )
1.7       takayama  497:   (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
1.1       takayama  498:   (    ecart.dehomogenize, ecart.dehomogenizeH)
                    499:   ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
                    500:   (                                                          define_ring )
                    501: ]] putUsages
                    502:
                    503:
                    504: /ecart.syz {
                    505:   /arg1 set
                    506:   [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
                    507:   [
                    508:     /ff arg1 def
                    509:     /ecart.save.needSyz ecart.needSyz def
                    510:     /ecart.needSyz 1 def
                    511:     ff ecart.gb /ff.ans set
                    512:     /ecart.needSyz ecart.save.needSyz def
                    513:     /arg1 ff.ans def
                    514:   ] pop
                    515:   popVariables
                    516:   arg1
                    517: } def
                    518: (ecart.syz ) messagen-quiet
                    519:
                    520: [(ecart.syz)
                    521:  [(a ecart.syz b)
                    522:   (array a; array b;)
                    523:   $b : [syzygy gb tmat input];  gb = tmat * input $
                    524:   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
1.8       takayama  525:   $             [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
1.1       takayama  526:   $ ff 0 get ff 3 get mul pmat $
                    527:   $ ff 2 get  ff 3 get mul [ff 1 get ] transpose sub pmat ; $
                    528:   (  )
1.9       takayama  529:   (To set the current ring to the ring in which ff belongs )
                    530:   (      ff getRing ring_def  )
1.1       takayama  531:   $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  532:   $             [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ]  [[0 1] [-3 1] ] ] ecart.syz pmat ; $
1.1       takayama  533:   (  )
                    534:   (cf. ecart.gb)
                    535:   (    /ecart.autoHomogenize 0 def )
                    536: ]] putUsages
1.2       takayama  537:
1.3       takayama  538:
                    539: /ecartn.begin {
                    540:   (red@) (standard) switch_function
                    541: %%  (red@) (ecart) switch_function
                    542:   [(Ecart) 1] system_variable
                    543:   [(CheckHomogenization) 0] system_variable
                    544:   [(ReduceLowerTerms) 0] system_variable
                    545:   [(AutoReduce) 0] system_variable
                    546:   [(EcartAutomaticHomogenization) 0] system_variable
                    547: } def
                    548: /ecartn.gb {
                    549:   /arg1 set
                    550:   [/in-ecartn.gb /aa /typev /setarg /f /v
                    551:    /gg /wv /vec /ans /rr /mm
                    552:    /degreeShift  /env2 /opt /ans.gb
                    553:   ] pushVariables
                    554:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    555:   [
                    556:     /aa arg1 def
1.13    ! takayama  557:     aa isArray { } { ( << array >> ecartn.gb) error } ifelse
1.3       takayama  558:     /setarg 0 def
                    559:     /wv 0 def
                    560:     /degreeShift 0 def
                    561:     /opt [(weightedHomogenization) 1] def
                    562:     aa { tag } map /typev set
                    563:     typev [ ArrayP ] eq
                    564:     {  /f aa 0 get def
                    565:        /v gb.v def
                    566:        /setarg 1 def
                    567:     } { } ifelse
                    568:     typev [ArrayP StringP] eq
                    569:     {  /f aa 0 get def
                    570:        /v aa 1 get def
                    571:        /setarg 1 def
                    572:     } { } ifelse
                    573:     typev [ArrayP RingP] eq
                    574:     {  /f aa 0 get def
                    575:        /v aa 1 get def
                    576:        /setarg 1 def
                    577:     } { } ifelse
                    578:     typev [ArrayP ArrayP] eq
                    579:     {  /f aa 0 get def
                    580:        /v aa 1 get from_records def
                    581:        /setarg 1 def
                    582:     } { } ifelse
                    583:     typev [ArrayP StringP ArrayP] eq
                    584:     {  /f aa 0 get def
                    585:        /v aa 1 get def
                    586:        /wv aa 2 get def
                    587:        /setarg 1 def
                    588:     } { } ifelse
                    589:     typev [ArrayP ArrayP ArrayP] eq
                    590:     {  /f aa 0 get def
                    591:        /v aa 1 get from_records def
                    592:        /wv aa 2 get def
                    593:        /setarg 1 def
                    594:     } { } ifelse
                    595:     typev [ArrayP StringP ArrayP ArrayP] eq
                    596:     {  /f aa 0 get def
                    597:        /v aa 1 get def
                    598:        /wv aa 2 get def
                    599:        /degreeShift aa 3 get def
                    600:        /setarg 1 def
                    601:     } { } ifelse
                    602:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    603:     {  /f aa 0 get def
                    604:        /v aa 1 get from_records def
                    605:        /wv aa 2 get def
                    606:        /degreeShift aa 3 get def
                    607:        /setarg 1 def
                    608:     } { } ifelse
                    609:
                    610:     /env1 getOptions def
                    611:
                    612:     setarg { } { (ecart.gb : Argument mismatch) error } ifelse
                    613:
                    614:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    615:
                    616:     %%% Start of the preprocess
                    617:     v tag RingP eq {
                    618:        /rr v def
                    619:     }{
                    620:       f getRing /rr set
                    621:     } ifelse
                    622:     %% To the normal form : matrix expression.
                    623:     f gb.toMatrixOfString /f set
                    624:     /mm gb.itWasMatrix def
                    625:
                    626:     rr tag 0 eq {
                    627:       %% Define our own ring
                    628:       v isInteger {
                    629:         (Error in gb: Specify variables) error
                    630:       } {  } ifelse
                    631:       wv isInteger {
                    632:         [v ring_of_differential_operators
                    633:          [ v ecart.wv1 v ecart.wv2 ] weight_vector
                    634:          gb.characteristic
                    635:          opt
                    636:         ] define_ring
                    637:       }{
                    638:        degreeShift isInteger {
                    639:          [v ring_of_differential_operators
                    640:           [v ecart.wv1 v ecart.wv2] wv join weight_vector
                    641:           gb.characteristic
                    642:           opt
                    643:          ] define_ring
                    644:
                    645:        }{
                    646:          [v ring_of_differential_operators
                    647:           [v ecart.wv1 v ecart.wv2] wv join weight_vector
                    648:           gb.characteristic
                    649:           [(degreeShift) degreeShift] opt join
                    650:           ] define_ring
                    651:
                    652:        } ifelse
                    653:       } ifelse
                    654:     } {
                    655:       %% Use the ring structre given by the input.
                    656:       v isInteger not {
                    657:         gb.warning {
                    658:          (Warning : the given ring definition is not used.) message
                    659:         } { } ifelse
                    660:       } {  } ifelse
                    661:       rr ring_def
                    662:       /wv rr gb.getWeight def
                    663:
                    664:     } ifelse
                    665:     %%% Enf of the preprocess
                    666:
                    667:     ecart.gb.verbose {
                    668:       (The first and the second weight vectors are automatically set as follows)
                    669:        message
                    670:        v ecart.wv1 message
                    671:        v ecart.wv2 message
                    672:        degreeShift isInteger { }
                    673:        {
                    674:          (The degree shift is ) messagen
                    675:          degreeShift message
                    676:        } ifelse
                    677:     } { } ifelse
                    678:
1.5       takayama  679:     %%BUG: case of v is integer
                    680:     v ecart.checkOrder
                    681:
1.3       takayama  682:     ecartn.begin
                    683:
                    684:     ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
                    685:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
                    686:     ecart.autoHomogenize {
                    687:       (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
                    688:       message
                    689:     } { } ifelse
                    690:     ecart.autoHomogenize {
                    691:       f { {. ecart.dehomogenize} map} map /f set
                    692:       f ecart.homogenize01 /f set
                    693:     }{
                    694:       f { {. } map } map /f set
                    695:     } ifelse
                    696:     ecart.needSyz {
                    697:       [f [(needSyz)] gb.options join ] groebner /gg set
                    698:     } {
                    699:       [f gb.options] groebner 0 get /gg set
                    700:     } ifelse
                    701:
                    702:     ecart.needSyz {
                    703:       mm {
                    704:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
                    705:       } { /ans.gb gg 0 get def } ifelse
                    706:       /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11      takayama  707: %      ans pmat ;
1.3       takayama  708:     } {
                    709:       wv isInteger {
                    710:         /ans [gg gg {init} map] def
                    711:       }{
1.10      takayama  712:        degreeShift isInteger {
                    713:          /ans [gg gg {wv 0 get weightv init} map] def
                    714:        } {
                    715:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    716:        } ifelse
1.3       takayama  717:       }ifelse
                    718:
                    719:       %% Postprocess : recover the matrix expression.
                    720:       mm {
                    721:         ans { /tmp set [mm tmp] toVectors } map
                    722:         /ans set
                    723:       }{ }
                    724:       ifelse
                    725:     } ifelse
                    726:
                    727:     ecart.end
                    728:
                    729:     %%
                    730:     env1 restoreOptions  %% degreeShift changes "grade"
                    731:
                    732:     /arg1 ans def
                    733:   ] pop
                    734:   popEnv
                    735:   popVariables
                    736:   arg1
                    737: } def
                    738: (ecartn.gb[gb by non-ecart division] ) messagen-quiet
1.4       takayama  739:
                    740: /ecartd.gb {
                    741:   /arg1 set
                    742:   [/in-ecart.gb /aa /typev /setarg /f /v
                    743:    /gg /wv /vec /ans /rr /mm
                    744:    /degreeShift  /env2 /opt /ans.gb
1.11      takayama  745:    /hdShift
1.4       takayama  746:   ] pushVariables
                    747:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    748:   [
                    749:     /aa arg1 def
1.13    ! takayama  750:     aa isArray { } { ( << array >> ecartd.gb) error } ifelse
1.4       takayama  751:     /setarg 0 def
                    752:     /wv 0 def
                    753:     /degreeShift 0 def
1.11      takayama  754:     /hdShift 0 def
1.4       takayama  755:     /opt [(weightedHomogenization) 1] def
                    756:     aa { tag } map /typev set
                    757:     typev [ ArrayP ] eq
                    758:     {  /f aa 0 get def
                    759:        /v gb.v def
                    760:        /setarg 1 def
                    761:     } { } ifelse
                    762:     typev [ArrayP StringP] eq
                    763:     {  /f aa 0 get def
                    764:        /v aa 1 get def
                    765:        /setarg 1 def
                    766:     } { } ifelse
                    767:     typev [ArrayP RingP] eq
                    768:     {  /f aa 0 get def
                    769:        /v aa 1 get def
                    770:        /setarg 1 def
                    771:     } { } ifelse
                    772:     typev [ArrayP ArrayP] eq
                    773:     {  /f aa 0 get def
                    774:        /v aa 1 get from_records def
                    775:        /setarg 1 def
                    776:     } { } ifelse
                    777:     typev [ArrayP StringP ArrayP] eq
                    778:     {  /f aa 0 get def
                    779:        /v aa 1 get def
                    780:        /wv aa 2 get def
                    781:        /setarg 1 def
                    782:     } { } ifelse
                    783:     typev [ArrayP ArrayP ArrayP] eq
                    784:     {  /f aa 0 get def
                    785:        /v aa 1 get from_records def
                    786:        /wv aa 2 get def
                    787:        /setarg 1 def
                    788:     } { } ifelse
                    789:     typev [ArrayP StringP ArrayP ArrayP] eq
                    790:     {  /f aa 0 get def
                    791:        /v aa 1 get def
                    792:        /wv aa 2 get def
                    793:        /degreeShift aa 3 get def
                    794:        /setarg 1 def
                    795:     } { } ifelse
                    796:     typev [ArrayP ArrayP ArrayP ArrayP] eq
                    797:     {  /f aa 0 get def
                    798:        /v aa 1 get from_records def
                    799:        /wv aa 2 get def
                    800:        /degreeShift aa 3 get def
                    801:        /setarg 1 def
                    802:     } { } ifelse
1.11      takayama  803:     typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
                    804:     {  /f aa 0 get def
                    805:        /v aa 1 get def
                    806:        /wv aa 2 get def
                    807:        /degreeShift aa 3 get def
                    808:        /hdShift aa 4 get def
                    809:        /setarg 1 def
                    810:     } { } ifelse
                    811:     typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
                    812:     {  /f aa 0 get def
                    813:        /v aa 1 get from_records def
                    814:        /wv aa 2 get def
                    815:        /degreeShift aa 3 get def
                    816:        /hdShift aa 4 get def
                    817:        /setarg 1 def
                    818:     } { } ifelse
                    819:     typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
                    820:     {  /f aa 0 get def
                    821:        /v aa 1 get from_records def
                    822:        /wv aa 2 get def
                    823:        /degreeShift aa 3 get def
                    824:        aa 4 get (no) eq {
                    825:          /hdShift -1 def
                    826:        } {
                    827:          (Unknown keyword for the 5th argument) error
                    828:        } ifelse
                    829:        /setarg 1 def
                    830:     } { } ifelse
1.13    ! takayama  831:     typev [ArrayP StringP ArrayP ArrayP StringP] eq
        !           832:     {  /f aa 0 get def
        !           833:        /v aa 1 get def
        !           834:        /wv aa 2 get def
        !           835:        /degreeShift aa 3 get def
        !           836:        aa 4 get (no) eq {
        !           837:          /hdShift -1 def
        !           838:        } {
        !           839:          (Unknown keyword for the 5th argument) error
        !           840:        } ifelse
        !           841:        /setarg 1 def
        !           842:     } { } ifelse
1.4       takayama  843:
                    844:     /env1 getOptions def
                    845:
                    846:     setarg { } { (ecart.gb : Argument mismatch) error } ifelse
                    847:
                    848:     [(KanGBmessage) ecart.gb.verbose ] system_variable
                    849:     $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message
                    850:
                    851:     %%% Start of the preprocess
                    852:     v tag RingP eq {
                    853:        /rr v def
                    854:     }{
                    855:       f getRing /rr set
                    856:     } ifelse
                    857:     %% To the normal form : matrix expression.
                    858:     f gb.toMatrixOfString /f set
                    859:     /mm gb.itWasMatrix def
                    860:
                    861:     rr tag 0 eq {
                    862:       %% Define our own ring
                    863:       v isInteger {
                    864:         (Error in gb: Specify variables) error
                    865:       } {  } ifelse
                    866:       wv isInteger {
                    867:         (Give an weight vector such that x < 1) error
                    868:       }{
                    869:        degreeShift isInteger {
                    870:          [v ring_of_differential_operators
                    871:            wv weight_vector
                    872:           gb.characteristic
                    873:           opt
                    874:          ] define_ring
                    875:
                    876:        }{
                    877:          [v ring_of_differential_operators
                    878:            wv weight_vector
                    879:           gb.characteristic
                    880:           [(degreeShift) degreeShift] opt join
                    881:           ] define_ring
                    882:
                    883:        } ifelse
                    884:       } ifelse
                    885:     } {
                    886:       %% Use the ring structre given by the input.
                    887:       v isInteger not {
                    888:         gb.warning {
                    889:          (Warning : the given ring definition is not used.) message
                    890:         } { } ifelse
                    891:       } {  } ifelse
                    892:       rr ring_def
                    893:       /wv rr gb.getWeight def
                    894:
                    895:     } ifelse
                    896:     %%% Enf of the preprocess
                    897:
                    898:     ecart.gb.verbose {
                    899:        degreeShift isInteger { }
                    900:        {
                    901:          (The degree shift is ) messagen
                    902:          degreeShift message
                    903:        } ifelse
                    904:     } { } ifelse
                    905:
1.5       takayama  906:     %%BUG: case of v is integer
                    907:     v ecart.checkOrder
                    908:
1.8       takayama  909:     ecartd.begin
1.4       takayama  910:
                    911:     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
                    912:
1.11      takayama  913:     hdShift tag 1 eq {
1.12      takayama  914:      ecart.autoHomogenize not hdShift -1 eq  or {
1.11      takayama  915: % No automatic h-homogenization.
                    916:        f { {. } map} map /f set
                    917:      } {
                    918: % Automatic h-homogenization without degreeShift
1.13    ! takayama  919:        (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
1.11      takayama  920:        f { {. ecart.dehomogenize} map} map /f set
                    921:        f ecart.homogenize01 /f set
                    922:        f { { [[(H). (1).]] replace } map } map /f set
                    923:      } ifelse
                    924:    } {
                    925: % Automatic h-homogenization with degreeShift
1.13    ! takayama  926:        (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
1.11      takayama  927:        f { {. ecart.dehomogenize} map} map /f set
                    928:        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
                    929:        f { { [[(H). (1).]] replace } map } map /f set
                    930:    }ifelse
1.4       takayama  931:
                    932:     ecart.needSyz {
                    933:       [f [(needSyz)] gb.options join ] groebner /gg set
                    934:     } {
                    935:       [f gb.options] groebner 0 get /gg set
                    936:     } ifelse
                    937:
                    938:     ecart.needSyz {
                    939:       mm {
                    940:        gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
                    941:       } { /ans.gb gg 0 get def } ifelse
                    942:       /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11      takayama  943: %      ans pmat ;
1.4       takayama  944:     } {
                    945:       wv isInteger {
                    946:         /ans [gg gg {init} map] def
                    947:       }{
1.11      takayama  948: %% Get the initial ideal
1.10      takayama  949:        degreeShift isInteger {
                    950:          /ans [gg gg {wv 0 get weightv init} map] def
                    951:        } {
                    952:          /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
                    953:        } ifelse
1.4       takayama  954:       }ifelse
                    955:
                    956:       %% Postprocess : recover the matrix expression.
                    957:       mm {
                    958:         ans { /tmp set [mm tmp] toVectors } map
                    959:         /ans set
                    960:       }{ }
                    961:       ifelse
                    962:     } ifelse
                    963:
1.8       takayama  964:     ecartd.end
1.4       takayama  965:
                    966:     %%
                    967:     env1 restoreOptions  %% degreeShift changes "grade"
                    968:
                    969:     /arg1 ans def
                    970:   ] pop
                    971:   popEnv
                    972:   popVariables
                    973:   arg1
                    974: } def
                    975: (ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
1.2       takayama  976:
1.5       takayama  977: /ecart.checkOrder {
                    978:   /arg1 set
                    979:   [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
                    980:   [
                    981:     /vv arg1 def
                    982:     vv isArray
                    983:     { } { [vv to_records pop] /vv set } ifelse
                    984:     vv {toString} map /vv set
                    985:     vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
                    986:     % Starting the checks.
                    987:     0 1 vv length 1 sub {
                    988:        /i set
                    989:        vv i get . dd i get . mul /tt set
                    990:        tt @@@.hsymbol . add init tt eq { }
                    991:        { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
                    992:     } for
                    993:
                    994:     0 1 vv length 1 sub {
                    995:        /i set
                    996:        vv i get . /tt set
                    997:        tt (1). add init (1). eq { }
1.6       takayama  998:        { [vv i get ( is larger than 1 ) ] cat error} ifelse
1.5       takayama  999:     } for
                   1000:     /arg1 1 def
                   1001:   ] pop
                   1002:   popVariables
                   1003:   arg1
                   1004: } def
                   1005: [(ecart.checkOrder)
                   1006:  [(v ecart.checkOrder bool checks if the given order is relevant)
                   1007:   (for the ecart division.)
                   1008:   (cf. ecartd.gb, ecart.gb, ecartn.gb)
                   1009:  ]
                   1010: ] putUsages
                   1011:
                   1012: /ecart.wv_last {
                   1013:   /arg1 set
                   1014:   [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
                   1015:   [
                   1016:     /vv arg1 def
                   1017:     vv isArray
                   1018:     { } { [vv to_records pop] /vv set } ifelse
                   1019:     vv {toString} map /vv set
                   1020:     vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
                   1021:     vv {  -1 } map
                   1022:     dd {   1 } map join /arg1 set
                   1023:   ] pop
                   1024:   popVariables
                   1025:   arg1
                   1026: } def
                   1027: [(ecart.wv_last)
                   1028:  [(v ecart.wv_last wt )
                   1029:   (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
                   1030:   (Use this weight vector as the last weight vector for ecart division)
                   1031:   (if ecart.checkOrder complains about the order given.)
                   1032:  ]
                   1033: ] putUsages
1.13    ! takayama 1034:
        !          1035: /ecart.mimimalBase.test {
        !          1036:  [
        !          1037:     [    (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
        !          1038:     [    (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
        !          1039:     [    (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
        !          1040:     [    (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
        !          1041:     [    (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
        !          1042:     [  (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
        !          1043:     [  (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
        !          1044:     [  (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
        !          1045:   ]
        !          1046:   /ff set
        !          1047:
        !          1048:   /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
        !          1049:   /shift [ [1 0 1 0 0] ] def
        !          1050:   /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
        !          1051:
        !          1052:   [ff (t,x,y) weight shift nmshift] ecart.minimalBase
        !          1053:
        !          1054:
        !          1055: }  def
        !          1056: /test {ecart.mimimalBase.test} def
        !          1057:
        !          1058: %(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
        !          1059: /ecart.minimalBase.D1 {
        !          1060:   /arg1 set
        !          1061:   [/in-ecart.minimalBase.D1  /tt /v]  pushVariables
        !          1062:   [
        !          1063:     /v arg1 def
        !          1064:     [ v to_records pop] /v set
        !          1065:     v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
        !          1066:     v [(h) 1] join /arg1 set
        !          1067:   ] pop
        !          1068:   popVariables
        !          1069:   arg1
        !          1070: } def
        !          1071:
        !          1072: % [0 1 2] 1 ecart.removeElem [0 2]
        !          1073: /ecart.removeElem {
        !          1074:   /arg2 set
        !          1075:   /arg1 set
        !          1076:   [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
        !          1077:   [
        !          1078:     /v arg1 def
        !          1079:     /q arg2 def
        !          1080:     /ans v length 1 sub newVector def
        !          1081:     /j 0 def
        !          1082:     0 1 v length 1 sub {
        !          1083:       /i set
        !          1084:       i q eq not {
        !          1085:         ans j  v i get put
        !          1086:         /j j 1 add def
        !          1087:       } {  } ifelse
        !          1088:     } for
        !          1089:   ] pop
        !          1090:   popVariables
        !          1091:   arg1
        !          1092: } def
        !          1093:
        !          1094: [(ecart.minimalBase)
        !          1095: [([ff v weight_vector degreeShift [D_shift_n uv_shift_m]]  ecart.minimalBase mbase)
        !          1096: ]] putUsages
        !          1097: /ecart.minimalBase {
        !          1098:   /arg1 set
        !          1099:   [/in-ecart.minimalBase /ai1 /ai  /aa /typev /setarg /f /v
        !          1100:    /gg /wv /vec /ans /rr /mm
        !          1101:    /degreeShift  /env2 /opt /ss0
        !          1102:    /hdShift
        !          1103:     /degreeShiftD /degreeShiftUV
        !          1104:     /degreeShiftDnew /degreeShiftUVnew
        !          1105:     /tt
        !          1106:     /ai1_gr  /ai_gr
        !          1107:     /s /r /p /q /i /j /k
        !          1108:      /ai1_new /ai_new /ai_new2
        !          1109:    ] pushVariables
        !          1110:   [
        !          1111:     /aa arg1 def
        !          1112:     aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
        !          1113:     /setarg 0 def
        !          1114:     /wv 0 def
        !          1115:     /degreeShift 0 def
        !          1116:     /hdShift 0 def
        !          1117:     aa { tag } map /typev set
        !          1118:     typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
        !          1119:     {  /f aa 0 get def
        !          1120:        /v aa 1 get def
        !          1121:        /wv aa 2 get def
        !          1122:        /degreeShift aa 3 get def
        !          1123:        /hdShift aa 4 get def
        !          1124:        /setarg 1 def
        !          1125:     } { } ifelse
        !          1126:     typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
        !          1127:     {  /f aa 0 get def
        !          1128:        /v aa 1 get from_records def
        !          1129:        /wv aa 2 get def
        !          1130:        /degreeShift aa 3 get def
        !          1131:        /hdShift aa 4 get def
        !          1132:        /setarg 1 def
        !          1133:     } { } ifelse
        !          1134:     setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
        !          1135:
        !          1136:     [(KanGBmessage) ecart.gb.verbose ] system_variable
        !          1137:
        !          1138:     f 0 get tag ArrayP eq {  }
        !          1139:     {  f { /tt set [ tt ] } map /f set } ifelse
        !          1140:     [f v wv degreeShift (no)] ecart.syz /ss0 set
        !          1141:
        !          1142:     ss0 getRing ring_def
        !          1143:     /degreeShiftD  hdShift 0 get def
        !          1144:     /degreeShiftUV hdShift 1 get def
        !          1145: %      -- ai --> D^r -- ai1 --> D^rr
        !          1146:     /ai1  f  { { . } map } map def
        !          1147:     /ai  ss0 0 get def
        !          1148:
        !          1149:    {
        !          1150:     /degreeShiftUVnew
        !          1151:        ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all  } map
        !          1152:     def
        !          1153:     (degreeShiftUVnew=) messagen degreeShiftUVnew message
        !          1154:
        !          1155:     /degreeShiftDnew
        !          1156:        ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ]  ord_ws_all}
        !          1157:             map
        !          1158:     def
        !          1159:     (degreeShiftDnew=) messagen degreeShiftDnew message
        !          1160:
        !          1161:     ai {[wv 0 get weightv  degreeShiftUVnew] init} map /ai_gr set
        !          1162:
        !          1163: %C  Note 2003.8.26
        !          1164:
        !          1165:     /s ai length def
        !          1166:     /r ai 0 get length def
        !          1167:
        !          1168:     /itIsMinimal 1 def
        !          1169:     0 1 s 1 sub {
        !          1170:       /i set
        !          1171:       0 1 r 1 sub {
        !          1172:         /j set
        !          1173:
        !          1174:         [(isConstantAll) ai_gr i get j get] gbext
        !          1175:         ai_gr i get j get (0). eq not and
        !          1176:         {
        !          1177:            /itIsMinimal 0 def
        !          1178:            /p i def /q j def
        !          1179:         } {  } ifelse
        !          1180:       } for
        !          1181:     } for
        !          1182:
        !          1183:
        !          1184:     itIsMinimal { exit } { } ifelse
        !          1185:
        !          1186: %    construct new ai and ai1 (A_i and A_{i-1})
        !          1187:      /ai1_new  r 1 sub newVector def
        !          1188:      /j 0 def
        !          1189:      0 1 r 1 sub {
        !          1190:        /i set
        !          1191:        i q eq not {
        !          1192:           ai1_new j ai1 i get put
        !          1193:           /j  j 1 add def
        !          1194:        } { } ifelse
        !          1195:      } for
        !          1196:
        !          1197:      /ai_new [s  r] newMatrix def
        !          1198:      0 1 s 1 sub {
        !          1199:        /j set
        !          1200:        0 1 r 1 sub {
        !          1201:          /k set
        !          1202:          ai_new [j k]
        !          1203:             << ai p get q get >> << ai j get k get >> mul
        !          1204:             << ai j get q get >> << ai p get k get >> mul
        !          1205:             sub
        !          1206:          put
        !          1207:        } for
        !          1208:      } for
        !          1209:
        !          1210: % remove 0 column
        !          1211:      /ai_new2 [s 1 sub r 1 sub] newMatrix def
        !          1212:      /j 0 def
        !          1213:      0 1 s 1 sub {
        !          1214:        /i set
        !          1215:        i p eq not {
        !          1216:           ai_new2 j << ai_new i get q ecart.removeElem >> put
        !          1217:           /j  j 1 add def
        !          1218:        } { } ifelse
        !          1219:      } for
        !          1220:
        !          1221: %   ( ) error
        !          1222:      /ai1 ai1_new def
        !          1223:      /ai ai_new2 def
        !          1224:
        !          1225:    } loop
        !          1226:    /arg1 ai1 def
        !          1227:   ] pop
        !          1228:   popVariables
        !          1229:   arg1
        !          1230: } def
        !          1231:
1.5       takayama 1232:
1.2       takayama 1233: ( ) message-quiet
1.5       takayama 1234:

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