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