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

Annotation of OpenXM/src/kan96xx/Doc/slope.sm1, Revision 1.3

1.3     ! takayama    1: % $OpenXM: OpenXM/src/kan96xx/Doc/slope.sm1,v 1.2 2001/06/18 03:12:21 takayama Exp $
1.2       takayama    2: (oxasir.sm1.loaded) boundp not {
                      3:    [(parse) (oxasir.sm1)  pushfile] extension
                      4: } { } ifelse
                      5: (cohom.sm1.loaded) boundp not {
                      6:    [(parse) (cohom.sm1)  pushfile] extension
                      7: } { } ifelse
1.1       takayama    8: $slope.sm1, computing the slopes of a D-ideal:  June 15, 2000$ message
1.3     ! takayama    9: $                            (C) N.Takayama, F.Castro-Jimenez$ message
1.1       takayama   10: $Imported commands:  slope $ message
                     11: /slope.verbose 1 def
                     12: /gb.warning 0 def
                     13: /slope.geometric 1 def %%Computing the geometric slope. Load cohom.sm1 and oxasir.
                     14:
                     15: /slope.infinity (99999999999999999999).. def
                     16: /w_support {
                     17:   /arg2 set
                     18:   /arg1 set
                     19:   [/in-w_support /f /wvec  /ans /g /tt] pushVariables
                     20:   [
                     21:      /f  arg1 def
                     22:      /wvec arg2 def
                     23:      /ans [ ] def
                     24:      {
                     25:         f (0). eq { exit } { } ifelse
                     26:         f init /g set
                     27:         wvec { g 2 1 roll ord_w (universalNumber) dc } map /tt set
                     28:         ans tt append /ans set
                     29:         f g sub /f set
                     30:      } loop
                     31:      /arg1 ans def
                     32:   ] pop
                     33:   popVariables
                     34:   arg1
                     35: } def
                     36:
                     37: [(w_support)
                     38:  [$f [w1 w2 ...] w_support [ [i1 i2 ...] [j1 j2 ...] [k1 k2 ...] ...]$
                     39:   $ i1, ..., j1, ..., k1, ... are universal numbers. $
                     40:   $Example: (x Dx+ x ). [ [(x) -1 (Dx) 1] [(Dx) 1]] w_support$
                     41:  ]
                     42: ] putUsages
                     43:
                     44:
                     45: /w_supports_of_I {
                     46:   /arg1 set
                     47:   [/in-w_supports_of_I /ans /v /ff /wvec /gg /gg2] pushVariables
                     48:   [
                     49:      /ff arg1 0 get def
                     50:      /v arg1 1 get def
                     51:      /wvec arg1 2 get def
                     52:      wvec { [ 2 1 roll ] [ ff v 4 -1 roll ] gb } map /gg set
                     53:      gg { 0 get } map /gg set
                     54:      gg flatten /gg2 set
                     55:      gg2 message
                     56:      gg2 0 get (ring) dc ring_def
                     57:      gg2 { (string) dc  . } map /gg2 set % reparse
                     58:      gg2 { wvec w_support } map /ans set
                     59:      /arg1 [ans gg] def
                     60:   ] pop
                     61:   popVariables
                     62:   arg1
                     63: } def
                     64:
                     65: [(w_supports_of_I)
                     66:  [$[f v [w1 w2 ...]] w_support_of_I [supports gb]$
                     67:   $Example 1: [[(x Dx + 2 y Dy) (Dx^2-Dy)] (x,y) [  [(Dx) 1 (Dy) 1] [(y) -1 (Dy) 1]]]$
                     68:   $          w_supports_of_I$
                     69:   $Example 2: [ [[1 2 3]] [0]] gkz /ff set$
                     70:   $          [ ff 0 get ff 1 get [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]]$
                     71:   $          ] w_supports_of_I $
                     72:   $Example 3: [ [[1 2 3]] [0]] gkz /ff set$
                     73:   $         [ ff 0 get ff 1 get [ [(x1) 0 (x2) 0 (x3) -3 (Dx1) 6 (Dx2) 6 (Dx3) 9]]] gb /gg set $
                     74:   $ gg 1 get { [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]] w_support } map /gg2 set $
                     75:  ]
                     76: ] putUsages
                     77:
                     78: /w_supports_of_I_without_gb_computation {
                     79:   /arg1 set
                     80:   [/in-w_supports_of_I_without_gb_computation
                     81:     /ans /v /ff /wvec /gg2] pushVariables
                     82:   [
                     83:      /ff arg1 0 get def
                     84:      /v arg1 1 get def
                     85:      /wvec arg1 2 get def
                     86:      /gg2 ff def
                     87: %%     gg2 message
                     88:      gg2 0 get (ring) dc ring_def
                     89:      gg2 { (string) dc  . } map /gg2 set % reparse
                     90:      gg2 { wvec w_support } map /ans set
                     91:      /arg1 [ans gg2] def
                     92:   ] pop
                     93:   popVariables
                     94:   arg1
                     95: } def
                     96:
                     97: /decompose_to_w_homogeneous {
                     98:   /arg1  set
                     99:   [/in-decompose_to_w_homogeneous /f /w /g /ans] pushVariables
                    100:   [
                    101:      /f arg1 0 get def
                    102:      /w arg1 1 get def
                    103:      /ans [ ] def
                    104:      f (ring) dc ring_def
                    105:      /w w weightv def
                    106:      {
                    107:        f (0). eq { exit } {  } ifelse
                    108:        f w init /g set
                    109:        ans g append /ans set
                    110:        f g sub /f set
                    111:      } loop
                    112:      /arg1 ans def
                    113:   ] pop
                    114:   popVariables
                    115:   arg1
                    116: } def
                    117:
                    118: [(decompose_to_w_homogeneous)
                    119: [( [f w] decompose_to_w_homogeneous [f0 f1 f2 ...])
                    120:  $Example: [ (x^3+x*h^4+x+1). [(x) 2 (h) 1] ] decompose_to_w_homogeneous $
                    121: ]] putUsages
                    122:
                    123: %% Check in the polynomial ring.
                    124: /w_homogeneousQ {
                    125:   /arg1 set
                    126:   [/in-w_homogeneousQ  /ii /vv /ww /ans /gg /jj /i] pushVariables
                    127:   [
                    128:     /ii arg1 0 get def
                    129:     /vv arg1 1 get def
                    130:     /ww arg1 2 get def
                    131:     [ii vv] pgb 0 get /gg set
                    132:     gg 0 get (ring) dc ring_def
                    133:     gg { (string) dc . } map /ii set
                    134:     ii { [ 2 1 roll ww ] decompose_to_w_homogeneous } map /jj set
                    135:     jj { dup length 1 eq { pop } { } ifelse } map /jj set
                    136:     jj flatten /jj set
                    137:     /ans 1 def
                    138:     0 1 jj length 1 sub {
                    139:        /i set
                    140:        jj i get gg reduction-noH 0 get (0). eq {  }
                    141:        { jj i get messagen ( does not belong to the ideal ) message
                    142:          /ans 0 def
                    143:          exit
                    144:        } ifelse
                    145:     } for
                    146:     /arg1 ans def
                    147:   ] pop
                    148:   popVariables
                    149:   arg1
                    150: } def
                    151:
                    152: [(w_homogeneousQ)
                    153: [([ideal variables weight] w_homogeneousQ bool)
                    154:  $Example 1: [[(x) (x^2+x) (x^3-y^2)] [(x) (y)] [(x) 1 (y) 1]] w_homogeneousQ$
                    155:  $Example 2: [[(x^2+1) (x^3-y^2)] [(x) (y)] [(x) 1 (y) 1]] w_homogeneousQ$
                    156: ]] putUsages
                    157:
                    158: %% Should move to hol.sm1
                    159: /gr_var {
                    160:   /arg1 set
                    161:   [/in-gr_var /v /ans /i /vec-input] pushVariables
                    162:   [
                    163:      /v arg1 def
                    164:      v isArray {
                    165:         /vec-input 1 def
                    166:         v { toString } map /v set
                    167:      } {
                    168:         /vec-input 0 def
                    169:         [v to_records pop] /v set
                    170:      } ifelse
                    171:      /ans v def
                    172:      0 1 v length 1 sub {
                    173:        /i set
                    174:        /ans ans [@@@.Dsymbol v i get] cat append def
                    175:      } for
                    176:      vec-input not {
                    177:        ans from_records /ans set
                    178:      } { } ifelse
                    179:      /arg1 ans def
                    180:   ] pop
                    181:   popVariables
                    182:   arg1
                    183: } def
                    184: [(gr_var)
                    185: [( [v1 ... vn] gr_var [v1 ... vn Dv1 ... Dvn] )
                    186:  $ (v1,...,vn) gr_var (v1,...,vn,Dv1,...,Dvn) $
                    187:  (cf. wToVW)
                    188: ]] putUsages
                    189:
                    190: %% Should move to hol.sm1
                    191: /reparse {
                    192:   /arg1 set
                    193:   [/in-reparse /f /ans] pushVariables
                    194:   [
                    195:      /f arg1 def
                    196:      f isArray {
                    197:        /ans f { reparse } map def
                    198:      }{
                    199:        f toString . /ans set
                    200:      } ifelse
                    201:      /arg1 ans def
                    202:   ] pop
                    203:   popVariables
                    204:   arg1
                    205: } def
                    206: [(reparse)
                    207: [(obj reparse obj2)
                    208:  (Parse the object in the current ring.)
                    209:  (Elements in obj2 belong to the current ring.)
                    210: ]] putUsages
                    211:
                    212: %% Should move to hol.sm1
                    213: /wToVW {
                    214:   /arg1 set
                    215:   [/in-wToVW /ww /vv /tmp /ans /i] pushVariables
                    216:   [
                    217:     /tmp arg1 def
                    218:     /ww tmp 0 get def
                    219:     /vv tmp 1 get def
                    220:     /ans [ ] def
                    221:     0 1 vv length 1 sub {
                    222:       /i set
                    223:       ans [ vv i get ww i get (integer) dc] append /ans set
                    224:     } for
                    225:     /arg1 ans flatten def
                    226:   ] pop
                    227:   popVariables
                    228:   arg1
                    229: } def
                    230: [(wToVW)
                    231: [([ ww vv] wToVW [ v1 w1 ...])
                    232:  (cf. gr_var)
                    233:  (Example: [ [-1 -2 1 2] [(x) (y) (Dx) (Dy)]] wToVW :: )
                    234: ]] putUsages
                    235:
                    236: /gr_gb {
                    237:   /arg1 set
                    238:   [/in-gr_gb /ii /vv /ww /vv_gr /ans /gr_I] pushVariables
                    239:   [(CurrentRingp)] pushEnv
                    240:   [
                    241:     /ii arg1 0 get def
                    242:     /vv arg1 1 get def
                    243:     /ww arg1 2 get def
                    244:     [ii vv ww] gb /ans set
                    245:     %% (gr_gb: your gb is) message  ans  message
                    246:     /vv_gr vv gr_var def
                    247:     vv_gr isArray { vv_gr from_records /vv_gr set } { } ifelse
                    248:     [vv_gr ring_of_polynomials 0] define_ring
                    249:     ans 1 get dehomogenize /gr_I set
                    250:     gr_I reparse /gr_I set
                    251:     /arg1 [ans 0 get gr_I] def
                    252:   ] pop
                    253:   popEnv
                    254:   popVariables
                    255:   arg1
                    256: } def
                    257: [(gr_gb)
                    258: [([ii vv ww] gr_gb [ii_gb gr_ii])
                    259:  (It computes the Grobner basis ii_gb in D for the weight vector vv.)
                    260:  (gr_ii is the initial ideal with respect to ww and is the ideal of)
                    261:  (the ring of polynomials with reverse lexicographic order.)
                    262:  (The answer is dehomogenized.)
                    263:  (cf. gr_var, reparse. Need gb for this function --- load cohom.sm1)
                    264:  $Example:   [[(x1*Dx1+2*x2*Dx2+3*x3*Dx3) $
                    265:  $             (Dx1^2-Dx2) (-Dx1*Dx2+Dx3)  (Dx2^2-Dx1*Dx3)] $
                    266:  $             [ (x1)  (x2)  (x3) ]  ] /ff set $
                    267:  $   [ff 0 get ff 1 get [[(x2) -1 (Dx1) 2 (Dx2) 3 (Dx3) 2]]] gr_gb /gg set$
                    268: ]] putUsages
                    269:
                    270: /firstSlope3 {
                    271:   /arg1 set
                    272:   [/in-firstSlope3 /ff /gv /gf /wv /wf /vv /vvdd
                    273:    /first-slope /first-weight /first-gb
                    274:   ] pushVariables
                    275:   [
                    276:      /ff arg1 def
                    277:      /vv [(x1) (x2) (x3)] def
                    278:      /vvdd [(x1) (x2) (x3) (Dx1) (Dx2) (Dx3)] def
                    279:      /wf [(Dx1) 1 (Dx2) 1 (Dx3) 1] def %% F-filtration
                    280:      /wv [(x2) -1 (Dx2) 1] def         %% V-filtration
                    281:
                    282:      [ff vv [wf]] gb /gf set
                    283:      [ff vv [wv]] gb dehomogenize /gv set
                    284:
                    285:      %% determine the first-slope and first-weight here.
                    286:      %%  [gf vv [wf]] w_supports_of_I
                    287:      %%  [gv vv [wv]] w_supports_of_I
                    288:      /firstweight [ (x2) -1 (Dx1) 2 (Dx2) 3 (Dx3) 2] def
                    289:      [ff vv [firstweight]] gr_gb
                    290:      /first-gb set
                    291:      [
                    292:       [first-gb 1 get vvdd wf] w_homogeneousQ
                    293:       [first-gb 1 get vvdd wv] w_homogeneousQ
                    294:       first-gb
                    295:      ] /arg1 set
                    296:   ] pop
                    297:   popVariables
                    298:   arg1
                    299: } def
                    300: %% [ [[1 2 3]] [0]] gkz /ff set ff 0 get firstSlope3 /gg set
                    301: %% [ [[1 2 3]] [2]] gkz /ff set ff 0 get firstSlope3 /gg set
                    302: %% This program is used to check gr_gb and w_homogeneousQ
                    303:
                    304: /biggest_pq {
                    305:   /arg1 set
                    306:   [/in-biggest_pq /ex /xmax /ymax /i /ans] pushVariables
                    307:   [
                    308:      /ex arg1 def
                    309:      ex length 0 eq {
                    310:        /ans null def
                    311:        /LLL.biggest_pq goto
                    312:      } {  } ifelse
                    313:      /xmax ex 0 get 0 get def
                    314:      0 1 ex length 1 sub {
                    315:         /i set
                    316:         ex i get 0 get xmax ge {
                    317:           /xmax ex i get 0 get def
                    318:           /ymax ex i get 1 get def
                    319:         }{ } ifelse
                    320:      } for
                    321:      0 1 ex length 1 sub {
                    322:         /i set
                    323:         ex i get 0 get xmax eq {
                    324:           ex i get 1 get ymax gt {
                    325:             /ymax ex i get 1 get def
                    326:           } { } ifelse
                    327:         }{ } ifelse
                    328:      } for
                    329:      /ans [xmax ymax] def
                    330:      /LLL.biggest_pq
                    331:      /arg1 ans def
                    332:   ] pop
                    333:   popVariables
                    334:   arg1
                    335: }def
                    336: [(biggest_pq)
                    337: [([[i1 j1] [i2 j2] ...] biggest_pq [ik jk])
                    338:  (It returns the biggest [i j] with the lexicographic order x > y)
                    339:  (Example:  [ [1 2] [1 3] [2 4] [2 -1]] biggest_pq :: )
                    340: ]] putUsages
                    341:
                    342: /remove_x* {
                    343:   /arg1 set
                    344:   [/in-remove_x* /ans /i /ex /x] pushVariables
                    345:   [
                    346:     /ex arg1 0 get def
                    347:     /x arg1 1 get def
                    348:     /ans [  ] def
                    349:     0 1 ex length 1 sub {
                    350:       /i set
                    351:       ex i get 0 get x eq {
                    352:       }{
                    353:         /ans ans ex i get append def
                    354:       } ifelse
                    355:     } for
                    356:     /arg1 ans def
                    357:   ] pop
                    358:   popVariables
                    359:   arg1
                    360: } def
                    361: [(remove_x*)
                    362: [([[[i1 j1] [i2 j2] ...] x] remove_x* [[i1 j1] [i2 j2] ...])
                    363:  (It removes [x *] elements from [[i1 j1] ...])
                    364:  (Example: [ [ [1 2] [1 3] [2 4] [2 -1]] 2 ] remove_x* :: )
                    365: ]] putUsages
                    366:
                    367: % f > g ?
                    368: /greater_u {
                    369:   /arg2 set  /arg1 set
                    370:   [/in-greater_u /f /g /tmp /ans] pushVariables
                    371:   [
                    372:     /f arg1 def /g arg2 def
                    373:     f g sub /tmp set
                    374:     /ans 0 def
                    375:     tmp isInteger {
                    376:       tmp 0 gt {
                    377:          /ans 1 def
                    378:       }{  } ifelse
                    379:     }{
                    380:       tmp isRational { tmp (numerator) dc /tmp set } { } ifelse
                    381:       tmp (0).. gt {
                    382:          /ans 1 def
                    383:       } {  } ifelse
                    384:     } ifelse
                    385:     /arg1 ans def
                    386:   ] pop
                    387:   popVariables
                    388:   arg1
                    389: } def
                    390:
                    391: %% to turn around the a bug of univ-num (universalNumber) dc bug.
                    392: /toUniv {
                    393:   /arg1 set
                    394:   [/in-toUniv /p] pushVariables
                    395:   [
                    396:     /p arg1 def
                    397:      p isInteger {
                    398:        /p p (universalNumber) dc def
                    399:      }{ } ifelse
                    400:     /arg1 p def
                    401:   ] pop
                    402:   popVariables
                    403:   arg1
                    404: } def
                    405: /smallSlope {
                    406:   /arg1 set
                    407:   [/in-smallSlope /ex /p /q /tmp /r /s /slope
                    408:    /upperBoundOfSlope
                    409:   ]  pushVariables
                    410:   [
                    411:      /ex arg1 0 get def
                    412:      /upperBoundOfSlope arg1 1 get def
                    413:      (0).. upperBoundOfSlope greater_u {
                    414:          (SmallSlope: the upperBoundOfSlope has a negative value.)
                    415:          error
                    416:      } {  } ifelse
                    417:      /slope (0).. def
                    418:      /tmp ex biggest_pq def
                    419:      /p tmp 0 get def /q tmp 1 get def
                    420:      [ex p] remove_x* /ex set
                    421:      {
                    422:         ex length 0 eq { exit } { } ifelse
                    423:         /tmp ex biggest_pq def
                    424:         /r tmp 0 get def  %% tmp = (r,s)
                    425:         /s tmp 1 get def  %% tmp = (r,s)
                    426:         [ex r] remove_x* /ex set
                    427:         s q greater_u {
                    428:           %% return  (s-q)/(p-r) : positiive
                    429:           s q sub toUniv
                    430:           p r sub toUniv div /slope set
                    431:           [(cancel) slope] mpzext /slope set
                    432:           upperBoundOfSlope slope greater_u {
                    433:             exit
                    434:           } {
                    435:             /p r def
                    436:             /q s def
                    437:             /slope (0).. def % throw away this slope
                    438:           } ifelse
                    439:         } {  } ifelse
                    440:      } loop
                    441:      /arg1 slope def
                    442:   ] pop
                    443:   popVariables
                    444:   arg1
                    445: } def
                    446: [(smallSlope)
                    447: [([ [[i1 j1] [i2 j2] ...]  upperBound] smallSlope b/a)
                    448:  (The absolute value of the smallSlope must be smaller than upperBound.)
                    449:  (Example: [ [[1 2] [1 6] [2 4] [2 -1]] slope.infinity] smallSlope :: )
                    450:  (Example: [ [[0 7] [1 2] [1 6] [2 4] [2 -1]] (2)..] smallSlope :: )
                    451:  (Example: [ [[1 2] [1 3] [2 4] [2 -1]] slope.infinity]smallSlope :: )
                    452:  (Example: [ [[1 2] [1 -1]] slope.infinity] smallSlope :: )
                    453:  $Example: [ [[1 2 3]] [0]] gkz /ff set$
                    454:  $          [ ff 0 get ff 1 get [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]]$
                    455:  $          ] w_supports_of_I /gg set$
                    456:  $        gg 0 get { /pp set [pp slope.infinity] smallSlope } map /hh set $
                    457: ]] putUsages
                    458:
                    459:
                    460: /maxSlope {
                    461:   /arg1 set
                    462:   [/in-maxSlope /ss /ans /i] pushVariables
                    463:   [
                    464:     /ss arg1 def
                    465:     /ans (0).. def
                    466:     0 1 ss length 1 sub {
                    467:       /i set
                    468:       ss i get ans greater_u {
                    469:         /ans ss i get def
                    470:       } {  } ifelse
                    471:     } for
                    472:     /arg1 ans def
                    473:   ] pop
                    474:   popVariables
                    475:   arg1
                    476: } def
                    477:
                    478: /slope {
                    479:   /arg1 set
                    480:   [/in-slope /ff /gv /gf /wv /wf /wll /worderf
                    481:    /vv /vvdd  /f /v /ll /f-filt
                    482:    /w_supp
                    483:    /virtualSlope /a /b  /ans /tmp /sslopes
                    484:    /pp  /maxSmallSlope
                    485:    /first-slope /first-weight /first-gb /first-init
                    486:   ] pushVariables
                    487:   [
                    488:      /ff arg1 0 get def
                    489:      /vv arg1 1 get def
                    490:      /f  arg1 2 get def
                    491:      /v  arg1 3 get def
                    492:      vv isArray not { [vv to_records pop] /vv set } { } ifelse
                    493:      /f-filt f def
                    494: %%   Example:
                    495: %%     /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def
                    496: %%     /f [ 0 0 1 1] def   %% F-filtration
                    497: %%     /v [ -1 0 1 0] def  %% V-filtration
                    498: %%     /vv [(x) (y)] def
                    499:      %% -3: x=0,   -2 : y =0
                    500:
                    501:      /maxSmallSlope slope.infinity def
                    502:      /vvdd vv gr_var def
                    503:      vvdd length f length eq {  }
                    504:      { (The number of variables <<vvdd>> and the size of weight vector <<f>>do not match.)
                    505:         error } ifelse
                    506:      vvdd length v length eq {  }
                    507:      { (The number of variables <<vvdd>> and the size of weight vector <<v>>do not match.)
                    508:         error } ifelse
                    509:      /ans [ ] def
                    510:      /wv [v vvdd] wToVW def
                    511:
                    512:      /worderf [f vvdd] wToVW def
                    513:
                    514:      /wf [f vvdd] wToVW def
                    515:      slope.verbose { (Computing gb with ) messagen wf message ( and ) messagen
                    516:                       wv message } { } ifelse
                    517:      [ff vv [wf wv]] gr_gb /first-gb set
                    518:      /firstweight wf def
                    519:     {
                    520:      /wf [f vvdd] wToVW def
                    521:
                    522:      first-gb 0 get dehomogenize /gf set
                    523:      [gf vv [worderf wv]] w_supports_of_I_without_gb_computation
                    524:      /w_supp set
                    525:       slope.verbose { (w_supp are ) message w_supp 0 get message } { } ifelse
                    526:       slope.verbose { (gb is ) message w_supp 1 get message } { } ifelse
                    527:       slope.verbose { (weight is ) messagen firstweight message } { } ifelse
                    528:       w_supp 0 get { /pp set [pp maxSmallSlope] smallSlope } map /sslopes set
                    529:       slope.verbose { (smallSlopes are ) message sslopes message } { } ifelse
                    530:       sslopes maxSlope /first-slope set
                    531:       first-slope (0).. greater_u {
                    532:        (small slope is ) messagen first-slope message
                    533:      } {
                    534:        (All the smallSlopes are zero. Exiting...) message
                    535:         exit
                    536:      } ifelse
                    537:      /a first-slope (denominator) dc def
                    538:      /b first-slope (numerator) dc def
                    539:      %% a v mul  b f mul add /ll set
                    540:      a v mul  b f-filt mul add /ll set
                    541:      /firstweight [ll vvdd] wToVW def
                    542:      (Computing the GB with the weight vector ) messagen firstweight message
                    543:      (and ) messagen wv message
                    544:      [ff vv [firstweight wv]] gr_gb  % use two weight vectors.
                    545:      /first-gb set
                    546:      %% (GB is) messagen first-gb message
                    547:      first-gb 1 get /first-init set
                    548:      slope.geometric {
                    549:        (To get the geometric slope, we need to compute the radical.) message
                    550:        [ first-init vvdd] radical /first-init set
                    551:        [first-init vvdd] pgb 0 get /first-init set
                    552:        (Radical is ) messagen first-init message
                    553:      } { } ifelse
                    554:      [first-init vvdd worderf] w_homogeneousQ
                    555:      [first-init vvdd wv] w_homogeneousQ
                    556:      and {
                    557:        (It is bi-homogeneous!  It is not a slope.) message
                    558:        /maxSmallSlope first-slope def %% I think it is necessary.
                    559:      } {
                    560:        slope.geometric {
                    561:           (It is a geometric slope.) message
                    562:        }{
                    563:          (It is an algebraic slope.) message
                    564:        } ifelse
                    565:        /maxSmallSlope first-slope def
                    566:        /ans ans [first-slope ll] append def
                    567:      } ifelse
                    568:      (-----------------------------------------------) message
                    569:      /f ll def
                    570:     } loop
                    571:     /arg1 ans def
                    572:   ] pop
                    573:   popVariables
                    574:   arg1
                    575: } def
                    576: [(slope)
                    577: [( [ii vv F-filtration V-filtration] slope [ [-slope1 weight] ...])
                    578:  ( ii : ideal, vv : variables, F-filtration : F-filtration by vector)
                    579:  ( V-filtration : V-filtration by vector)
                    580:  (It computes the algebraic or geometric slopes of ii along the hyperplane)
                    581:  (specified by the V-filtration.)
                    582:  (When slope.geometric is one, it outputs the geometric slopes.)
                    583:  (As to the algorithm, see A.Assi, F.J.Castro-Jimenez and J.M.Granger)
                    584:  ( How to calculate the slopes of a D-module, Compositio Math, 104, 1-17, 1996)
                    585:  (Note that the signs of the slopes are negative, but the absolute values)
                    586:  (of the slopes are returned.)
                    587:  $Example 1: [ [(x^4 Dx + 3)] (x) [0 1] [-1 1]] slope :: $
                    588:  $          The solution is exp(x^(-3)). $
                    589:  $Example 2: [ [(x^3 Dx^2 + (x + x^2) Dx + 1)] [(x)] $
                    590:  $             [0 1] [-1 1]] slope :: $
                    591:  $Example 3: [ [(x^6 Dx^3 + x^3 Dx^2 + (x + x^2) Dx + 1)] [(x)] $
                    592:  $             [0 1] [-1 1]] slope :: $
                    593:  $Example 4:$
                    594:  $   /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def$
                    595:  $   [ ff (x,y) [ 0 0 1 1]  [ 0 -1 0 1] ] slope :: $
                    596:  $   Answer should be  2  ==> -2 $
                    597:  $Example 5:$
                    598:  $   /ff [ [[1 2 3]] [-3]] gkz def $
                    599:  $   [ ff 0 get ff 1 get [ 0 0 0 1 1 1]  [ 0 0 -1 0 0 1] ] slope :: $
                    600: ]] putUsages
                    601:
                    602: /bihomogeneousGrQ {
                    603:   /arg1 set
                    604:   [/in-checkBihomogeneous  /ff /vv /firstweight /worderf /wv
                    605:    /first-gb /ans /vvdd
                    606:   ] pushVariables
                    607:   [
                    608:      arg1 0 get /ff set
                    609:      arg1 1 get /vv set
                    610:      arg1 2 get /firstweight set
                    611:      arg1 3 get 0 get /worderf set
                    612:      arg1 3 get 1 get /wv set
                    613:
                    614:      vv isArray not { [vv to_records pop] /vv set} { } ifelse
                    615:      vv gr_var /vvdd set
                    616:      %%(Computing the GB with the weight vector ) messagen firstweight message
                    617:      [ff vv [firstweight]] gr_gb
                    618:      /first-gb set
                    619:      %% (GB is) messagen first-gb message
                    620:      [first-gb 1 get vvdd worderf] w_homogeneousQ
                    621:      [first-gb 1 get vvdd wv] w_homogeneousQ
                    622:      and {
                    623:        (It is bi-homogeneous!) message  /ans 1 def
                    624:      } {
                    625:        (It is not bi-homogenous w.r.t ) messagen
                    626:         [worderf wv] message
                    627:         /ans 0 def
                    628:      } ifelse
                    629:      /arg1 [ans first-gb firstweight] def
                    630:   ] pop
                    631:   popVariables
                    632:   arg1
                    633: } def
                    634: [(bihomogeneousGrQ)
                    635: [([ ii vv w [vf wv]] bihomogeneousGrQ [ans gb])
                    636:  $It checks if in_w(ii) is bihomogeneous w.r.t. vf and wv$
                    637:  $Example 1: [ [[1 2 3]] [0]] gkz /ff set $
                    638:  $         [ff 0 get ff 1 get [(x3) -2 (Dx1) 1 (Dx2) 1 (Dx3) 3] $
                    639:  $              [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(x3) -1 (x3) 1]]] $
                    640:  $              bihomogeneousGrQ /gg set $
                    641:  $ bi-homogeneous $
                    642:  $Example 2: [ [[1 2 3]] [0]] gkz /ff set $
                    643:  $         [ff 0 get ff 1 get [(x3) -1 (Dx1) 2 (Dx2) 2 (Dx3) 3] $
                    644:  $              [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(x3) -1 (x3) 1]]] $
                    645:  $              bihomogeneousGrQ /gg set $
                    646:  $ not bi-homogeneous $
                    647:  $Example 3: [ [[1 3]] [0]] gkz /ff set $
                    648:  $         [ff 0 get ff 1 get [(x2) -2 (Dx1) 1 (Dx2) 3] $
                    649:  $              [ [(Dx1) 1 (Dx2) 1] [(x2) -1 (x2) 1]]] $
                    650:  $              bihomogeneousGrQ /gg set $
                    651:  $ not bi-homogeneous $
                    652: ]] putUsages
                    653:
                    654: %% Radical via primary ideal decomposition.
                    655: /radical {
                    656:   /arg1 set
                    657:   [/in-radical /ii /jj /pp0 /n /i /vv /ans] pushVariables
                    658:   [
                    659:      /ii arg1 def
                    660:      ii 1 get /vv set
                    661:      ii primadec /jj set
                    662:      /n  jj length def
                    663:      jj { 1 get } map /pp0 set
                    664:      vv isArray {
                    665:        /vv vv from_records def
                    666:      } { } ifelse
                    667:      (Primary components are ) messagen pp0 message
                    668:      /ans pp0 0 get def
                    669:      pp0 rest /pp0 set
                    670:      {
                    671:         pp0 length 0 eq { exit } {  } ifelse
                    672:         %% [ans pp0 0 get vv] message
                    673:         [ans pp0 0 get vv] gr_intersection /ans set
                    674:         %%[ans pp0 0 get vv] gr_intersection /ans set
                    675:         pp0 rest /pp0 set
                    676:      } loop
                    677:      ans /arg1 set
                    678:   ] pop
                    679:   popVariables
                    680:   arg1
                    681: } def
                    682: [(radical)
                    683: [([ii vv] radical jj)
                    684:  (Computing the radical of ii via primadec.)
                    685:  (Example 1: [ [(x^2-1) (x^4-1)] (x)] radical ::)
                    686:  (Example 2: [ [(x^2 y) (y^4)  (x y)] (x,y)] radical ::)
                    687: ]] putUsages
                    688:
                    689: /gr_intersection {
                    690:   /arg1 set
                    691:   [/in-gr_intersection /ii /jj /rr /vlist /ii2 /jj2 ] pushVariables
                    692:   [(CurrentRingp) (KanGBmessage)] pushEnv
                    693:   [
                    694:      /ii arg1 0 get def
                    695:      /jj arg1 1 get def
                    696:      /vlist arg1 2 get def
                    697:
                    698:     [(KanGBmessage) 0] system_variable
                    699:
                    700:      [vlist to_records pop] /vlist set
                    701:      [vlist [(_t)] join from_records ring_of_polynomials
                    702:       [[(_t) 1]] weight_vector 0] define_ring
                    703:      ii { toString . (_t). mul } map /ii2 set
                    704:      jj { toString . (1-_t). mul } map /jj2 set
                    705:      [ii2 jj2 join] groebner_sugar 0 get
                    706:      [(_t)] eliminatev /arg1 set
                    707:   ] pop
                    708:   popEnv
                    709:   popVariables
                    710:   arg1
                    711: } def
                    712: [(gr_intersection)
                    713: [(Ideal intersections in the ring of polynomials.)
                    714:  $Example 1: [[(y) (Dx)] [(x) (Dy)] (x,y,Dx,Dy)] gr_intersection ::$
                    715: ]] putUsages
                    716:
                    717:
                    718: /tests {
                    719:
                    720:      /ff [ [[1 2 3] ] [0]] gkz 0 get def
                    721:      /vv [(x1) (x2) (x3)] def
                    722:      /f [ 0 0 0 1 1 1] def   %% F-filtration
                    723:      /v [ 0 0 -1  0 0 1] def  %% V-filtration
                    724:
                    725:      /ff [ [[1 2 4] ] [0]] gkz 0 get def
                    726:      /vv [(x1) (x2) (x3)] def
                    727:      /f [ 0 0 0 1 1 1] def   %% F-filtration
                    728:      /v [ 0 0 -1  0 0 1] def  %% V-filtration
                    729:
                    730:      %% [1 2 3]
                    731:      /ff  [    $2*(x1-1)*Dx1+4*(x2-2)*Dx2+6*x3*Dx3-1$ , $Dx1^2-Dx2$ , $-Dx1*Dx2+Dx3$ , $Dx2^2-Dx1*Dx3$ ] def
                    732:      /vv [(x1) (x2) (x3)] def
                    733:      /f [ 0 0 0 1 1 1] def   %% F-filtration
                    734:      /v [ 0 0 -1  0 0 1] def  %% V-filtration
                    735:
                    736:      %% [1 2 4]
                    737:      /ff  [    $2*(x1-1)*Dx1+4*(x2-2)*Dx2+8*x3*Dx3-1$ , $Dx1^2-Dx2$ , $Dx2^2-Dx3$ ] def
                    738:      /vv [(x1) (x2) (x3)] def
                    739:      /f [ 0 0 0 1 1 1] def   %% F-filtration
                    740:      /v [ 0 0 -1  0 0 1] def  %% V-filtration
                    741:
                    742:      /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def
                    743:      /f [ 0 0 1 1] def   %% F-filtration
                    744:      /v [ 0 -1 0 1] def  %% V-filtration
                    745:      /vv [(x) (y)] def
                    746:      %% -3: x=0,   -2 : y =0
                    747:
                    748:      /ff [ [[1 3]] [0]] gkz 0 get def
                    749:      /f [ 0 0 1 1] def   %% F-filtration
                    750:      /v [ 0 -1 0 1] def  %% V-filtration
                    751:      /vv [(x1) (x2)] def
                    752:
                    753:
                    754: } def
                    755:
1.2       takayama  756: /slope.sm1.loaded 1 def

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