Annotation of OpenXM/src/kan96xx/Doc/gfan.sm1, Revision 1.1
1.1 ! takayama 1: % $OpenXM$
! 2: % cp cone.sm1 $OpenXM_HOME/src/kan96xx/Doc/gfan.sm1
! 3: % $Id: cone.sm1,v 1.29 2004/09/05 10:16:00 taka Exp $
! 4: % iso-2022-jp
! 5:
! 6: /cone.debug 1 def
! 7:
! 8: /ox.k0.loaded boundp {
! 9: } {
! 10: [(parse) (ox.sm1) pushfile] extension
! 11: } ifelse
! 12:
! 13: % Global: cone.type
! 14: % $B$I$N(B exponents $B$r<h$j=P$9$N$+;XDj$9$k(B.
! 15: % cf. exponents, gbext h $B$d(B H $B$b8+$k$+(B?
! 16: % 0 : x,y,Dx,Dy
! 17: % 1 : x,y,Dx,Dy,h,H
! 18: % 2 : x,y,Dx,Dy,h
! 19: /cone.type 2 def
! 20:
! 21: % Global: cone.local
! 22: % cone.local: Local $B$+(B? 1 $B$J$i(B local
! 23: /cone.local 1 def
! 24:
! 25: % Global: cone.h0
! 26: % cone.h0: 1 $B$J$i(B h $B$N(B weight 0 $B$G$N(B Grobner fan $B$r7W;;$9$k(B.
! 27: /cone.h0 1 def
! 28:
! 29: % Global: cone.n (number of variables in GB)
! 30: % cone.m (freedom of the weight space. cf. cone.W)
! 31: % cone.d (pointed cones lies in this space. cf. cone.Lp)
! 32: % These are set during getting the cone.startingCone
! 33:
! 34:
! 35: %<
! 36: % Usage: wv g coneEq1
! 37: % in(f) $B$,(B monomial $B@lMQ(B. in_w(f) = LT(f) $B$H$J$k(B weight w $B$NK~$?$9(B
! 38: % $BITEy<0@)Ls$r5a$a$k(B.
! 39: %>
! 40: /coneEq1 {
! 41: /arg1 set
! 42: [/g /eqs /gsize /i /j /n /f /exps /m % Do not use "eq" as a variable
! 43: /expsTop
! 44: ] pushVariables
! 45: [
! 46: /g arg1 def % Reduced Grobner basis
! 47: /eqs [ ] def % $BITEy<07O$N78?t(B
! 48: /gsize g length def
! 49: 0 1 gsize 1 sub {
! 50: /i set
! 51: g i get /f set % f $B$O(B i $BHVL\$N(B reduced Grobner basis $B$N85(B
! 52: [(exponents) f cone.type] gbext /exps set % exps $B$O(B f $B$N(B exponent vector
! 53: exps length /m set
! 54: m 1 eq not {
! 55: /expsTop exps 0 get def % expsTop $B$O(B f $B$N@hF,$N(B exponent vector.
! 56: 1 1 exps length 1 sub {
! 57: /j set
! 58: eqs [expsTop exps j get sub] join /eqs set
! 59: % exps[0]-exps[j] $B$r(B eqs $B$X3JG<$7$F$$$/$@$1(B.
! 60: % Cone $B$N(B closure $B$r$@$9$N$G(B >= $B$G(B OK.
! 61: } for
! 62: } { } ifelse
! 63: } for
! 64: /arg1 eqs def
! 65: ] pop
! 66: popVariables
! 67: arg1
! 68: } def
! 69:
! 70: %<
! 71: % Usage: ww g coneEq
! 72: % ww $B$O(B [v1 w1 v2 w2 ... ] $B7A<0(B. (v-w $B7A<0(B) w1, w2 $B$O(B univNumber $B$G$b$$$$(B.
! 73: % g $B$O(B reduced Grobner basis
! 74: % in(f) $B$,(B monomial $B$G$J$$>l9g$b07$&(B.
! 75: % in_w(f) = in_ww(f) $B$H$J$k(B weight w $B$NK~$?$9(B
! 76: % $BITEy<0@)Ls$r5a$a$k(B.
! 77: % ord_w, init (weightv) $B$rMQ$$$k(B.
! 78: %>
! 79: /coneEq {
! 80: /arg2 set
! 81: /arg1 set
! 82: [/g /eqs /gsize /i /j /n /f /exps /m
! 83: /expsTop /ww /ww2 /iterms
! 84: ] pushVariables
! 85: [
! 86: /g arg2 def % Reduced Grobner basis
! 87: /ww arg1 def % weight vector. v-w $B7A<0(B
! 88: ww to_int32 /ww set % univNum $B$,$"$l$P(B int32 $B$KD>$7$F$*$/(B.
! 89: /ww2 ww weightv def % v-w $B7A<0$r(B $B?t;z$N%Y%/%H%k$K(B. (init $BMQ(B)
! 90:
! 91: /eqs [ ] def % $BITEy<07O$N78?t(B
! 92: /gsize g length def
! 93: 0 1 gsize 1 sub {
! 94: /i set
! 95: g i get /f set % f $B$O(B i $BHVL\$N(B reduced Grobner basis $B$N85(B
! 96: [(exponents) f cone.type] gbext /exps set % exps $B$O(B f $B$N(B exponent vector
! 97: exps length /m set
! 98: m 1 eq not {
! 99: /expsTop exps 0 get def % expsTop $B$O(B f $B$N@hF,$N(B exponent vector.
! 100: /iterms f ww2 init length def % f $B$N(B initial term $B$N9`$N?t(B.
! 101: % in_ww(f) > f_j $B$H$J$k9`$N=hM}(B.
! 102: iterms 1 exps length 1 sub {
! 103: /j set
! 104: eqs [expsTop exps j get sub] join /eqs set
! 105: % exps[0]-exps[j] $B$r(B eqs $B$X3JG<$7$F$$$/(B.
! 106: } for
! 107: % in_ww(f) = f_j $B$H$J$k9`$N=hM}(B.
! 108: [(exponents) f ww2 init cone.type] gbext /exps set % exps $B$O(B in(f)
! 109: 1 1 iterms 1 sub {
! 110: /j set
! 111: eqs [exps j get expsTop sub] join /eqs set
! 112: eqs [expsTop exps j get sub] join /eqs set
! 113: % exps[j]-exps[0], exps[0]-exps[j] $B$r3JG<(B.
! 114: % $B7k2LE*$K(B (exps[j]-exps[0]).w = 0 $B$H$J$k(B.
! 115: } for
! 116: } { } ifelse
! 117: } for
! 118: /arg1 eqs def
! 119: ] pop
! 120: popVariables
! 121: arg1
! 122: } def
! 123:
! 124: %<
! 125: % Usage: wv g coneEq genPo
! 126: % polymake $B7A<0$N(B INEQUALITIES $B$r@8@.$9$k(B. coneEq -> genPo $B$HMxMQ(B
! 127: %>
! 128: /genPo {
! 129: /arg1 set
! 130: [/outConeEq /rr /nn /ii /mm /jj /ee] pushVariables
! 131: [
! 132: /outConeEq arg1 def
! 133: /rr [(INEQUALITIES) nl] cat def % $BJ8;zNs(B rr $B$KB-$7$F$$$/(B.
! 134: outConeEq length /nn set
! 135: 0 1 nn 1 sub {
! 136: /ii set
! 137: outConeEq ii get /ee set
! 138: [ rr
! 139: (0 ) % $BHs$;$$$8MQ$N(B 0 $B$r2C$($k(B.
! 140: 0 1 ee length 1 sub {
! 141: /jj set
! 142: ee jj get toString ( )
! 143: } for
! 144: nl
! 145: ] cat /rr set
! 146: } for
! 147: /arg1 rr def
! 148: ] pop
! 149: popVariables
! 150: arg1
! 151: } def
! 152:
! 153: %<
! 154: % Usage: wv g coneEq genPo2
! 155: % doPolyamke $B7A<0$N(B INEQUALITIES $B$r@8@.$9$k(B. coneEq -> genPo2 $B$HMxMQ(B
! 156: % tfb $B7A<0J8;zNs(B.
! 157: %>
! 158: /genPo2 {
! 159: /arg1 set
! 160: [/outConeEq /rr /nn /ii /mm /jj /ee] pushVariables
! 161: [
! 162: /outConeEq arg1 def
! 163: /rr $polymake.data(polymake.INEQUALITIES([$ def
! 164: % $BJ8;zNs(B rr $B$KB-$7$F$$$/(B.
! 165: outConeEq length /nn set
! 166: 0 1 nn 1 sub {
! 167: /ii set
! 168: outConeEq ii get /ee set
! 169: [ rr
! 170: ([0,) % $BHs$;$$$8MQ$N(B 0 $B$r2C$($k(B.
! 171: 0 1 ee length 1 sub {
! 172: /jj set
! 173: ee jj get toString
! 174: jj ee length 1 sub eq { } { (,) } ifelse
! 175: } for
! 176: (])
! 177: ii nn 1 sub eq { } { (,) } ifelse
! 178: ] cat /rr set
! 179: } for
! 180: [rr $]))$ ] cat /rr set
! 181: /arg1 rr def
! 182: ] pop
! 183: popVariables
! 184: arg1
! 185: } def
! 186:
! 187: /test1 {
! 188: [(x,y) ring_of_differential_operators 0] define_ring
! 189: [ (x + y + Dx + Dy).
! 190: (x ^2 Dx^2 + y^2 Dy^2).
! 191: (x).
! 192: ] /gg set
! 193: gg coneEq1 /ggc set
! 194: gg message
! 195: ggc pmat
! 196:
! 197: ggc genPo message
! 198: } def
! 199:
! 200: /test2 {
! 201: [(parse) (dhecart.sm1) pushfile] extension
! 202: dh.test.p1 /ff set
! 203: ff 0 get coneEq1 /ggc set
! 204: ggc message
! 205: ggc genPo /ss set
! 206: ss message
! 207: (Data is in ss) message
! 208: } def
! 209:
! 210:
! 211: /test3 {
! 212: % [(parse) (cohom.sm1) pushfile] extension
! 213: /ww [(Dx) 1 (Dy) 1] def
! 214: [(x,y) ring_of_differential_operators
! 215: [ww] weight_vector
! 216: 0] define_ring
! 217: [ (x Dx + y Dy -1).
! 218: (y^2 Dy^2 + 2 + y Dy ).
! 219: ] /gg set
! 220: gg {homogenize} map /gg set
! 221: [gg] groebner 0 get /gg set
! 222: ww message
! 223: ww gg coneEq /ggc set
! 224: gg message
! 225: ggc pmat
! 226:
! 227: ggc genPo message
! 228: } def
! 229:
! 230: %<
! 231: % Usage: test3b
! 232: % Grobner cone $B$r7hDj$7$F(B, polymake $BMQ$N%G!<%?$r@8@.$9$k%F%9%H(B.
! 233: % weight (0,0,1,1) $B$@$H(B max dim cone $B$G$J$$(B.
! 234: %>
! 235: /test3b {
! 236: % [(parse) (cohom.sm1) pushfile] extension
! 237: /ww [(Dx) 1 (Dy) 2] def
! 238: [(x,y) ring_of_differential_operators
! 239: [ww] weight_vector
! 240: 0] define_ring
! 241: [ (x Dx + y Dy -1).
! 242: (y^2 Dy^2 + 2 + y Dy ).
! 243: ] /gg set
! 244: gg {homogenize} map /gg set
! 245: [gg] groebner 0 get /gg set
! 246: ww message
! 247: ww gg coneEq /ggc set
! 248: gg message
! 249: ggc pmat
! 250:
! 251: % ggc genPo /ggs set % INEQ $B$rJ8;zNs7A<0$G(B
! 252: % ggs message
! 253: % ggs output
! 254: % (mv sm1out.txt test3b.poly) system
! 255: % (Type in polymake-pear.sh test3b.poly FACETS) message
! 256:
! 257: ggc genPo2 /ggs set % INEQ $B$rJ8;zNs7A<0(B for doPolymake
! 258: ggs message
! 259:
! 260: } def
! 261:
! 262: % commit (dr.sm1): lcm, denominator, ngcd, to_univNum, numerator, reduce
! 263: % 8/22, changelog-ja $B$^$@(B.
! 264: % to do : nnormalize_vec, sort_vec --> shell $B$G(B OK.
! 265: % 8/27, getNode
! 266:
! 267: /test4 {
! 268: $polymake.data(polymake.INEQUALITIES([[0,1,0,0],[0,0,1,0]]))$ /ff set
! 269: [(FACETS) ff] doPolymake /rr set
! 270:
! 271: rr 1 get /rr1 set
! 272: rr1 getLinearitySubspace pmat
! 273:
! 274: } def
! 275:
! 276: %<
! 277: % Usage: vv ineq isInLinearSpace
! 278: % vv $B$,(B ineq[i] > 0 $B$GDj5A$5$l$kH>6u4V$N$I$l$+$K$O$$$C$F$$$k$J$i(B 0
! 279: % vv $B$,(B $BA4$F$N(B i $B$K$D$$$F(B ineq[i] = 0 $B$K$O$$$C$F$$$?$i(B 1.
! 280: %>
! 281: /isInLinearSpace {
! 282: /arg2 set
! 283: /arg1 set
! 284: [/vv /ineq /ii /rr] pushVariables
! 285: [
! 286: /vv arg1 def
! 287: /ineq arg2 def
! 288: /rr 1 def
! 289: {
! 290: 0 1 ineq length 1 sub {
! 291: /ii set
! 292: % vv . ineq[ii] != 0 $B$J$i(B vv $B$O(B linearity space $B$N85$G$J$$(B.
! 293: vv ineq ii get mul to_univNum isZero {
! 294: } { /rr 0 def exit} ifelse
! 295: } for
! 296: exit
! 297: } loop
! 298: /arg1 rr def
! 299: ] pop
! 300: popVariables
! 301: arg1
! 302: } def
! 303:
! 304: %<
! 305: % Usages: doPolymakeObj getLinearitySubspace
! 306: % INEQUALITIES $B$H(B VERTICES $B$+$i(B maximal linearity subspace
! 307: % $B$N@8@.%Y%/%H%k$r5a$a$k(B.
! 308: % $BNc(B: VERTICES [[0,1,0,0],[0,0,1,0],[0,0,0,-1],[0,0,0,1]]]
! 309: % $BNc(B: INEQUALITIES [[0,1,0,0],[0,0,1,0]]
! 310: % $BF~NO$O(B polymake $B$N(B tree (doPolymake $B$N(B 1 get)
! 311: %>
! 312: /getLinearitySubspace {
! 313: /arg1 set
! 314: [/pdata /vv /ineq /rr /ii] pushVariables
! 315: [
! 316: /pdata arg1 def
! 317: {
! 318: /rr [ ] def
! 319: % POINTED $B$J$i(B max lin subspace $B$O(B 0.
! 320: pdata (POINTED) getNode tag 0 eq { } { exit} ifelse
! 321:
! 322: pdata (INEQUALITIES) getNode 2 get 0 get /ineq set
! 323: pdata (VERTICES) getNode 2 get 0 get /vv set
! 324: 0 1 vv length 1 sub {
! 325: /ii set
! 326: % -vv[ii] $B$,(B ineq $B$rK~$?$9$+D4$Y$k(B.
! 327: vv ii get ineq isInLinearSpace {
! 328: rr [vv ii get] join /rr set
! 329: } { } ifelse
! 330: } for
! 331: exit
! 332: } loop
! 333: /arg1 rr def
! 334: ] pop
! 335: popVariables
! 336: arg1
! 337: } def
! 338:
! 339: %<
! 340: % Usages: mm asir_matrix_image
! 341: % $B@8@.85$h$j@~7A6u4V$N4pDl$rF@$k(B.
! 342: %>
! 343: /asir_matrix_image {
! 344: /arg1 set
! 345: [/mm /rr] pushVariables
! 346: [(CurrentRingp)] pushEnv
! 347: [
! 348: /mm arg1 def
! 349: mm to_univNum /mm set
! 350: oxasir.ccc [ ] eq {
! 351: (Starting ox_asir server.) message
! 352: ox_asirConnectMethod
! 353: } { } ifelse
! 354: {
! 355: oxasir.ccc [(matrix_image) mm] asir
! 356: /rr set
! 357: rr null_to_zero /rr set
! 358: exit
! 359:
! 360: (asir_matrix_image: not implemented) error exit
! 361: } loop
! 362:
! 363: rr numerator /rr set
! 364: /arg1 rr def
! 365: ] pop
! 366: popEnv
! 367: popVariables
! 368: arg1
! 369: } def
! 370: [(asir_matrix_image)
! 371: [(Calling the function matrix_image of asir. It gets a reduced basis of a given matrix.)
! 372: (Example: [[1 2 3] [2 4 6]] asir_matrix_image)
! 373: ]] putUsages
! 374:
! 375: %<
! 376: % Usages: mm asir_matrix_kernel
! 377: % $BD>8r$9$k6u4V$N4pDl(B.
! 378: %>
! 379: /asir_matrix_kernel {
! 380: /arg1 set
! 381: [/mm /rr] pushVariables
! 382: [(CurrentRingp)] pushEnv
! 383: [
! 384: /mm arg1 def
! 385: mm to_univNum /mm set
! 386: oxasir.ccc [ ] eq {
! 387: (Starting ox_asir server.) message
! 388: ox_asirConnectMethod
! 389: } { } ifelse
! 390: {
! 391: oxasir.ccc [(matrix_kernel) mm] asir
! 392: /rr set
! 393: rr null_to_zero /rr set
! 394: exit
! 395:
! 396: (asir_matrix_image: not implemented) error exit
! 397: } loop
! 398: rr 1 get numerator /rr set
! 399: /arg1 rr def
! 400: ] pop
! 401: popEnv
! 402: popVariables
! 403: arg1
! 404: } def
! 405: [(asir_matrix_kernel)
! 406: [(Calling the function matrix_kernel of asir.)
! 407: (It gets a reduced basis of the kernel of a given matrix.)
! 408: (Example: [[1 2 3] [2 4 6]] asir_matrix_kernel)
! 409: ]] putUsages
! 410:
! 411: %<
! 412: % Usages: v null_to_zero
! 413: %>
! 414: /null_to_zero {
! 415: /arg1 set
! 416: [/pp /rr] pushVariables
! 417: [
! 418: /pp arg1 def
! 419: {
! 420: /rr pp def
! 421: pp isArray {
! 422: pp {null_to_zero} map /rr set
! 423: exit
! 424: }{ } ifelse
! 425:
! 426: pp tag 0 eq {
! 427: /rr (0).. def
! 428: exit
! 429: }{ } ifelse
! 430: exit
! 431: } loop
! 432: /arg1 rr def
! 433: ] pop
! 434: popVariables
! 435: arg1
! 436: } def
! 437: [(null_to_zero)
! 438: [(obj null_to_zero rob)
! 439: $It translates null to (0)..$
! 440: ]] putUsages
! 441:
! 442: % [2 0] lcm $B$O(B 0 $B$r$b$I$9$,$$$$$+(B? --> OK.
! 443:
! 444: %<
! 445: % Usages: mm addZeroForPolymake
! 446: % $B0J2<$NFs$D$N4X?t$O(B, toQuotientSpace $B$K$bMxMQ(B.
! 447: % Polymake INEQUALITIES $BMQ$K(B 0 $B$r;O$a$KB-$9(B.
! 448: % $BF~NO$O(B $B%j%9%H$N%j%9%H(B
! 449: % [[1,2], [3,4],[5,6]] --> [[0,1,2],[0,3,4],[0,5,6]]
! 450: %>
! 451: /addZeroForPolymake {
! 452: /arg1 set
! 453: [/mm /rr] pushVariables
! 454: [
! 455: /mm arg1 def
! 456: mm to_univNum /mm set
! 457: mm { [(0)..] 2 1 roll join } map /mm set
! 458: /arg1 mm def
! 459: ] pop
! 460: popVariables
! 461: arg1
! 462: } def
! 463:
! 464: %<
! 465: % Usages: mm cone.appendZero
! 466: %>
! 467: /cone.appendZero {
! 468: /arg1 set
! 469: [/mm /rr] pushVariables
! 470: [
! 471: /mm arg1 def
! 472: mm to_univNum /mm set
! 473: mm { [(0)..] join } map /mm set
! 474: /arg1 mm def
! 475: ] pop
! 476: popVariables
! 477: arg1
! 478: } def
! 479:
! 480: %<
! 481: % Usages: mm removeFirstFromPolymake
! 482: % $B;O$a$N(B 0 $B$r<h$j=|$/(B.
! 483: % $BF~NO$O(B $B%j%9%H$N%j%9%H(B
! 484: % [[0,1,2],[0,3,4],[0,5,6]] ---> [[1,2], [3,4],[5,6]]
! 485: %>
! 486: /removeFirstFromPolymake {
! 487: /arg1 set
! 488: [/mm /rr] pushVariables
! 489: [
! 490: /mm arg1 def
! 491: mm to_univNum /mm set
! 492: mm {rest} map /mm set
! 493: /arg1 mm def
! 494: ] pop
! 495: popVariables
! 496: arg1
! 497: } def
! 498:
! 499: %<
! 500: % Usages: mm genUnit
! 501: % [1,0,0,...] $B$r2C$($k$?$a$K@8@.(B.
! 502: % [[0,1,2], [0,3,4],[0,5,6]]--> [1,0,0]
! 503: %>
! 504: /genUnit {
! 505: /arg1 set
! 506: [/mm /rr /i] pushVariables
! 507: [
! 508: /mm arg1 def
! 509: mm 0 get length newVector /rr set
! 510: rr null_to_zero /rr set
! 511: rr 0 (1).. put
! 512: /arg1 rr def
! 513: ] pop
! 514: popVariables
! 515: arg1
! 516: } def
! 517:
! 518: %<
! 519: % Usages: mm genUnitMatrix
! 520: % [[0,1,2], [0,3,4],[0,5,6]]--> [[1,0,0],[0,1,0],[0,0,1]]
! 521: %>
! 522: /genUnitMatrix {
! 523: /arg1 set
! 524: [/mm /rr /nn /i] pushVariables
! 525: [
! 526: /mm arg1 def
! 527: mm 0 get length /nn set
! 528: [
! 529: 0 1 nn 1 sub {
! 530: /i set
! 531: nn newVector null_to_zero /mm set
! 532: mm i (1).. put
! 533: mm
! 534: } for
! 535: ]
! 536: /arg1 set
! 537: ] pop
! 538: popVariables
! 539: arg1
! 540: } def
! 541:
! 542: %<
! 543: %%note: 2004, 8/29 (sun)
! 544: % toQuotientSpace : Linearity space $B$G3d$k(B.
! 545: % Usages: ineq mm toQuotientSpace
! 546: % $BF~NO$O(B coneEq $B$N=PNO(B ineq
! 547: % $B$*$h$S(B doPolymake --> getLinearitySubspace ==> L
! 548: % [L,[1,0,0,...]] asir_matrix_kernel removeFirstFromPolymake $B$GF@$i$l$?(B mm
! 549: % $B=PNO$+$i(B 0 $B%Y%/%H%k$O:o=|(B.
! 550: % $B=PNO$b(B coneEq $B7A<0(B. $BFC$K(B polymake $BMQ$K(B 0 $B$r2C$($k$N$,I,MW(B.
! 551: % ref: getUnit, removeFirstFromPolymake, addZeroForPolymake,
! 552: % asir_matrix_kernel, getLinearitySubspace
! 553: %>
! 554: /toQuotientSpace {
! 555: /arg2 set
! 556: /arg1 set
! 557: [/ineq /mm /rr] pushVariables
! 558: [
! 559: /ineq arg1 def
! 560: /mm arg2 def
! 561:
! 562: ineq mm transpose mul /rr set
! 563:
! 564: /arg1 rr def
! 565: ] pop
! 566: popVariables
! 567: arg1
! 568: } def
! 569:
! 570: /test5.data
! 571: $polymake.data(polymake.INEQUALITIES([[0,1,-1,1,-1,0],[0,0,-1,0,-1,2],[0,0,-1,0,-1,2],[0,0,-2,0,-2,4],[0,-1,0,-1,0,2],[0,-2,0,-2,0,4]]),polymake.VERTICES([[0,0,-1,0,0,0],[0,-1,-1,0,0,0],[0,1,0,-1,0,0],[0,-1,0,1,0,0],[0,0,1,0,-1,0],[0,0,-1,0,1,0],[0,-2,-2,0,0,-1],[0,2,2,0,0,1]]),polymake.FACETS([[0,1,-1,1,-1,0],[0,-1,0,-1,0,2]]),polymake.AFFINE_HULL(),polymake.FEASIBLE(),polymake.NOT__POINTED(),polymake.FAR_FACE([polymake._set([0,1,2,3,4,5,6,7])]),polymake.VERTICES_IN_INEQUALITIES([polymake._set([1,2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([0,2,3,4,5,6,7]),polymake._set([0,2,3,4,5,6,7])]),polymake.DIM([[5]]),polymake.AMBIENT_DIM([[5]]))$
! 572: def
! 573: %<
! 574: % Usages: test5
! 575: %% getConeInfo $B$rJQ99$9$l$P(B polymake $B$r8F$P$:$K%F%9%H$G$-$k(B.
! 576: %>
! 577: /test5 {
! 578: % test3b $B$h$j(B
! 579: /ww [(Dx) 1 (Dy) 2] def
! 580: % /ww [(x) 1 (y) -2 (Dx) 3 (Dy) 6] def
! 581: [(x,y) ring_of_differential_operators
! 582: [ww] weight_vector
! 583: 0] define_ring
! 584: [ (x Dx + y Dy -1).
! 585: (y^2 Dy^2 + 2 + y Dy ).
! 586: ] /gg set
! 587: gg {homogenize} map /gg set
! 588: [(AutoReduce) 1] system_variable
! 589: [gg] groebner 0 get /gg set
! 590: ww message
! 591:
! 592: ww gg coneEq getConeInfo /rr set
! 593: (Type in rr 0 get :: ) message
! 594: } def
! 595: %[5, [[1,0,1,0,-2],[0,1,0,1,-2]], $NOT__POINTED$ ]
! 596: % $B$3$N>l9g$O(B 2 $B<!85$^$GMn$9$H(B pointed cone $B$K$J$k(B.
! 597: % coneEq mmc transpose $B$r$b$H$K(B FACETS $B$r7W;;$9$l$P$h$$(B.
! 598:
! 599: %<
! 600: % Usage: ceq getConeInfo
! 601: % vw $B$O(B [v1 w1 v2 w2 ... ] $B7A<0(B. (v-w $B7A<0(B) w1, w2 $B$O(B univNumber $B$G$b$$$$(B.
! 602: % g $B$O(B reduced Grobner basis $B$H$7$F(B vw g coneEq $B$r7W;;(B. $B$3$l$r(B getConeInfo $B$X(B.
! 603: % Grobner cone $B$N(B $B<!85(B cdim (DIM), $BJd6u4V(B (linearity space ) $B$X$N9TNs(B mmc
! 604: % linearity space $B<+BN(B, pointed or not__pointed
! 605: % $B$D$^$j(B [cdim, L', L, PointedQ]
! 606: % $B$r7W;;$7$FLa$9(B. (polymake $B7A<0$NM>J,$JItJ,$J$7(B)
! 607: % polymake $BI,MW(B.
! 608: % ref: coneEq
! 609: % Global:
! 610: % cone.getConeInfo.rr0, cone.getConeInfo.rr1 $B$K(B polymake $B$h$j$NLa$jCM$,$O$$$k(B.
! 611: %>
! 612: /getConeInfo {
! 613: /arg1 set
! 614: [/ww /g /ceq /ceq2 /cdim /mmc /mmL /rr /ineq /ppt] pushVariables
! 615: [
! 616: /ceq arg1 def
! 617: ceq pruneZeroVector /ceq set
! 618: ceq genPo2 /ceq2 set
! 619: % ceq2 $B$O(B polymake.data(polymake.INEQUALITIES(...)) $B7A<0(B
! 620: % polymake $B$G(B ceq2 $B$N<!85$N7W;;(B.
! 621: /getConeInfo.ceq ceq def /getConeInfo.ceq2 ceq2 def
! 622:
! 623: cone.debug { (Calling polymake DIM.) message } { } ifelse
! 624: [(DIM) ceq2] doPolymake 1 get /rr set
! 625: cone.debug {(Done.) message } { } ifelse
! 626: % test5 $B$K$O<!$N%3%a%s%H$H$j$5$k(B. $B>e$N9T$r%3%a%s%H%"%&%H(B.
! 627: % test5.data tfbToTree /rr set
! 628: /cone.getConeInfo.rr0 rr def
! 629:
! 630: rr (DIM) getNode /cdim set
! 631: cdim 2 get 0 get 0 get 0 get to_univNum /cdim set
! 632: % polymake $B$N(B DIM $B$O0l$D>.$5$$$N$G(B 1 $BB-$9(B.
! 633: cdim (1).. add /cdim set
! 634:
! 635: rr (FACETS) getNode tag 0 eq {
! 636: % FACETS $B$r;}$C$F$$$J$$$J$i:FEY7W;;$9$k(B.
! 637: % POINTED, NOT__POINTED $B$bF@$i$l$k(B
! 638: cone.debug { (Calling polymake FACETS.) message } { } ifelse
! 639: [(FACETS) ceq2] doPolymake 1 get /rr set
! 640: cone.debug { (Done.) message } { } ifelse
! 641: } { } ifelse
! 642:
! 643: rr (VERTICES) getNode tag 0 eq {
! 644: (internal error: VERTICES is not found.) error
! 645: } { } ifelse
! 646:
! 647: /cone.getConeInfo.rr1 rr def
! 648:
! 649: rr (NOT__POINTED) getNode tag 0 eq {
! 650: % cone $B$,(B pointed $B$N;~$O(B mmc $B$OC10L9TNs(B. genUnitMatrix $B$r;H$&(B.
! 651: % VERTICES $B$h$j0l$D>.$5$$%5%$%:(B.
! 652: /mmc
! 653: [ rr (VERTICES) getNode 2 get 0 get 0 get rest]
! 654: genUnitMatrix
! 655: def
! 656: /mmL [ ] def
! 657: /ppt (POINTED) def
! 658: } {
! 659: % pointed $B$G$J$$>l9g(B,
! 660: % cone $B$N@~7AItJ,6u4V$r7W;;(B.
! 661: rr getLinearitySubspace /mmL set
! 662: [mmL genUnit] mmL join /mmc set % [1,0,0,...] $B$rB-$9(B.
! 663: mmc asir_matrix_kernel /mmc set % $BJd6u4V(B
! 664: mmc removeFirstFromPolymake /mmc set % $B$R$H$D>.$5$$%5%$%:$K(B.
! 665:
! 666: [mmL genUnit] mmL join asir_matrix_image
! 667: removeFirstFromPolymake /mmL set
! 668: mmL asir_matrix_image /mmL set % Linearity space $B$r5a$a$k(B. rm 0vector
! 669: /ppt (NOT__POINTED) def
! 670: } ifelse
! 671: /arg1 [[cdim mmc mmL ppt] rr] def
! 672: ] pop
! 673: popVariables
! 674: arg1
! 675: } def
! 676:
! 677:
! 678: /test.put {
! 679: /dog [(dog) [[(legs) 4] ] [1 2 3 ]] [(class) (tree)] dc def
! 680: /man [(man) [[(legs) 2] ] [1 2 3 ]] [(class) (tree)] dc def
! 681: /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def
! 682: /fan [ma 1 copy] def
! 683: ma (dog) getNode /dd set
! 684: dd 2 get /dd2 set
! 685: dd2 1 0 put
! 686: ma message
! 687:
! 688: fan message
! 689: } def
! 690:
! 691: /test6.data
! 692: $polymake.data(polymake.INEQUALITIES([[0,1,-1,1,-1,0],[0,0,-1,0,-1,2],[0,0,-1,0,-1,2],[0,0,-2,0,-2,4],[0,-1,0,-1,0,2],[0,-2,0,-2,0,4]]),polymake.VERTICES([[0,0,-1,0,0,0],[0,-1,-1,0,0,0],[0,1,0,-1,0,0],[0,-1,0,1,0,0],[0,0,1,0,-1,0],[0,0,-1,0,1,0],[0,-2,-2,0,0,-1],[0,2,2,0,0,1]]),polymake.FACETS([[0,1,-1,1,-1,0],[0,-1,0,-1,0,2]]),polymake.AFFINE_HULL(),polymake.FEASIBLE(),polymake.NOT__POINTED(),polymake.FAR_FACE([polymake._set([0,1,2,3,4,5,6,7])]),polymake.VERTICES_IN_INEQUALITIES([polymake._set([1,2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([2,3,4,5,6,7]),polymake._set([0,2,3,4,5,6,7]),polymake._set([0,2,3,4,5,6,7])]))$
! 693: def
! 694: % tfbToTree
! 695:
! 696: /arrayToTree { [(class) (tree)] dc } def
! 697:
! 698: %<
! 699: % polymake $B$h$jF@$i$l$?(B TreeObject $B$+$i(B TreeObject cone $B$r@8@.$9$k(B.
! 700: % Usages: test6.data tfbToTree newCone $B$GF0:n%F%9%H(B
! 701: %>
! 702: /test6 {
! 703: test6.data tfbToTree /rr set
! 704: rr newCone /rr2 set
! 705: } def
! 706:
! 707: %<
! 708: % Usages: doPolymakeObj newCone
! 709: %>
! 710: /newCone {
! 711: /arg1 set
! 712: [/polydata /cone /facets /vertices /flipped /ineq
! 713: /facetsv /rr] pushVariables
! 714: [
! 715: /polydata arg1 def
! 716: polydata (FACETS) getNode tag 0 eq {
! 717: (newCone : no FACETS data.) error
! 718: } { } ifelse
! 719: % facets $B$OM-M}?t$N>l9g@55,2=$9$k(B. data/test11 $B$G(B $BM-M}?t$G$k(B.
! 720: polydata (FACETS) getNode 2 get 0 get to_univNum
! 721: { nnormalize_vec} map /facets set
! 722: [[ ] ] facets join shell rest removeFirstFromPolymake /facets set
! 723: % vertices $B$O(B cone $B$N>e$K$"$k$N$G@0?tG\(B OK. $B@55,$+$9$k(B.
! 724: polydata (VERTICES) getNode 2 get 0 get to_univNum
! 725: { nnormalize_vec} map /vertices set
! 726: [[ ] ] vertices join shell rest removeFirstFromPolymake /vertices set
! 727: % inequalities $B$OM-M}?t$N>l9g@55,2=$9$k(B.
! 728: polydata (INEQUALITIES) getNode 2 get 0 get to_univNum
! 729: { nnormalize_vec } map /ineq set
! 730: [[ ] ] ineq join shell rest removeFirstFromPolymake /ineq set
! 731:
! 732: [(cone) [ ]
! 733: [
! 734: [(facets) [ ] facets] arrayToTree
! 735: [(flipped) [ ] facets length newVector null_to_zero] arrayToTree
! 736: [(facetsv) [ ] facets vertices newCone_facetsv] arrayToTree
! 737: [(vertices) [ ] vertices] arrayToTree
! 738: [(inequalities) [ ] ineq] arrayToTree
! 739: ]
! 740: ] arrayToTree /cone set
! 741: /arg1 cone def
! 742: ] pop
! 743: popVariables
! 744: arg1
! 745: } def
! 746:
! 747: %<
! 748: % Usages: newCone_facetv
! 749: % facet vertices newCone_facetv
! 750: % facet $B$K$N$C$F$$$k(B vertices $B$r$9$Y$FNs5s(B.
! 751: %>
! 752: /newCone_facetv {
! 753: /arg2 set
! 754: /arg1 set
! 755: [/facet /vertices] pushVariables
! 756: [
! 757: /facet arg1 def /vertices arg2 def
! 758: [
! 759: 0 1 vertices length 1 sub {
! 760: /ii set
! 761: facet vertices ii get mul isZero
! 762: { vertices ii get } { } ifelse
! 763: } for
! 764: ]
! 765: /arg1 set
! 766: ] pop
! 767: popVariables
! 768: arg1
! 769: } def
! 770:
! 771: %<
! 772: % Usages: newCone_facetsv
! 773: % facets vertices newCone_facetv
! 774: % facets $B$K$N$C$F$$$k(B vertices $B$r$9$Y$FNs5s(B. $B%j%9%H$r:n$k(B.
! 775: %>
! 776: /newCone_facetsv {
! 777: /arg2 set
! 778: /arg1 set
! 779: [/facets /vertices] pushVariables
! 780: [
! 781: /facets arg1 def /vertices arg2 def
! 782: facets { vertices newCone_facetv } map
! 783: /arg1 set
! 784: ] pop
! 785: popVariables
! 786: arg1
! 787: } def
! 788:
! 789: %<
! 790: % Usages: cone_random
! 791: %>
! 792: /cone_random.start (2).. def
! 793: /cone_random {
! 794: [(tdiv_qr)
! 795: cone_random.start (1103515245).. mul
! 796: (12345).. add
! 797:
! 798: (2147483646)..
! 799: ] mpzext 1 get /cone_random.start set
! 800: cone_random.start
! 801: } def
! 802:
! 803: /cone_random.limit 40 def
! 804: /cone_random_vec {
! 805: /arg1 set
! 806: [/nn /rr] pushVariables
! 807: [
! 808: /nn arg1 def
! 809: [
! 810: 0 1 nn 1 sub {
! 811: pop
! 812: [(tdiv_qr) cone_random cone_random.limit] mpzext 1 get
! 813: } for
! 814: ] /arg1 set
! 815: ] pop
! 816: popVariables
! 817: arg1
! 818: } def
! 819:
! 820: %<
! 821: % Usages: getNewRandomWeight
! 822: %% max dim $B$N(B cone $B$r@8@.$9$k$?$a$K(B, random $B$J(B weight $B$r@8@.$9$k(B.
! 823: %% h, H $B$N=hM}$bI,MW(B.
! 824: %% $B@)Ls>r7o(B u+v >= 2t $B$r$_$?$9(B weight $B$,I,MW(B. $B$3$l$r$I$N$h$&$K:n$k$N$+(B?
! 825: %>
! 826: /getNewRandomWeight {
! 827: /arg1 set
! 828: [/vv /vvd /rr] pushVariables
! 829: [
! 830: /vv arg1 def
! 831: vv { (D) 2 1 roll 2 cat_n } map /vvd set
! 832: ] pop
! 833: popVariables
! 834: arg1
! 835: } def
! 836:
! 837: % test7 : univNum $B$N(B weight $B$,@5$7$/G'<1$5$l$k$+$N%F%9%H(B
! 838: % aux-cone.sm1
! 839:
! 840: %<
! 841: % Usages: n d coneEqForSmallFan.2 (cone.type 2 $B@lMQ(B: x,y,Dx,Dy,h)
! 842: % n $BJQ?t$N?t(B, d zero $B$K$7$J$$JQ?t$N?t(B. d $B$O(B max dim cone $B$N<!85$H$J$k(B.
! 843: % $B$O$8$a$+$i(B d $B8D$NJQ?t(B.
! 844: % 4, 2 , s,t,x,y $B$J$i(B weight $B$O(B s,t,Ds,Dt $B$N$_(B.
! 845: % u_i + v_i >= 0 , u_i = v_i = 0.
! 846: % homog $BJQ?t$N>r7o(B u_i+v_i >= t, i.e, -t >= 0 $B$bF~$l$k(B.
! 847: % coneEq $B$N7k2L$H(B coneEqForSmallFan.2 $B$N7k2L$r(B join $B$7$F(B
! 848: % getConeInfo or newCone
! 849: % note-cone.sm1 2004.8.31 $B$r8+$h(B. w_ineq $B$"$?$j(B.
! 850: % cone.local $B$,@_Dj$5$l$F$$$k$H(B u_i <= 0 $B$b>r7o$KF~$k(B.
! 851: %>
! 852: /coneEqForSmallFan.2 {
! 853: /arg2 set
! 854: /arg1 set
! 855: [/n /d /nn /dd /ii /tt] pushVariables
! 856: [
! 857: /n arg1 def
! 858: /d arg2 def
! 859: n to_int32 /n set
! 860: d to_int32 /d set
! 861: /dd n d add def
! 862: /nn n n add def
! 863:
! 864: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i = 0
! 865: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
! 866: % -t >= 0
! 867: [
! 868: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
! 869: d 1 n 1 sub {
! 870: /ii set
! 871: % [ 0,0, ..., 0,1,0,... ; 0] $B$r@8@.(B
! 872: nn 1 add newVector null_to_zero /tt set
! 873: tt ii (1).. put
! 874: tt
! 875: % [ 0,0, ..., 0,-1,0,... ; 0] $B$r@8@.(B
! 876: nn 1 add newVector null_to_zero /tt set
! 877: tt ii (-1).. put
! 878: tt
! 879: } for
! 880: dd 1 nn 1 sub {
! 881: /ii set
! 882: nn 1 add newVector null_to_zero /tt set
! 883: tt ii (1).. put
! 884: tt
! 885: nn 1 add newVector null_to_zero /tt set
! 886: tt ii (-1).. put
! 887: tt
! 888: } for
! 889:
! 890: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i = 0
! 891: 0 1 d 1 sub {
! 892: /ii set
! 893: nn 1 add newVector null_to_zero /tt set
! 894: tt ii (1).. put
! 895: tt ii n add (1).. put
! 896: tt
! 897:
! 898: nn 1 add newVector null_to_zero /tt set
! 899: tt ii (-1).. put
! 900: tt ii n add (-1).. put
! 901: tt
! 902:
! 903: } for
! 904:
! 905: % -t >= 0
! 906: cone.h0 {
! 907: % t = 0
! 908: nn 1 add newVector null_to_zero /tt set
! 909: tt nn (1).. put
! 910: tt
! 911: nn 1 add newVector null_to_zero /tt set
! 912: tt nn (-1).. put
! 913: tt
! 914: }
! 915: {
! 916: % -t >= 0
! 917: nn 1 add newVector null_to_zero /tt set
! 918: tt nn (-1).. put
! 919: tt
! 920: } ifelse
! 921:
! 922: % cone.local $B$,(B 1 $B$N;~(B
! 923: % 0 ~ d-1 $B$G$O(B -u_i >= 0
! 924: cone.local {
! 925: 0 1 d 1 sub {
! 926: /ii set
! 927: nn 1 add newVector null_to_zero /tt set
! 928: tt ii (-1).. put
! 929: tt
! 930: } for
! 931: } { } ifelse
! 932: ] /rr set
! 933: /arg1 rr to_univNum def
! 934: ] pop
! 935: popVariables
! 936: arg1
! 937: } def
! 938:
! 939: %<
! 940: % Usages: n d coneEqForSmallFan.1 (cone.type 1 $B@lMQ(B: x,y,Dx,Dy,h,H)
! 941: % cone.type 2 $B$G$O(B x,y,Dx,Dy,h
! 942: % coneEqForSmallFan.2 $B$N7k2L$rMQ$$$F@8@.(B.
! 943: % H $B$N>r7o$r2C$($k(B.
! 944: %>
! 945: /coneEqForSmallFan.1 {
! 946: /arg2 set
! 947: /arg1 set
! 948: [/n /d /i /j /rr /tt /tt2] pushVariables
! 949: [
! 950: /n arg1 def /d arg2 def
! 951: n d coneEqForSmallFan.2 /rr set
! 952: rr cone.appendZero /rr set
! 953: % H $BMQ$N(B 0 $B$r2C$($k(B.
! 954: % $B$H$j$"$($:(B t' = 0 $B$G$-$a$&$A(B.
! 955: cone.h0 { } { (cone.h0 = 0 has not yet been implemented.) error } ifelse
! 956: n 2 mul 2 add newVector null_to_zero /tt set
! 957: tt n 2 mul 2 add 1 sub (-1).. put
! 958: n 2 mul 2 add newVector null_to_zero /tt2 set
! 959: tt2 n 2 mul 2 add 1 sub (1).. put
! 960: rr [tt tt2] join /rr set
! 961: /arg1 rr to_univNum def
! 962: ] pop
! 963: popVariables
! 964: arg1
! 965: } def
! 966:
! 967: %<
! 968: % Usages: vv ineq toQuotientCone
! 969: % weight space $B$N(B $B%Q%i%a!<%?$D$1$N$?$a$K;H$&(B.
! 970: % cone.V $B$r5a$a$?$$(B. vv $B$O(B doPolymakeObj (VERTICES) getNode 2 get 0 get $B$GF@$k(B.
! 971: % vertices $B$N(B non-negative combination $B$,(B cone.
! 972: % vertice cone.w_ineq isInLinearSubspace $B$J$i<h$j=|$/(B.
! 973: % $B$D$^$j(B vertice*cone.w_ineq = 0 $B$J$i<h$j=|$/(B.
! 974: %
! 975: % $B$3$l$G@5$7$$(B? $B>ZL@$O(B? $B$^$@ESCf(B. cone.W $B$r5a$a$k$N$K;H$&(B. (BUG)
! 976: % cone.w_cone 1 get (VERTICES) getNode :: $B$HHf3S$;$h(B.
! 977: % $B$3$N4X?t$r8F$s$G(B cone.W $B$r:n$k$N$OITMW$+$b(B.
! 978: %
! 979: % Example: cf. parametrizeSmallFan
! 980: % 4 2 coneEqForSmallFan.2 /cone.w_ineq set cone.w_ineq getConeInfo /rr set
! 981: % rr 1 get (VERTICES) getNode 2 get 0 get removeFirstFromPolymake /vv set
! 982: % vv cone.w_ineq toQuotientCone pmat
! 983: %>
! 984: /toQuotientCone {
! 985: /arg2 set /arg1 set
! 986: [/vv /ineq /rr] pushVariables
! 987: [
! 988: /vv arg1 def /ineq arg2 def
! 989: vv {
! 990: dup
! 991: ineq isInLinearSpace 1 eq { pop }
! 992: { } ifelse
! 993: } map /arg1 set
! 994: ] pop
! 995: popVariables
! 996: arg1
! 997: } def
! 998:
! 999: %<
! 1000: % Usages: n d parametrizeSmallFan
! 1001: % n : x $BJQ?t$N?t(B.
! 1002: % d : 0 $B$K$7$J$$(B weight $B$N?t(B.
! 1003: % $B<!$NBg0hJQ?t$b@_Dj$5$l$k(B.
! 1004: % cone.W : weight $B$r%Q%i%a!<%?$E$1$9$k%Y%/%H%k$NAH(B.
! 1005: % cone.Wpos : i $B$,(B 0 ~ Wpos-1 $B$NHO0O$N$H$-(B V[i] $B$X$O(B N $B$N85$r3]$1;;$7$F$h$$(B,
! 1006: % i $B$,(B Wpos ~ $B$NHO0O$N$H$-(B V[i] $B$X$O(B Z $B$N85$r3]$1;;$7$F$h$$(B.
! 1007: % cone.w_ineq : weight space $B$NITEy<0@)Ls(B. $B0J8e$N7W;;$G>o$KIU2C$9$k(B.
! 1008: % cone.w_cone : w_ineq $B$r(B polymake $B$G(B getConeInfo $B$7$?7k2L(B.
! 1009: % Example: /cone.local 1 def ; 4 2 parametrizeSmallFan pmat
! 1010: % Example: /cone.local 0 def ; 4 2 parametrizeSmallFan pmat
! 1011: %>
! 1012: /parametrizeSmallFan {
! 1013: /arg2 set /arg1 set
! 1014: [/n /d /vv /coneray] pushVariables
! 1015: [
! 1016: /n arg1 def /d arg2 def
! 1017: {
! 1018: cone.type 1 eq {
! 1019: n d coneEqForSmallFan.1 /cone.w_ineq set
! 1020: exit
! 1021: } { } ifelse
! 1022: cone.type 2 eq {
! 1023: n d coneEqForSmallFan.2 /cone.w_ineq set
! 1024: exit
! 1025: } { } ifelse
! 1026: (This cone.type has not yet been implemented.) error
! 1027: } loop
! 1028: cone.w_ineq getConeInfo /cone.w_cone set
! 1029: cone.w_cone 1 get (VERTICES) getNode 2 get 0 get
! 1030: removeFirstFromPolymake /vv set
! 1031:
! 1032: vv cone.w_ineq toQuotientCone /coneray set
! 1033: coneray length /cone.Wpos set
! 1034:
! 1035: coneray cone.w_cone 0 get 2 get join /cone.W set
! 1036: /arg1 cone.W def
! 1037: ] pop
! 1038: popVariables
! 1039: arg1
! 1040: } def
! 1041:
! 1042: %<
! 1043: % Usages: n d coneEqForTotalFan.2 (cone.type 2 $B@lMQ(B: x,y,Dx,Dy,h)
! 1044: % n $BJQ?t$N?t(B,
! 1045: % d 0 $B$K$7$J$$JQ?t(B.
! 1046: % u_i + v_i >= 0 ,
! 1047: % homog $BJQ?t$N>r7o(B u_i+v_i >= 0, t = 0 $B$bF~$l$k(B.
! 1048: % coneEq $B$N7k2L$H(B coneEqForSmallFan.2 $B$N7k2L$r(B join $B$7$F(B
! 1049: % getConeInfo or newCone
! 1050: % cone.local $B$,@_Dj$5$l$F$$$k$H(B u_i <= 0 $B$b>r7o$KF~$k(B.
! 1051: %>
! 1052: /coneEqForTotalFan.2 {
! 1053: /arg2 set
! 1054: /arg1 set
! 1055: [/n /nn /dd /ii /tt] pushVariables
! 1056: [
! 1057: /n arg1 def
! 1058: /d arg2 def
! 1059: n to_int32 /n set
! 1060: d to_int32 /d set
! 1061: /nn n n add def
! 1062: /dd n d add def
! 1063:
! 1064: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i >= 0
! 1065: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
! 1066: % t = 0
! 1067: [
! 1068: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
! 1069: d 1 n 1 sub {
! 1070: /ii set
! 1071: % [ 0,0, ..., 0,1,0,... ; 0] $B$r@8@.(B
! 1072: nn 1 add newVector null_to_zero /tt set
! 1073: tt ii (1).. put
! 1074: tt
! 1075: % [ 0,0, ..., 0,-1,0,... ; 0] $B$r@8@.(B
! 1076: nn 1 add newVector null_to_zero /tt set
! 1077: tt ii (-1).. put
! 1078: tt
! 1079: } for
! 1080: dd 1 nn 1 sub {
! 1081: /ii set
! 1082: nn 1 add newVector null_to_zero /tt set
! 1083: tt ii (1).. put
! 1084: tt
! 1085: nn 1 add newVector null_to_zero /tt set
! 1086: tt ii (-1).. put
! 1087: tt
! 1088: } for
! 1089:
! 1090: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i >= 0
! 1091: 0 1 d 1 sub {
! 1092: /ii set
! 1093: nn 1 add newVector null_to_zero /tt set
! 1094: tt ii (1).. put
! 1095: tt ii n add (1).. put
! 1096: tt
! 1097:
! 1098: } for
! 1099:
! 1100: % t = 0
! 1101: cone.h0 {
! 1102: % t = 0
! 1103: nn 1 add newVector null_to_zero /tt set
! 1104: tt nn (1).. put
! 1105: tt
! 1106: nn 1 add newVector null_to_zero /tt set
! 1107: tt nn (-1).. put
! 1108: tt
! 1109: }
! 1110: {
! 1111: (coneForTotalFan.2. Not implemented.) error
! 1112: } ifelse
! 1113:
! 1114: % cone.local $B$,(B 1 $B$N;~(B
! 1115: % 0 ~ d-1 $B$G$O(B -u_i >= 0
! 1116: cone.local {
! 1117: 0 1 d 1 sub {
! 1118: /ii set
! 1119: nn 1 add newVector null_to_zero /tt set
! 1120: tt ii (-1).. put
! 1121: tt
! 1122: } for
! 1123: } { } ifelse
! 1124: ] /rr set
! 1125: /arg1 rr to_univNum def
! 1126: ] pop
! 1127: popVariables
! 1128: arg1
! 1129: } def
! 1130:
! 1131: %<
! 1132: % Usages: n d parametrizeTotalFan
! 1133: % n : x $BJQ?t$N?t(B.
! 1134: % d : 0 $B$K$7$J$$?t(B.
! 1135: % $B<!$NBg0hJQ?t$b@_Dj$5$l$k(B.
! 1136: % cone.W : weight $B$r%Q%i%a!<%?$E$1$9$k%Y%/%H%k$NAH(B.
! 1137: % cone.Wpos : i $B$,(B 0 ~ Wpos-1 $B$NHO0O$N$H$-(B V[i] $B$X$O(B N $B$N85$r3]$1;;$7$F$h$$(B,
! 1138: % i $B$,(B Wpos ~ $B$NHO0O$N$H$-(B V[i] $B$X$O(B Z $B$N85$r3]$1;;$7$F$h$$(B.
! 1139: % cone.w_ineq : weight space $B$NITEy<0@)Ls(B. $B0J8e$N7W;;$G>o$KIU2C$9$k(B.
! 1140: % cone.w_ineq $B$r(B getConeInfo $B$7$?7k2L$O(B cone.w_cone
! 1141: % Example: /cone.local 1 def ; 3 parametrizeSmallFan pmat
! 1142: % Example: /cone.local 0 def ; 3 parametrizeSmallFan pmat
! 1143: % local $B$,(B 1 $B$@$H(B u_i <= 0 $B$K$J$k(B.
! 1144: %>
! 1145: /parametrizeTotalFan {
! 1146: /arg2 set
! 1147: /arg1 set
! 1148: [/n /d /vv /coneray] pushVariables
! 1149: [
! 1150: /n arg1 def /d arg2 def
! 1151: {
! 1152: cone.type 2 eq { n d coneEqForTotalFan.2 /cone.w_ineq set exit}
! 1153: { } ifelse
! 1154: (This cone.type has not yet been implemented.) error
! 1155: } loop
! 1156: cone.w_ineq getConeInfo /cone.w_cone set
! 1157: cone.w_cone 1 get (VERTICES) getNode 2 get 0 get
! 1158: removeFirstFromPolymake /vv set
! 1159:
! 1160: vv cone.w_ineq toQuotientCone /coneray set
! 1161: coneray length /cone.Wpos set
! 1162:
! 1163: coneray cone.w_cone 0 get 2 get join /cone.W set
! 1164: /arg1 cone.W def
! 1165: ] pop
! 1166: popVariables
! 1167: arg1
! 1168: } def
! 1169:
! 1170: %<
! 1171: % Usages: vlist wlist cone_wtowv
! 1172: % [x y Dx Dy h] [-1 0 1 0 0] ==> [(x) -1 (Dx) 1] $B$r:n$k(B.
! 1173: %>
! 1174: /cone_wtowv {
! 1175: /arg2 set /arg1 set
! 1176: [/vlist /wlist /ii] pushVariables
! 1177: [
! 1178: /vlist arg1 def
! 1179: /wlist arg2 def
! 1180: wlist length vlist length eq {
! 1181: } { (cone_wtowv: length of the argument must be the same.) error} ifelse
! 1182:
! 1183: wlist to_int32 /wlist set
! 1184: [
! 1185: 0 1 wlist length 1 sub {
! 1186: /ii set
! 1187: wlist ii get 0 eq { }
! 1188: { vlist ii get wlist ii get } ifelse
! 1189: } for
! 1190: ] /arg1 set
! 1191: ] pop
! 1192: popVariables
! 1193: arg1
! 1194: } def
! 1195:
! 1196: %<
! 1197: % Usages: pruneZeroVector
! 1198: % genPo, getConeInfo $BEy$NA0$K;H$&(B. 0 $B%Y%/%H%k$O0UL#$N$J$$@)Ls$J$N$G=|$/(B.
! 1199: %>
! 1200: /pruneZeroVector {
! 1201: /arg1 set
! 1202: [/mm /ii /jj /tt] pushVariables
! 1203: [
! 1204: /mm arg1 def
! 1205: mm to_univNum /mm set
! 1206: [
! 1207: 0 1 mm length 1 sub {
! 1208: /ii set
! 1209: mm ii get /tt set
! 1210: {
! 1211: 0 1 tt length 1 sub {
! 1212: /jj set
! 1213: tt jj get (0).. eq { }
! 1214: { tt exit } ifelse
! 1215: } for
! 1216: exit
! 1217: } loop
! 1218: } for
! 1219: ] /arg1 set
! 1220: ] pop
! 1221: arg1
! 1222: } def
! 1223:
! 1224: %<
! 1225: % Usages: a projectIneq v , dim(a) = n, dim(v) = d
! 1226: % a*cone.Wt*cone.Lpt
! 1227: %>
! 1228: /projectIneq {
! 1229: cone.Wt mul cone.Lpt mul
! 1230: } def
! 1231:
! 1232: %<
! 1233: % Usages: v liftWeight [w vw], dim(v) = d, dim(w) = n, vw : vw $B7A<0$N(B weight
! 1234: % v*cone.Lp*cone.W cone.vlist w cone_wtowv
! 1235: %>
! 1236: /liftWeight {
! 1237: /arg1 set
! 1238: [/v /w /vw] pushVariables
! 1239: [
! 1240: /v arg1 def
! 1241: v cone.Lp mul cone.W mul /w set
! 1242: [w cone.vlist w cone_wtowv] /arg1 set
! 1243: ] pop
! 1244: popVariables
! 1245: arg1
! 1246: } def
! 1247:
! 1248: %<
! 1249: % Usage: m isZero
! 1250: % dr.sm1 $B$X0\$9(B.
! 1251: %>
! 1252: /isZero {
! 1253: /arg1 set
! 1254: [/mm /ans /ii] pushVariables
! 1255: [
! 1256: /mm arg1 def
! 1257: /ans 1 def
! 1258: mm isArray {
! 1259: 0 1 mm length 1 sub {
! 1260: /ii set
! 1261: mm ii get isZero /ans set
! 1262: ans 0 eq { exit } { } ifelse
! 1263: } for
! 1264: } {
! 1265: {
! 1266: mm tag 1 eq {/ans mm 0 eq def exit} { } ifelse
! 1267: mm isPolynomial { /ans mm (0). eq def exit } { } ifelse
! 1268: mm isUniversalNumber { /ans mm (0).. eq def exit } { } ifelse
! 1269: /ans 0 def exit
! 1270: } loop
! 1271: } ifelse
! 1272: /arg1 ans def
! 1273: ] pop
! 1274: popVariables
! 1275: arg1
! 1276: } def
! 1277: [(isZero)
! 1278: [(m isZero bool)]] putUsages
! 1279:
! 1280: %<
! 1281: % Usage: m isNonNegative
! 1282: % dr.sm1 $B$X0\$9(B.
! 1283: %>
! 1284: /isNonNegative {
! 1285: /arg1 set
! 1286: [/mm /ans /ii] pushVariables
! 1287: [
! 1288: /mm arg1 def
! 1289: /ans 1 def
! 1290: mm isArray {
! 1291: 0 1 mm length 1 sub {
! 1292: /ii set
! 1293: mm ii get isNonNegative /ans set
! 1294: ans 0 eq { exit } { } ifelse
! 1295: } for
! 1296: } {
! 1297: {
! 1298: mm tag 1 eq {/ans mm 0 gt mm 0 eq or def exit} { } ifelse
! 1299: mm isUniversalNumber { /ans mm (0).. gt mm (0).. eq or def exit }
! 1300: { } ifelse
! 1301: mm isRational { mm (numerator) dc mm (denominator) dc mul /mm set
! 1302: /ans mm (0).. gt mm (0).. eq or def exit } { } ifelse
! 1303: /ans 0 def exit
! 1304: } loop
! 1305: } ifelse
! 1306: /arg1 ans def
! 1307: ] pop
! 1308: popVariables
! 1309: arg1
! 1310: } def
! 1311: [(isNonNegative)
! 1312: [(m isNonNegative bool)
! 1313: (In case of matrix, m[i,j] >= 0 must hold for all i,j.)
! 1314: ]] putUsages
! 1315:
! 1316: % Global variable: cone.weightBorder
! 1317: % /cone.weightBorder null def $BITMW$G$"$m$&(B. getStartingCone $B$G@_Dj$5$l$k(B.
! 1318:
! 1319: %<
! 1320: % Usages: cone i isOnWeigthBorder
! 1321: % cone $B$N(B i $BHVL\$N(B facet $B$,(B weight $B6u4V$N6-3&$K$"$k$+(B?
! 1322: % $BBg0hJQ?t(B cone.weightBorder $B$,@_Dj$5$l$F$k$3$H(B.
! 1323: % $B$3$NJQ?t$O(B cone $B$N(B facet $B%Y%/%H%k$N%j%9%H(B.
! 1324: % $B$3$NJQ?t$O(B setWeightBorder $B$G@_Dj(B
! 1325: % cone.weightBorder[0] or cone.weightBorder[1] or ...
! 1326: % /ccone cone.startingCone def ccone 0 isOnWeightBorder
! 1327: % ccone 1 isOnWeightBorder
! 1328: %>
! 1329: /isOnWeightBorder {
! 1330: /arg2 set /arg1 set
! 1331: [/cone /facet_i /i /j /vv /co /ans] pushVariables
! 1332: [
! 1333: /cone arg1 def /facet_i arg2 def
! 1334: facet_i to_int32 /facet_i set
! 1335: /ans 0 def
! 1336: cone (facetsv) getNode 2 get facet_i get /vv set % Facet $B$r(B vertex $BI=8=(B.
! 1337: {
! 1338: 0 1 cone.weightBorder length 1 sub {
! 1339: /i set
! 1340: cone.weightBorder i get /co set % co $B$K@)Ls>r7o(B
! 1341: vv cone.Lp mul % vv $B$r(B weight space $B$X(B lift.
! 1342: co mul isZero
! 1343: { /ans 1 def exit } { } ifelse
! 1344: } for
! 1345: exit
! 1346: } loop
! 1347: /arg1 ans def
! 1348: ] pop
! 1349: popVariables
! 1350: arg1
! 1351: } def
! 1352:
! 1353: %<
! 1354: % Usages: cone i markFlipped
! 1355: % cone $B$N(B i $BHVL\$N(B facet $B$K(B flipped $B$N0u$r$D$1$k(B. cone $B<+BN$,JQ99$5$l$k(B.
! 1356: % cone $B$O(B class-tree. Constructor $B$O(B newCone
! 1357: %>
! 1358: /markFlipped {
! 1359: /arg2 set /arg1 set
! 1360: [/cone /facet_i /vv] pushVariables
! 1361: [
! 1362: /cone arg1 def /facet_i arg2 def
! 1363: facet_i to_int32 /facet_i set
! 1364: cone (flipped) getNode 2 get /vv set
! 1365: vv facet_i (1).. put
! 1366: ] pop
! 1367: popVariables
! 1368: } def
! 1369:
! 1370:
! 1371:
! 1372: %<
! 1373: % Usages: cone getNextFacet i
! 1374: % flipped $B$N(B mark $B$N$J$$(B facet $B$N(B index facet_i $B$rLa$9(B.
! 1375: % $B$=$l$,$J$$$H$-$O(B null
! 1376: %>
! 1377: /getNextFacet {
! 1378: /arg1 set
! 1379: [/cone /facet_i /vv /ii] pushVariables
! 1380: [
! 1381: /cone arg1 def
! 1382: /facet_i null def
! 1383: cone (flipped) getNode 2 get /vv set
! 1384: 0 1 vv length 1 sub {
! 1385: /ii set
! 1386: vv ii get to_int32 0 eq { /facet_i ii def exit }
! 1387: { } ifelse
! 1388: } for
! 1389: /arg1 facet_i def
! 1390: ] pop
! 1391: popVariables
! 1392: arg1
! 1393: } def
! 1394:
! 1395: %<
! 1396: % Usages: cone i epsilon flipWeight
! 1397: % cone $B$N(B i $BHVL\$N(B facet $B$K$+$s$7$F(B flip $B$9$k(B.
! 1398: % $B?7$7$$(B weight $B$r5a$a$k(B. cf. liftWeight
! 1399: %>
! 1400: /flipWeight {
! 1401: /arg3 set /arg2 set /arg1 set
! 1402: [/cone /facet_i /ep /vp /v /v /ii] pushVariables
! 1403: [
! 1404: /cone arg1 def /facet_i arg2 def
! 1405: facet_i to_int32 /facet_i set
! 1406: /ep arg3 def
! 1407:
! 1408: ep to_univNum (1).. div /ep set
! 1409:
! 1410: % note: 2004.9.2
! 1411: cone (facetsv) getNode 2 get facet_i get /v set
! 1412: cone (facets) getNode 2 get facet_i get /f set
! 1413: /vp v 0 get def
! 1414: 1 1 v length 1 sub {
! 1415: /ii set
! 1416: vp v ii get add /vp set
! 1417: } for
! 1418: vp ep f mul sub /vp set
! 1419: vp nnormalize_vec /vp set
! 1420: /arg1 vp def
! 1421: ] pop
! 1422: popVariables
! 1423: arg1
! 1424: } def
! 1425:
! 1426: %<
! 1427: % Usages: cone1 cone2 isSameCone bool
! 1428: % cone1 cone2 $B$,Ey$7$$$+(B? facet $B$GHf$Y$k(B.
! 1429: % cone1, cone2 $B$O(B pointed cone $B$G$J$$$H$$$1$J$$(B.
! 1430: %>
! 1431: /isSameCone {
! 1432: /arg2 set /arg1 set
! 1433: [/cone1 /cone2 /facets1 /facets2 /ans] pushVariables
! 1434: [
! 1435: /cone1 arg1 def
! 1436: /cone2 arg2 def
! 1437: /facets1 cone1 (facets) getNode 2 get def
! 1438: /facets2 cone2 (facets) getNode 2 get def
! 1439: facets1 length facets2 length eq {
! 1440: facets1 facets2 sub isZero /ans set
! 1441: } {
! 1442: /ans 0 def
! 1443: } ifelse
! 1444: /arg1 ans def
! 1445: ] pop
! 1446: popVariables
! 1447: arg1
! 1448: } def
! 1449:
! 1450: %<
! 1451: % Usages: cone1 cone2 getCommonFacet list
! 1452: % cone1 $B$NCf$G(B cone2 $B$K4^$^$l$k(B facet $B$N%j%9%H(B
! 1453: % cone2 $B$NCf$G(B cone1 $B$K4^$^$l$k(B facet $B$N%j%9%H$r$b$I$9(B.
! 1454: % [1 [i] [j]] $B$"$k$H$-(B. [0 [ ] [ ]] $B$J$$$H$-(B.
! 1455: % cone1 $B$N(B facetsv[i] $B$,(B cone2 $B$K4^$^$l$k$+D4$Y$k(B.
! 1456: % cone2 $B$N(B facetsv[i] $B$,(B cone1 $B$K4^$^$l$k$+D4$Y$k(B.
! 1457: % cone1, cone2 $B$O(B pointed cone $B$G$J$$$H$$$1$J$$(B.
! 1458: %>
! 1459: /getCommonFacet {
! 1460: /arg2 set /arg1 set
! 1461: [/cone1 /cone2 /facets /ineq /ans1 /ans2 /i /tt] pushVariables
! 1462: [
! 1463: /cone1 arg1 def
! 1464: /cone2 arg2 def
! 1465:
! 1466: /facets cone1 (facetsv) getNode 2 get def
! 1467: /ineq cone2 (inequalities) getNode 2 get def
! 1468: /ans1 [
! 1469: 0 1 facets length 1 sub {
! 1470: /i set
! 1471: facets i get /tt set % facetsv[i] $B$r(B tt $B$X(B.
! 1472: ineq tt transpose mul isNonNegative {
! 1473: i
! 1474: } { } ifelse
! 1475: } for
! 1476: ] def
! 1477:
! 1478: /facets cone2 (facetsv) getNode 2 get def
! 1479: /ineq cone1 (inequalities) getNode 2 get def
! 1480: /ans2 [
! 1481: 0 1 facets length 1 sub {
! 1482: /i set
! 1483: facets i get /tt set % facetsv[i] $B$r(B tt $B$X(B.
! 1484: ineq tt transpose mul isNonNegative {
! 1485: i
! 1486: } { } ifelse
! 1487: } for
! 1488: ] def
! 1489: ans1 length 1 gt ans2 length 1 gt or {
! 1490: (getCommonFacet found more than 1 common facets.) error
! 1491: } { } ifelse
! 1492: % $B6&DL(B facet $B$,$"$l$P(B 1, $B$J$1$l$P(B 0.
! 1493: ans1 length 1 eq ans2 length 1 eq and {
! 1494: /tt 1 def
! 1495: } {
! 1496: /tt 0 def
! 1497: } ifelse
! 1498: /arg1 [tt ans1 ans2] def
! 1499: ] pop
! 1500: popVariables
! 1501: arg1
! 1502: } def
! 1503:
! 1504: %
! 1505: % -------------------------------------------------
! 1506: % test8 $B$O(B aux-cone.sm1 $B$X0\F0(B.
! 1507: % $B0J2<$$$h$$$h0lHL$N%W%m%0%i%`$N:n@.3+;O(B.
! 1508: % -------------------------------------------------
! 1509: %
! 1510:
! 1511: %<
! 1512: % Usages: setWeightBorder
! 1513: % cone.weightBorder (weight cone $B$N(B facet $B%Y%/%H%k$N=89g(B) $B$r@_Dj$9$k(B.
! 1514: % $B$"$HI{;:J*$H$7$F(B cone.w_cone_projectedWt (doPolymakeObj)
! 1515: % cone.w_ineq_projectedWt
! 1516: % cone.m $B<!85$N%Y%/%H%k(B.
! 1517: % cone.W, cone.Wt, cone.w_ineq $B$,$9$G$K7W;;$:$_$G$J$$$H$$$1$J$$(B.
! 1518: %>
! 1519: /setWeightBorder {
! 1520: [
! 1521: (Entering setWeightBorder ) message
! 1522: cone.w_ineq cone.Wt mul pruneZeroVector /cone.w_ineq_projectedWt set
! 1523: {
! 1524: cone.w_ineq_projectedWt length 0 eq {
! 1525: % weight $B$N6u4V$K(B border $B$,$J$$>l9g(B.
! 1526: /cone.weightBorder [ ] def
! 1527: exit
! 1528: } { } ifelse
! 1529: % weight $B$N6u4V$K(B border $B$,$"$k>l9g(B.
! 1530: cone.w_ineq_projectedWt getConeInfo /cone.w_cone_projectedWt set
! 1531: cone.w_cone_projectedWt 0 get 0 get to_int32 cone.m to_int32 eq {
! 1532: } {
! 1533: (setWeightBorder : internal error.) message
! 1534: } ifelse
! 1535: cone.w_cone_projectedWt 1 get (FACETS) getNode 2 get 0 get
! 1536: removeFirstFromPolymake /cone.weightBorder set
! 1537: exit
! 1538: } loop
! 1539: (cone.weightBorder=) message
! 1540: cone.weightBorder pmat
! 1541: ] pop
! 1542: } def
! 1543:
! 1544: %
! 1545: % -------------------------------------------------
! 1546: % $B%W%m%0%i%`$NN.$l(B.
! 1547: % Global: cone.fan cone $B$rG[Ns$H$7$F3JG<$9$k(B.
! 1548: %
! 1549: % ncone (next cone) $B$,?75,$KF@$i$l$?(B cone $B$G$"$k$H$9$k(B.
! 1550: % $B$3$N$H$-<!$NA`:n$r$9$k(B.
! 1551: % 0. ncone $B$,(B cone.fan $B$K$9$G$K$J$$$+D4$Y$k(B. $B$"$l$P(B, internal error.
! 1552: % 1. ncone markBorder ; ncone $B$NCf$N(B border $B>e$N(B facet $B$r(B mark
! 1553: % 2. cone.fan $B$NCf$N(B cone $B$H6&DL(B facet $B$,$J$$$+D4$Y(B (getCommonFacet),
! 1554: % $B$"$l$P$=$l$i$r(B mark $B$9$k(B.
! 1555: % global: cone.incidence $B$K(B $B6&DL(Bfacet $B$r;}$DAH$_$N>pJs$r2C$($k(B.
! 1556: % 3. ncone $B$r(B cone.fan $B$N:G8e$K2C$($k(B.
! 1557: % $B0J>e$NA`:n$r$^$H$a$?$b$N$,(B ncone updateFan
! 1558: %
! 1559: % getNextFlip $B$O(B cone.fan $B$NCf$+$i(B flip $B$7$F$J$$(B cone $B$H(B facet $B$NAH$rLa$9(B.
! 1560: % $B$J$1$l$P(B null $B$rLa$9(B. null $B$,La$l$P%W%m%0%i%`=*N;(B.
! 1561: %
! 1562: % getStargingCone $B$O7W;;$r=PH/$9$Y$-?75,$N(B cone $B$r7W;;$9$k(B. $BBg0hJQ?t(B cone.Lt, cone.W
! 1563: % $B$J$I$b$3$NCf$G@_Dj$9$k(B.
! 1564: % $BJQ?t%j%9%H(B, weight space $B$r@8@.$9$k4X?t(B, $BF~NOB?9`<0(B, weight $B$N8uJd(B $BEy$OBg0hJQ?t(B
! 1565: % $B$H$7$FF~NO$7$F$*$/(B.
! 1566: %
! 1567: % reduced gb $B$O(B $B4X?t(B input weight cone.gb reduced_G $B$G7W;;$9$k(B.
! 1568: %
! 1569: %
! 1570: % [ccone i] getNextCone ncone : flip $B$K$h$j<!$N(B cone $B$rF@$k(B.
! 1571: %
! 1572: % 1. clearGlobals ; $BF~NOBg0hJQ?t$N@_Dj(B.
! 1573: % 2. getStartingCone /ncone set
! 1574: % 3. { ncone updateFan
! 1575: % 4. getNextFlip /cone.nextflip set
! 1576: % 6. cone.nextflip isNull { exit } { } ifelse
! 1577: % 7. cone.nextflip getNextCone /ncone set
! 1578: % 8. } loop
! 1579: %
! 1580: %
! 1581: % -------------------------------------------------
! 1582: %
! 1583:
! 1584: %<
! 1585: % Usages: input weight cone.gb_Dh reduced_G
! 1586: % gb in h[1,1](D)
! 1587: %>
! 1588: /cone.gb_Dh {
! 1589: /arg2 set /arg1 set
! 1590: [/ff /ww /gg] pushVariables
! 1591: [
! 1592: /ff arg1 def
! 1593: /ww arg2 def
! 1594: [(AutoReduce) 1] system_variable
! 1595: [cone.vv ring_of_differential_operators
! 1596: [ww] weight_vector 0] define_ring
! 1597: [ff {toString .} map] groebner 0 get /gg set
! 1598: /cone.gb_Dh.g gg def
! 1599: /arg1 gg def
! 1600: ] pop
! 1601: popVariables
! 1602: arg1
! 1603: } def
! 1604:
! 1605: %<
! 1606: % Usages: cone.boundp
! 1607: %
! 1608: /cone.boundp {
! 1609: dup boundp 2 1 roll tag 0 eq not and
! 1610: } def
! 1611:
! 1612: %<
! 1613: % Usages: clearGlobals
! 1614: % cf. cone.boundp
! 1615: % polymake $B$r:FEY8F$V$?$a$K(B global $BJQ?t$r%/%j%"$9$k(B.
! 1616: % $B$^$@ESCf(B.
! 1617: %>
! 1618: /clearGlobals {
! 1619: /cone.W null def
! 1620: /cone.Wt null def
! 1621:
! 1622: /cone.cinit null def
! 1623: /cone.weightBorder null def
! 1624:
! 1625: } def
! 1626:
! 1627: %<
! 1628: % Usages: getStartingCone ncone
! 1629: % getStargingCone $B$O7W;;$r=PH/$9$Y$-?75,$N(B cone $B$r7W;;$9$k(B.
! 1630: % $B@_Dj$9$Y$-Bg0hJQ?t$O0J2<$r8+$h(B.
! 1631: %>
! 1632:
! 1633: /getStartingCone.test {
! 1634: %------------------Globals----------------------------------------
! 1635: % --------------- $BF~NO%G!<%?MQBg0hJQ?t$N@_Dj(B --------------------------
! 1636: %
! 1637: % cone.input : $BF~NOB?9`<07O(B
! 1638: /cone.input
! 1639: [(t1-x-y) (h*t2-x^2-y^2) (2*x*Dt2+h*Dt1+h*Dx) (2*y*Dt2+h*Dt1+h*Dy)]
! 1640: def
! 1641:
! 1642: % cone.vlist : $BA4JQ?t$N%j%9%H(B
! 1643: /cone.vlist [(t1) (t2) (x) (y) (Dt1) (Dt2) (Dx) (Dy) (h)] def
! 1644:
! 1645: % cone.vv : define_ring $B7A<0$NJQ?t%j%9%H(B.
! 1646: % t1,t2, x,y : t-space $B$N(B Grobner fan (local) $B$r5a$a$k(B.
! 1647: /cone.vv (t1,t2,x,y) def
! 1648:
! 1649: % cone.parametrizeWeightSpace : weight $B6u4V$r(B parametrize $B$9$k4X?t(B.
! 1650: % $BBg0hJQ?t(B cone.W , cone.Wpos $B$b$-$^$k(B.
! 1651: /cone.parametrizeWeightSpace {
! 1652: 4 2 parametrizeSmallFan
! 1653: } def
! 1654:
! 1655: % cone.w_start : weight$B6u4V$K$*$1$k(B weight $B$N=i4|CM(B.
! 1656: % $B$3$NCM$G(B max dim cone $B$,F@$i$l$J$$$H(B random weight $B$K$h$k(B $B%5!<%A$,;O$^$k(B.
! 1657: /cone.w_start
! 1658: [ 1 4 ]
! 1659: def
! 1660:
! 1661: % cone.gb : gb $B$r7W;;$9$k4X?t(B.
! 1662: /cone.gb {
! 1663: cone.gb_Dh
! 1664: } def
! 1665:
! 1666: %
! 1667: % ----------------- $B$*$o$j(B ---------------------------
! 1668: %
! 1669: } def % end of getStartingCone.test
! 1670:
! 1671: /getStartingCone {
! 1672: [/wv_start /w_start /reduced_G] pushVariables
! 1673: [
! 1674: % cone.n $B$O<+F0E*$K$-$a$i$l$k(B.
! 1675: % cone.n $B$O(B GB $B$r7W;;$9$k6u4V$N<!85(B.
! 1676: /cone.n cone.vlist length def
! 1677: %[1] cone.W, cone.Wpos $B$r5a$a$k(B. cone.m $B$O(B cone.W $B$h$j<+F0E*$K$-$^$k(B.
! 1678: % cone.m $B$O(B weight $B6u4V$N<+M3EY(B. cone.W $B$G<M1F$5$l$k@h$N<!85(B.
! 1679: /cone.W cone.boundp {
! 1680: (Skip cone.parametrizeWeightSpace. cf. clearGlobals) message
! 1681: } {
! 1682: cone.parametrizeWeightSpace
! 1683: } ifelse
! 1684: (parametrizing weight space: cone.W = ) messagen cone.W message
! 1685: /cone.Wt cone.W transpose def
! 1686: /cone.m cone.W length def
! 1687: % WeightBorder $B$N>r7oH=Dj(B facet $B$r@_Dj(B.
! 1688: /cone.weightBorder cone.boundp {
! 1689: (Skip setWeightBorder cf. clearGlobals) message
! 1690: } {
! 1691: setWeightBorder
! 1692: } ifelse
! 1693:
! 1694: %[2] weight vector wv_start $B$r@8@.$9$k(B.
! 1695: % wv_start $B$r@_Dj(B.
! 1696: cone.w_start tag 0 eq {
! 1697: % cone.w_start $B$,(B null $B$J$i(B random $B$K(B weight $B$r@_Dj(B.
! 1698: /cone.w_start cone.m cone_random_vec def
! 1699: } {
! 1700: cone.w_start length cone.m to_int32 eq {
! 1701: } {
! 1702: (Error: cone.w_start has wrong length.) error
! 1703: /cone.w_start cone.m cone_random_vec def
! 1704: } ifelse
! 1705: } ifelse
! 1706: /w_start cone.w_start cone.W mul def
! 1707:
! 1708: {
! 1709: cone.vlist w_start cone_wtowv /wv_start set
! 1710: (Trying a starting weight vector : ) messagen
! 1711: wv_start pmat
! 1712: %[3] reduced GB $B$N7W;;(B.
! 1713: cone.input wv_start cone.gb /reduced_G set
! 1714: (Reduced GB : ) message
! 1715: reduced_G pmat
! 1716:
! 1717: %[4] $B<M1F$7$F$+$i(B polytope $B$N%G!<%?$r7W;;(B.
! 1718: wv_start reduced_G coneEq /cone.g_ineq set
! 1719: cone.g_ineq cone.w_ineq join /cone.gw_ineq set
! 1720: cone.gw_ineq cone.Wt mul /cone.gw_ineq_projectedWt set % $B<M1F(B
! 1721: /cone.cinit cone.boundp {
! 1722: (Skipping cone.gw_ineq_projectedWt getConeInfo. cf. clearGlobals) message
! 1723: } {
! 1724: cone.gw_ineq_projectedWt getConeInfo /cone.cinit set
! 1725: } ifelse
! 1726:
! 1727: (cone.cinit is --- the first number is the dim of cone.) messagen
! 1728: cone.cinit 0 get pmat
! 1729: % Maximal dimensional cone $B$+$I$&$+$N8!::(B. $B8!::$K%Q%9$9$l$P(B loop $B$r(B exit
! 1730: % $B%Q%9$7$J$$>l9g(B w_start $B$r(B cone_random_vec $B$rMQ$$$FJQ99$9$k(B.
! 1731: cone.cinit 0 get 0 get to_int32 cone.m eq { exit }
! 1732: {
! 1733: (Failed to get the max dim cone. Updating the weight ...) messagen
! 1734: /w_start cone.m cone_random_vec cone.W mul def
! 1735: % cone.cinit $B$r:FEY7W;;$9$k$?$a$K(B clear $B$9$k(B.
! 1736: /cone.cinit null def
! 1737: } ifelse
! 1738: } loop
! 1739:
! 1740: (cone.m = ) messagen cone.m message
! 1741: (Suceeded to get the maximal dimensional startingCone.) message
! 1742:
! 1743: % Linearity subspace $B$N(B orth complement $B$X$N<M1F9TNs(B.
! 1744: % $BBg0hJQ?t(B cone.Lp, cone.Lpt $B$r@_Dj(B
! 1745: cone.cinit 0 get 1 get /cone.Lp set
! 1746: cone.Lp transpose /cone.Lpt set
! 1747: % Linearity subspace $B$N9TNs$r@_Dj(B.
! 1748: % $BBg0hJQ?t(B cone.L $B$r@_Dj(B
! 1749: cone.cinit 0 get 2 get /cone.L set
! 1750: % cone.d $B$O(B cone.W $B$*$h$S(B Linearity space $B$G3d$C$?8e(B, cone $B$r9M$($k$H$-$N<!85(B.
! 1751: % $BBg0hJQ?t(B cone.d $B$N@_Dj(B.
! 1752: /cone.d cone.Lp length def
! 1753:
! 1754: cone.m cone.d eq {
! 1755: (There is no linearity space) message
! 1756: } {
! 1757: (Dim of the linearity space is ) messagen cone.m cone.d sub message
! 1758: (cone.Lp = ) messagen cone.Lp pmat
! 1759: } ifelse
! 1760:
! 1761: %[5] cone.g_ineq * cone.Wt * cone.Lpt
! 1762: % cone.w_ineq * cone.Wt * cone.Lpt
! 1763: % $B$G@)Ls$r(B d $B<!85%Y%/%H%k$KJQ49(B.
! 1764: % W (R^m) $B6u4V$NITEy<0@)Ls$r(B L' (R^d) $B6u4V$X<M1F(B
! 1765: % cone.gw_ineq_projectedWtLpt
! 1766: % = cone.g_ineq*cone.Wt*cone.Lpt \/ cone.w_ineq*coneWt*cone.Lpt
! 1767:
! 1768: /cone.gw_ineq_projectedWtLpt
! 1769: cone.gw_ineq_projectedWt cone.Lpt mul
! 1770: def
! 1771:
! 1772: cone.m cone.d eq {
! 1773: /cone.cinit.d cone.cinit def
! 1774: } {
! 1775: % cone.m > cone.d $B$J$i$P(B, $B:FEY(B cone $B$N7W;;$,I,MW(B.
! 1776: % R^d $B$N(B cone $B$O(B cone.cinit.d $B$XF~$l$k(B.
! 1777: cone.gw_ineq_projectedWtLpt getConeInfo /cone.cinit.d set
! 1778: } ifelse
! 1779:
! 1780: cone.cinit.d 1 get newCone /cone.startingCone set
! 1781:
! 1782: (cone.startingCone is ) message
! 1783: cone.startingCone message
! 1784: ] pop
! 1785: popVariables
! 1786: cone.startingCone
! 1787: } def
! 1788:
! 1789: %
! 1790: % data/test9.sm1 $B$N(B test9 1-simplex X 2-simplex
! 1791: %
! 1792: % data/test10.sm1 1-simplex X 3-simplex
! 1793: % data/test11.sm1 SST, p.59
! 1794: %
! 1795: % $B$$$h$$$h(B, cone enumeration $B$N%W%m%0%i%`=q$-3+;O(B
! 1796: %
! 1797:
! 1798: %<
! 1799: % Usages: cone markBorder
! 1800: % cone->facets[i] $B$,(B weight space $B$N(B border $B$K$"$k$H$-(B
! 1801: % cone->flipped[i] = 2 $B$H$9$k(B.
! 1802: % $B$3$l$r(B cone $B$N$9$Y$F$N(B facet $B$KBP$7$F7W;;(B.
! 1803: %>
! 1804: /markBorder {
! 1805: /arg1 set
! 1806: [/cone /facets_t /flipped_t /kk] pushVariables
! 1807: [
! 1808: /cone arg1 def
! 1809: cone (facets) getNode 2 get /facets_t set
! 1810: cone (flipped) getNode 2 get /flipped_t set
! 1811: 0 1 flipped_t length 1 sub {
! 1812: /kk set
! 1813: flipped_t kk get (0).. eq {
! 1814: cone kk isOnWeightBorder {
! 1815: % Border $B$N>e$K$"$k$N$G(B flip $B:Q$N%^!<%/$r$D$1$k(B.
! 1816: flipped_t kk (2).. put
! 1817: } { } ifelse
! 1818: } { } ifelse
! 1819: } for
! 1820: ] pop
! 1821: popVariables
! 1822: } def
! 1823:
! 1824: %<
! 1825: % Usages: ncone updateFan
! 1826: % $B%0%m!<%P%kJQ?t(B cone.fan $B$r99?7$9$k(B.
! 1827: %>
! 1828: %
! 1829: % updateFan $B$N(B debug $B$O(B data/test8 $B$G$H$j$"$($:$d$k(B.
! 1830: % test8 /ncone set $B$r<B9T$7$F$+$i(B ncone updateFan
! 1831:
! 1832: % global: cone.fan
! 1833: /cone.fan [ ] def
! 1834: % global: cone.incidence
! 1835: /cone.incidence [ ] def
! 1836:
! 1837: /updateFan {
! 1838: /arg1 set
! 1839: [/ncone /kk /cfacet /ii /jj /tcone /flipped_t] pushVariables
! 1840: [
! 1841: /ncone arg1 def
! 1842: /cone.fan.n cone.fan length def
! 1843: % 0. ncone $B$,(B cone.fan $B$K$9$G$K$"$l$P%(%i!<(B
! 1844: 0 1 cone.fan.n 1 sub {
! 1845: /kk set
! 1846: ncone cone.fan kk get isSameCone {
! 1847: (Internal error updateFan: ncone is already in cone.fan) error
! 1848: } { } ifelse
! 1849: } for
! 1850:
! 1851: % 1. ncone $B$NCf$N(B border $B>e$N(B facet $B$r$9$Y$F(B mark.
! 1852: ncone markBorder
! 1853:
! 1854: % 2. ncone /\ cone.fan[kk] $B$,$"$k$+D4$Y$k(B. $B$"$l$P(B Mark $B$9$k(B. incidence graph $B$K2C$($k(B
! 1855: 0 1 cone.fan.n 1 sub {
! 1856: /kk set
! 1857: ncone cone.fan kk get getCommonFacet /cfacet set
! 1858: cfacet 0 get
! 1859: {
! 1860: % $B6&DL(B facet $B$,$"$k>l9g(B. [[cone$BHV9f(B face$BHV9f(B] [cone$BHV9f(B face$BHV9f(B]] $B$N7A<0$G3JG<(B.
! 1861: /ii cfacet 1 get 0 get def
! 1862: /jj cfacet 2 get 0 get def
! 1863: cone.incidence [ [[cone.fan.n ii] [kk jj]] ] join /cone.incidence set
! 1864: % flipped $B$r(B mark $B$9$k(B.
! 1865: ncone ii markFlipped
! 1866: cone.fan kk get /tcone set
! 1867: tcone jj markFlipped
! 1868: } { } ifelse
! 1869: } for
! 1870: % 3. ncone $B$r2C$($k(B.
! 1871: cone.fan [ncone] join /cone.fan set
! 1872: ] pop
! 1873: popVariables
! 1874: } def
! 1875:
! 1876: %<
! 1877: % usages: getNextFlip [cone, k]
! 1878: % cone.fan $B$r8!:w$7$F(B $B$^$@(B flip $B$7$F$J$$(B cone $B$H(B facet $B$NAH$rLa$9(B.
! 1879: % $B$b$&$J$$$H$-$K$O(B null $B$rLa$9(B.
! 1880: %>
! 1881: /getNextFlip {
! 1882: [/tcone /ans /ii ] pushVariables
! 1883: [
! 1884: /ans null def
! 1885: 0 1 cone.fan length 1 sub {
! 1886: /ii set
! 1887: cone.fan ii get /tcone set
! 1888: tcone getNextFacet /ans set
! 1889: ans tag 0 eq { } { exit } ifelse
! 1890: } for
! 1891: ans tag 0 eq { /arg1 null def }
! 1892: { /arg1 [tcone ans] def } ifelse
! 1893: ] pop
! 1894: popVariables
! 1895: arg1
! 1896: } def
! 1897:
! 1898: % global variable : cone.epsilon , cone.epsilon.limit
! 1899: % flip $B$N;~$N(B epsilon
! 1900: /cone.epsilon (1).. (10).. div def
! 1901: /cone.epsilon.limit (1).. (100).. div def
! 1902:
! 1903: %<
! 1904: % Usages: result_getNextFlip getNextCone ncone
! 1905: % flip $B$7$F?7$7$$(B ncone $B$rF@$k(B.
! 1906: %>
! 1907: /getNextCone {
! 1908: /arg1 set
! 1909: [/ncone /ccone /kk /w /next_weight_w_wv] pushVariables
! 1910: [
! 1911: /ccone arg1 def
! 1912: /ncone null def
! 1913: /kk ccone 1 get def
! 1914: ccone 0 get /ccone set
! 1915: {
! 1916: ccone tag 0 eq { exit } { } ifelse
! 1917:
! 1918: % ccone $B$N(B kk $BHVL\$N(B facet $B$K$D$$$F(B flip $B$9$k(B.
! 1919: ccone kk cone.epsilon flipWeight /w set
! 1920: (Trying new weight is ) messagen w message
! 1921: w liftWeight /next_weight_w_wv set
! 1922: (Trying new weight [w,wv] is ) messagen next_weight_w_wv message
! 1923:
! 1924: cone.input next_weight_w_wv 1 get cone.gb /cone.cgb set
! 1925: next_weight_w_wv 1 get cone.cgb coneEq /cone.g_ineq set
! 1926: cone.g_ineq cone.w_ineq join cone.Wt mul cone.Lpt mul
! 1927: pruneZeroVector /cone.gw_ineq_projectedWtLpt set
! 1928:
! 1929: (cone.gw_ineq_projectedWtLpt is obtained.) message
! 1930:
! 1931: cone.gw_ineq_projectedWtLpt getConeInfo /cone.nextConeInfo set
! 1932: % $B<!85$rD4$Y$k(B. $B$@$a$J$i(B retry
! 1933: cone.nextConeInfo 0 get 0 get to_int32 cone.d eq {
! 1934: cone.nextConeInfo 1 get newCone /ncone set
! 1935: ccone ncone getCommonFacet 0 get {
! 1936: (Flip succeeded.) message
! 1937: exit
! 1938: } { } ifelse
! 1939: } { } ifelse
! 1940: % common face $B$,$J$1$l$P(B $B$d$O$j(B epsilon $B$r>.$5$/(B.
! 1941: cone.nextConeInfo 0 get 0 get to_int32 cone.d eq {
! 1942: (ccone and ncone do not have a common facet.) message
! 1943: } {
! 1944: (ncone is not maximal dimensional. ) message
! 1945: } ifelse
! 1946: (Decreasing epsilon to ) messagen
! 1947: cone.epsilon (1).. (2).. div mul /cone.epsilon set
! 1948: cone.epsilon cone.epsilon.limit sub numerator (0).. lt {
! 1949: (Too small cone.epsilon ) error
! 1950: } { } ifelse
! 1951: cone.epsilon message
! 1952: } loop
! 1953: /arg1 ncone def
! 1954: ] pop
! 1955: popVariables
! 1956: arg1
! 1957: } def
! 1958:
! 1959: %<
! 1960: % Usages: set globals and getGrobnerFan
! 1961: % cf. clearGlobals
! 1962: % getStartingCone $B$9$k$H(B weightSpace $B$H$+$N7W;;$,$G$-$k(B. isOnWeightBorder $B$,(B
! 1963: % $B7h$a$i$l$k(B.
! 1964: %>
! 1965: % $B$H$j$"$($:(B (data/test8.sm1) run $B$7$F$+$i(B getGrobnerFan
! 1966: /getGrobnerFan {
! 1967: getStartingCone /cone.ncone set
! 1968: {
! 1969: cone.ncone updateFan
! 1970: ( ) message
! 1971: (----------------------------------------------------------) message
! 1972: (getGrobnerFan #cone.fan=) messagen cone.fan length message
! 1973: cone.ncone /cone.ccone set
! 1974: getNextFlip /cone.nextflip set
! 1975: cone.nextflip tag 0 eq { exit } { } ifelse
! 1976: cone.nextflip getNextCone /cone.ncone set
! 1977: } loop
! 1978: (Construction is completed. See cone.fan and cone.incidence.) message
! 1979: } def
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to gfan.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc