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