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