Annotation of OpenXM/src/kan96xx/Doc/gfan.sm1, Revision 1.3
1.3 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.2 2004/09/09 08:50:12 takayama Exp $
1.1 takayama 2: % cp cone.sm1 $OpenXM_HOME/src/kan96xx/Doc/gfan.sm1
1.3 ! takayama 3: % $Id: cone.sm1,v 1.42 2004/09/14 08:28:50 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:
523: % [2 0] lcm $B$O(B 0 $B$r$b$I$9$,$$$$$+(B? --> OK.
524:
525: %<
526: % Usages: mm addZeroForPolymake
527: % $B0J2<$NFs$D$N4X?t$O(B, toQuotientSpace $B$K$bMxMQ(B.
528: % Polymake INEQUALITIES $BMQ$K(B 0 $B$r;O$a$KB-$9(B.
529: % $BF~NO$O(B $B%j%9%H$N%j%9%H(B
530: % [[1,2], [3,4],[5,6]] --> [[0,1,2],[0,3,4],[0,5,6]]
531: %>
532: /addZeroForPolymake {
533: /arg1 set
534: [/mm /rr] pushVariables
535: [
536: /mm arg1 def
537: mm to_univNum /mm set
538: mm { [(0)..] 2 1 roll join } map /mm set
539: /arg1 mm def
540: ] pop
541: popVariables
542: arg1
543: } def
544:
545: %<
546: % Usages: mm cone.appendZero
547: %>
548: /cone.appendZero {
549: /arg1 set
550: [/mm /rr] pushVariables
551: [
552: /mm arg1 def
553: mm to_univNum /mm set
554: mm { [(0)..] join } map /mm set
555: /arg1 mm def
556: ] pop
557: popVariables
558: arg1
559: } def
560:
561: %<
562: % Usages: mm removeFirstFromPolymake
563: % $B;O$a$N(B 0 $B$r<h$j=|$/(B.
564: % $BF~NO$O(B $B%j%9%H$N%j%9%H(B
565: % [[0,1,2],[0,3,4],[0,5,6]] ---> [[1,2], [3,4],[5,6]]
566: %>
567: /removeFirstFromPolymake {
568: /arg1 set
569: [/mm /rr] pushVariables
570: [
571: /mm arg1 def
572: mm to_univNum /mm set
573: mm {rest} map /mm set
574: /arg1 mm def
575: ] pop
576: popVariables
577: arg1
578: } def
579:
580: %<
581: % Usages: mm genUnit
582: % [1,0,0,...] $B$r2C$($k$?$a$K@8@.(B.
583: % [[0,1,2], [0,3,4],[0,5,6]]--> [1,0,0]
584: %>
585: /genUnit {
586: /arg1 set
587: [/mm /rr /i] pushVariables
588: [
589: /mm arg1 def
590: mm 0 get length newVector /rr set
591: rr null_to_zero /rr set
592: rr 0 (1).. put
593: /arg1 rr def
594: ] pop
595: popVariables
596: arg1
597: } def
598:
599: %<
600: % Usages: mm genUnitMatrix
601: % [[0,1,2], [0,3,4],[0,5,6]]--> [[1,0,0],[0,1,0],[0,0,1]]
602: %>
603: /genUnitMatrix {
604: /arg1 set
605: [/mm /rr /nn /i] pushVariables
606: [
607: /mm arg1 def
608: mm 0 get length /nn set
609: [
610: 0 1 nn 1 sub {
611: /i set
612: nn newVector null_to_zero /mm set
613: mm i (1).. put
614: mm
615: } for
616: ]
617: /arg1 set
618: ] pop
619: popVariables
620: arg1
621: } def
622:
623: %<
624: %%note: 2004, 8/29 (sun)
625: % toQuotientSpace : Linearity space $B$G3d$k(B.
626: % Usages: ineq mm toQuotientSpace
627: % $BF~NO$O(B coneEq $B$N=PNO(B ineq
628: % $B$*$h$S(B doPolymake --> getLinearitySubspace ==> L
629: % [L,[1,0,0,...]] asir_matrix_kernel removeFirstFromPolymake $B$GF@$i$l$?(B mm
630: % $B=PNO$+$i(B 0 $B%Y%/%H%k$O:o=|(B.
631: % $B=PNO$b(B coneEq $B7A<0(B. $BFC$K(B polymake $BMQ$K(B 0 $B$r2C$($k$N$,I,MW(B.
632: % ref: getUnit, removeFirstFromPolymake, addZeroForPolymake,
633: % asir_matrix_kernel, getLinearitySubspace
634: %>
635: /toQuotientSpace {
636: /arg2 set
637: /arg1 set
638: [/ineq /mm /rr] pushVariables
639: [
640: /ineq arg1 def
641: /mm arg2 def
642:
643: ineq mm transpose mul /rr set
644:
645: /arg1 rr def
646: ] pop
647: popVariables
648: arg1
649: } def
650:
651: /test5.data
652: $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]]))$
653: def
654: %<
655: % Usages: test5
656: %% getConeInfo $B$rJQ99$9$l$P(B polymake $B$r8F$P$:$K%F%9%H$G$-$k(B.
657: %>
658: /test5 {
659: % test3b $B$h$j(B
660: /ww [(Dx) 1 (Dy) 2] def
661: % /ww [(x) 1 (y) -2 (Dx) 3 (Dy) 6] def
662: [(x,y) ring_of_differential_operators
663: [ww] weight_vector
664: 0] define_ring
665: [ (x Dx + y Dy -1).
666: (y^2 Dy^2 + 2 + y Dy ).
667: ] /gg set
668: gg {homogenize} map /gg set
669: [(AutoReduce) 1] system_variable
670: [gg] groebner 0 get /gg set
671: ww message
672:
673: ww gg coneEq getConeInfo /rr set
674: (Type in rr 0 get :: ) message
675: } def
676: %[5, [[1,0,1,0,-2],[0,1,0,1,-2]], $NOT__POINTED$ ]
677: % $B$3$N>l9g$O(B 2 $B<!85$^$GMn$9$H(B pointed cone $B$K$J$k(B.
678: % coneEq mmc transpose $B$r$b$H$K(B FACETS $B$r7W;;$9$l$P$h$$(B.
679:
680: %<
681: % Usage: ceq getConeInfo
682: % 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.
683: % 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.
684: % Grobner cone $B$N(B $B<!85(B cdim (DIM), $BJd6u4V(B (linearity space ) $B$X$N9TNs(B mmc
685: % linearity space $B<+BN(B, pointed or not__pointed
686: % $B$D$^$j(B [cdim, L', L, PointedQ]
687: % $B$r7W;;$7$FLa$9(B. (polymake $B7A<0$NM>J,$JItJ,$J$7(B)
688: % polymake $BI,MW(B.
689: % ref: coneEq
690: % Global:
691: % cone.getConeInfo.rr0, cone.getConeInfo.rr1 $B$K(B polymake $B$h$j$NLa$jCM$,$O$$$k(B.
692: %>
693: /getConeInfo {
694: /arg1 set
695: [/ww /g /ceq /ceq2 /cdim /mmc /mmL /rr /ineq /ppt] pushVariables
696: [
697: /ceq arg1 def
698: ceq pruneZeroVector /ceq set
699: ceq genPo2 /ceq2 set
700: % ceq2 $B$O(B polymake.data(polymake.INEQUALITIES(...)) $B7A<0(B
701: % polymake $B$G(B ceq2 $B$N<!85$N7W;;(B.
702: /getConeInfo.ceq ceq def /getConeInfo.ceq2 ceq2 def
703:
704: cone.debug { (Calling polymake DIM.) message } { } ifelse
705: [(DIM) ceq2] doPolymake 1 get /rr set
706: cone.debug {(Done.) message } { } ifelse
707: % test5 $B$K$O<!$N%3%a%s%H$H$j$5$k(B. $B>e$N9T$r%3%a%s%H%"%&%H(B.
708: % test5.data tfbToTree /rr set
709: /cone.getConeInfo.rr0 rr def
710:
711: rr (DIM) getNode /cdim set
712: cdim 2 get 0 get 0 get 0 get to_univNum /cdim set
713: % polymake $B$N(B DIM $B$O0l$D>.$5$$$N$G(B 1 $BB-$9(B.
714: cdim (1).. add /cdim set
715:
716: rr (FACETS) getNode tag 0 eq {
717: % FACETS $B$r;}$C$F$$$J$$$J$i:FEY7W;;$9$k(B.
718: % POINTED, NOT__POINTED $B$bF@$i$l$k(B
719: cone.debug { (Calling polymake FACETS.) message } { } ifelse
720: [(FACETS) ceq2] doPolymake 1 get /rr set
721: cone.debug { (Done.) message } { } ifelse
722: } { } ifelse
723:
724: rr (VERTICES) getNode tag 0 eq {
725: (internal error: VERTICES is not found.) error
726: } { } ifelse
727:
728: /cone.getConeInfo.rr1 rr def
729:
730: rr (NOT__POINTED) getNode tag 0 eq {
731: % cone $B$,(B pointed $B$N;~$O(B mmc $B$OC10L9TNs(B. genUnitMatrix $B$r;H$&(B.
732: % VERTICES $B$h$j0l$D>.$5$$%5%$%:(B.
733: /mmc
734: [ rr (VERTICES) getNode 2 get 0 get 0 get rest]
735: genUnitMatrix
736: def
737: /mmL [ ] def
738: /ppt (POINTED) def
739: } {
740: % pointed $B$G$J$$>l9g(B,
741: % cone $B$N@~7AItJ,6u4V$r7W;;(B.
742: rr getLinearitySubspace /mmL set
743: [mmL genUnit] mmL join /mmc set % [1,0,0,...] $B$rB-$9(B.
744: mmc asir_matrix_kernel /mmc set % $BJd6u4V(B
745: mmc removeFirstFromPolymake /mmc set % $B$R$H$D>.$5$$%5%$%:$K(B.
746:
747: [mmL genUnit] mmL join asir_matrix_image
748: removeFirstFromPolymake /mmL set
749: mmL asir_matrix_image /mmL set % Linearity space $B$r5a$a$k(B. rm 0vector
750: /ppt (NOT__POINTED) def
751: } ifelse
752: /arg1 [[cdim mmc mmL ppt] rr] def
753: ] pop
754: popVariables
755: arg1
756: } def
757:
758:
759: /test.put {
760: /dog [(dog) [[(legs) 4] ] [1 2 3 ]] [(class) (tree)] dc def
761: /man [(man) [[(legs) 2] ] [1 2 3 ]] [(class) (tree)] dc def
762: /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def
763: /fan [ma 1 copy] def
764: ma (dog) getNode /dd set
765: dd 2 get /dd2 set
766: dd2 1 0 put
767: ma message
768:
769: fan message
770: } def
771:
772: /test6.data
773: $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])]))$
774: def
775: % tfbToTree
776:
777: /arrayToTree { [(class) (tree)] dc } def
778:
779: %<
780: % polymake $B$h$jF@$i$l$?(B TreeObject $B$+$i(B TreeObject cone $B$r@8@.$9$k(B.
781: % Usages: test6.data tfbToTree newCone $B$GF0:n%F%9%H(B
782: %>
783: /test6 {
784: test6.data tfbToTree /rr set
785: rr newCone /rr2 set
786: } def
787:
788: %<
789: % Usages: doPolymakeObj newCone
790: %>
791: /newCone {
792: /arg1 set
793: [/polydata /cone /facets /vertices /flipped /ineq
794: /facetsv /rr] pushVariables
795: [
796: /polydata arg1 def
797: polydata (FACETS) getNode tag 0 eq {
798: (newCone : no FACETS data.) error
799: } { } ifelse
800: % facets $B$OM-M}?t$N>l9g@55,2=$9$k(B. data/test11 $B$G(B $BM-M}?t$G$k(B.
801: polydata (FACETS) getNode 2 get 0 get to_univNum
802: { nnormalize_vec} map /facets set
803: [[ ] ] facets join shell rest removeFirstFromPolymake /facets set
1.2 takayama 804: facets length 0 eq
805: {(Internal error. Facet data is not obtained. See OpenXM_tmp.) error} { } ifelse
1.1 takayama 806: % vertices $B$O(B cone $B$N>e$K$"$k$N$G@0?tG\(B OK. $B@55,$+$9$k(B.
807: polydata (VERTICES) getNode 2 get 0 get to_univNum
808: { nnormalize_vec} map /vertices set
809: [[ ] ] vertices join shell rest removeFirstFromPolymake /vertices set
810: % inequalities $B$OM-M}?t$N>l9g@55,2=$9$k(B.
811: polydata (INEQUALITIES) getNode 2 get 0 get to_univNum
812: { nnormalize_vec } map /ineq set
813: [[ ] ] ineq join shell rest removeFirstFromPolymake /ineq set
814:
815: [(cone) [ ]
816: [
817: [(facets) [ ] facets] arrayToTree
818: [(flipped) [ ] facets length newVector null_to_zero] arrayToTree
819: [(facetsv) [ ] facets vertices newCone_facetsv] arrayToTree
820: [(vertices) [ ] vertices] arrayToTree
821: [(inequalities) [ ] ineq] arrayToTree
822: ]
823: ] arrayToTree /cone set
824: /arg1 cone def
825: ] pop
826: popVariables
827: arg1
828: } def
829:
830: %<
831: % Usages: newCone_facetv
832: % facet vertices newCone_facetv
833: % facet $B$K$N$C$F$$$k(B vertices $B$r$9$Y$FNs5s(B.
834: %>
835: /newCone_facetv {
836: /arg2 set
837: /arg1 set
838: [/facet /vertices] pushVariables
839: [
840: /facet arg1 def /vertices arg2 def
841: [
842: 0 1 vertices length 1 sub {
843: /ii set
844: facet vertices ii get mul isZero
845: { vertices ii get } { } ifelse
846: } for
847: ]
848: /arg1 set
849: ] pop
850: popVariables
851: arg1
852: } def
853:
854: %<
855: % Usages: newCone_facetsv
856: % facets vertices newCone_facetv
857: % facets $B$K$N$C$F$$$k(B vertices $B$r$9$Y$FNs5s(B. $B%j%9%H$r:n$k(B.
858: %>
859: /newCone_facetsv {
860: /arg2 set
861: /arg1 set
862: [/facets /vertices] pushVariables
863: [
864: /facets arg1 def /vertices arg2 def
865: facets { vertices newCone_facetv } map
866: /arg1 set
867: ] pop
868: popVariables
869: arg1
870: } def
871:
872: %<
1.2 takayama 873: % Usages: [gb weight] newConeGB
874: % gb $B$H(B weight $B$r(B tree $B7A<0$K$7$F3JG<$9$k(B.
875: %>
876: /newConeGB {
877: /arg1 set
878: [/gbdata /gg /ww /rr] pushVariables
879: [
880: /gbdata arg1 def
881: % gb
882: gbdata 0 get /gg set
883: % weight
884: gbdata 1 get /ww set
885: %
886: [(coneGB) [ ]
887: [
888: [(grobnerBasis) [ ] gg] arrayToTree
889: [(weight) [ ] [ww]] arrayToTree
890: [(initial) [ ] gg { ww 2 get weightv init } map ] arrayToTree
891: ]
892: ] arrayToTree /rr set
893: /arg1 rr def
894: ] pop
895: popVariables
896: arg1
897: } def
898:
899: %<
1.1 takayama 900: % Usages: cone_random
901: %>
902: /cone_random.start (2).. def
903: /cone_random {
904: [(tdiv_qr)
905: cone_random.start (1103515245).. mul
906: (12345).. add
907:
908: (2147483646)..
909: ] mpzext 1 get /cone_random.start set
910: cone_random.start
911: } def
912:
913: /cone_random.limit 40 def
914: /cone_random_vec {
915: /arg1 set
916: [/nn /rr] pushVariables
917: [
918: /nn arg1 def
919: [
920: 0 1 nn 1 sub {
921: pop
922: [(tdiv_qr) cone_random cone_random.limit] mpzext 1 get
923: } for
924: ] /arg1 set
925: ] pop
926: popVariables
927: arg1
928: } def
929:
930: %<
931: % Usages: getNewRandomWeight
932: %% 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.
933: %% h, H $B$N=hM}$bI,MW(B.
934: %% $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?
935: %>
936: /getNewRandomWeight {
937: /arg1 set
938: [/vv /vvd /rr] pushVariables
939: [
940: /vv arg1 def
941: vv { (D) 2 1 roll 2 cat_n } map /vvd set
942: ] pop
943: popVariables
944: arg1
945: } def
946:
947: % test7 : univNum $B$N(B weight $B$,@5$7$/G'<1$5$l$k$+$N%F%9%H(B
948: % aux-cone.sm1
949:
950: %<
951: % Usages: n d coneEqForSmallFan.2 (cone.type 2 $B@lMQ(B: x,y,Dx,Dy,h)
952: % 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.
953: % $B$O$8$a$+$i(B d $B8D$NJQ?t(B.
954: % 4, 2 , s,t,x,y $B$J$i(B weight $B$O(B s,t,Ds,Dt $B$N$_(B.
955: % u_i + v_i >= 0 , u_i = v_i = 0.
956: % homog $BJQ?t$N>r7o(B u_i+v_i >= t, i.e, -t >= 0 $B$bF~$l$k(B.
957: % coneEq $B$N7k2L$H(B coneEqForSmallFan.2 $B$N7k2L$r(B join $B$7$F(B
958: % getConeInfo or newCone
959: % note-cone.sm1 2004.8.31 $B$r8+$h(B. w_ineq $B$"$?$j(B.
960: % cone.local $B$,@_Dj$5$l$F$$$k$H(B u_i <= 0 $B$b>r7o$KF~$k(B.
961: %>
962: /coneEqForSmallFan.2 {
963: /arg2 set
964: /arg1 set
965: [/n /d /nn /dd /ii /tt] pushVariables
966: [
967: /n arg1 def
968: /d arg2 def
969: n to_int32 /n set
970: d to_int32 /d set
971: /dd n d add def
972: /nn n n add def
973:
974: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i = 0
975: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
976: % -t >= 0
977: [
978: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
979: d 1 n 1 sub {
980: /ii set
981: % [ 0,0, ..., 0,1,0,... ; 0] $B$r@8@.(B
982: nn 1 add newVector null_to_zero /tt set
983: tt ii (1).. put
984: tt
985: % [ 0,0, ..., 0,-1,0,... ; 0] $B$r@8@.(B
986: nn 1 add newVector null_to_zero /tt set
987: tt ii (-1).. put
988: tt
989: } for
990: dd 1 nn 1 sub {
991: /ii set
992: nn 1 add newVector null_to_zero /tt set
993: tt ii (1).. put
994: tt
995: nn 1 add newVector null_to_zero /tt set
996: tt ii (-1).. put
997: tt
998: } for
999:
1000: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i = 0
1001: 0 1 d 1 sub {
1002: /ii set
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: nn 1 add newVector null_to_zero /tt set
1009: tt ii (-1).. put
1010: tt ii n add (-1).. put
1011: tt
1012:
1013: } for
1014:
1015: % -t >= 0
1016: cone.h0 {
1017: % t = 0
1018: nn 1 add newVector null_to_zero /tt set
1019: tt nn (1).. put
1020: tt
1021: nn 1 add newVector null_to_zero /tt set
1022: tt nn (-1).. put
1023: tt
1024: }
1025: {
1026: % -t >= 0
1027: nn 1 add newVector null_to_zero /tt set
1028: tt nn (-1).. put
1029: tt
1030: } ifelse
1031:
1032: % cone.local $B$,(B 1 $B$N;~(B
1033: % 0 ~ d-1 $B$G$O(B -u_i >= 0
1034: cone.local {
1035: 0 1 d 1 sub {
1036: /ii set
1037: nn 1 add newVector null_to_zero /tt set
1038: tt ii (-1).. put
1039: tt
1040: } for
1041: } { } ifelse
1042: ] /rr set
1043: /arg1 rr to_univNum def
1044: ] pop
1045: popVariables
1046: arg1
1047: } def
1048:
1049: %<
1050: % Usages: n d coneEqForSmallFan.1 (cone.type 1 $B@lMQ(B: x,y,Dx,Dy,h,H)
1051: % cone.type 2 $B$G$O(B x,y,Dx,Dy,h
1052: % coneEqForSmallFan.2 $B$N7k2L$rMQ$$$F@8@.(B.
1053: % H $B$N>r7o$r2C$($k(B.
1054: %>
1055: /coneEqForSmallFan.1 {
1056: /arg2 set
1057: /arg1 set
1058: [/n /d /i /j /rr /tt /tt2] pushVariables
1059: [
1060: /n arg1 def /d arg2 def
1061: n d coneEqForSmallFan.2 /rr set
1062: rr cone.appendZero /rr set
1063: % H $BMQ$N(B 0 $B$r2C$($k(B.
1064: % $B$H$j$"$($:(B t' = 0 $B$G$-$a$&$A(B.
1065: cone.h0 { } { (cone.h0 = 0 has not yet been implemented.) error } ifelse
1066: n 2 mul 2 add newVector null_to_zero /tt set
1067: tt n 2 mul 2 add 1 sub (-1).. put
1068: n 2 mul 2 add newVector null_to_zero /tt2 set
1069: tt2 n 2 mul 2 add 1 sub (1).. put
1070: rr [tt tt2] join /rr set
1071: /arg1 rr to_univNum def
1072: ] pop
1073: popVariables
1074: arg1
1075: } def
1076:
1077: %<
1078: % Usages: vv ineq toQuotientCone
1079: % weight space $B$N(B $B%Q%i%a!<%?$D$1$N$?$a$K;H$&(B.
1080: % cone.V $B$r5a$a$?$$(B. vv $B$O(B doPolymakeObj (VERTICES) getNode 2 get 0 get $B$GF@$k(B.
1081: % vertices $B$N(B non-negative combination $B$,(B cone.
1082: % vertice cone.w_ineq isInLinearSubspace $B$J$i<h$j=|$/(B.
1083: % $B$D$^$j(B vertice*cone.w_ineq = 0 $B$J$i<h$j=|$/(B.
1084: %
1085: % $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)
1086: % cone.w_cone 1 get (VERTICES) getNode :: $B$HHf3S$;$h(B.
1087: % $B$3$N4X?t$r8F$s$G(B cone.W $B$r:n$k$N$OITMW$+$b(B.
1088: %
1089: % Example: cf. parametrizeSmallFan
1090: % 4 2 coneEqForSmallFan.2 /cone.w_ineq set cone.w_ineq getConeInfo /rr set
1091: % rr 1 get (VERTICES) getNode 2 get 0 get removeFirstFromPolymake /vv set
1092: % vv cone.w_ineq toQuotientCone pmat
1093: %>
1094: /toQuotientCone {
1095: /arg2 set /arg1 set
1096: [/vv /ineq /rr] pushVariables
1097: [
1098: /vv arg1 def /ineq arg2 def
1099: vv {
1100: dup
1101: ineq isInLinearSpace 1 eq { pop }
1102: { } ifelse
1103: } map /arg1 set
1104: ] pop
1105: popVariables
1106: arg1
1107: } def
1108:
1109: %<
1110: % Usages: n d parametrizeSmallFan
1111: % n : x $BJQ?t$N?t(B.
1112: % d : 0 $B$K$7$J$$(B weight $B$N?t(B.
1113: % $B<!$NBg0hJQ?t$b@_Dj$5$l$k(B.
1114: % cone.W : weight $B$r%Q%i%a!<%?$E$1$9$k%Y%/%H%k$NAH(B.
1115: % 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,
1116: % i $B$,(B Wpos ~ $B$NHO0O$N$H$-(B V[i] $B$X$O(B Z $B$N85$r3]$1;;$7$F$h$$(B.
1117: % cone.w_ineq : weight space $B$NITEy<0@)Ls(B. $B0J8e$N7W;;$G>o$KIU2C$9$k(B.
1118: % cone.w_cone : w_ineq $B$r(B polymake $B$G(B getConeInfo $B$7$?7k2L(B.
1119: % Example: /cone.local 1 def ; 4 2 parametrizeSmallFan pmat
1120: % Example: /cone.local 0 def ; 4 2 parametrizeSmallFan pmat
1121: %>
1122: /parametrizeSmallFan {
1123: /arg2 set /arg1 set
1124: [/n /d /vv /coneray] pushVariables
1125: [
1126: /n arg1 def /d arg2 def
1127: {
1128: cone.type 1 eq {
1129: n d coneEqForSmallFan.1 /cone.w_ineq set
1130: exit
1131: } { } ifelse
1132: cone.type 2 eq {
1133: n d coneEqForSmallFan.2 /cone.w_ineq set
1134: exit
1135: } { } ifelse
1136: (This cone.type has not yet been implemented.) error
1137: } loop
1138: cone.w_ineq getConeInfo /cone.w_cone set
1139: cone.w_cone 1 get (VERTICES) getNode 2 get 0 get
1140: removeFirstFromPolymake /vv set
1141:
1142: vv cone.w_ineq toQuotientCone /coneray set
1143: coneray length /cone.Wpos set
1144:
1145: coneray cone.w_cone 0 get 2 get join /cone.W set
1146: /arg1 cone.W def
1147: ] pop
1148: popVariables
1149: arg1
1150: } def
1151:
1152: %<
1153: % Usages: n d coneEqForTotalFan.2 (cone.type 2 $B@lMQ(B: x,y,Dx,Dy,h)
1154: % n $BJQ?t$N?t(B,
1155: % d 0 $B$K$7$J$$JQ?t(B.
1156: % u_i + v_i >= 0 ,
1157: % homog $BJQ?t$N>r7o(B u_i+v_i >= 0, t = 0 $B$bF~$l$k(B.
1158: % coneEq $B$N7k2L$H(B coneEqForSmallFan.2 $B$N7k2L$r(B join $B$7$F(B
1159: % getConeInfo or newCone
1160: % cone.local $B$,@_Dj$5$l$F$$$k$H(B u_i <= 0 $B$b>r7o$KF~$k(B.
1161: %>
1162: /coneEqForTotalFan.2 {
1163: /arg2 set
1164: /arg1 set
1165: [/n /nn /dd /ii /tt] pushVariables
1166: [
1167: /n arg1 def
1168: /d arg2 def
1169: n to_int32 /n set
1170: d to_int32 /d set
1171: /nn n n add def
1172: /dd n d add def
1173:
1174: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i >= 0
1175: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
1176: % t = 0
1177: [
1178: % d ~ n-1, dd ~ nn-1 $B$G$O(B u_i=v+i = 0.
1179: d 1 n 1 sub {
1180: /ii set
1181: % [ 0,0, ..., 0,1,0,... ; 0] $B$r@8@.(B
1182: nn 1 add newVector null_to_zero /tt set
1183: tt ii (1).. put
1184: tt
1185: % [ 0,0, ..., 0,-1,0,... ; 0] $B$r@8@.(B
1186: nn 1 add newVector null_to_zero /tt set
1187: tt ii (-1).. put
1188: tt
1189: } for
1190: dd 1 nn 1 sub {
1191: /ii set
1192: nn 1 add newVector null_to_zero /tt set
1193: tt ii (1).. put
1194: tt
1195: nn 1 add newVector null_to_zero /tt set
1196: tt ii (-1).. put
1197: tt
1198: } for
1199:
1200: % 0 ~ d-1, n ~ dd-1 $B$G$O(B u_i + v_i >= 0
1201: 0 1 d 1 sub {
1202: /ii set
1203: nn 1 add newVector null_to_zero /tt set
1204: tt ii (1).. put
1205: tt ii n add (1).. put
1206: tt
1207:
1208: } for
1209:
1210: % t = 0
1211: cone.h0 {
1212: % t = 0
1213: nn 1 add newVector null_to_zero /tt set
1214: tt nn (1).. put
1215: tt
1216: nn 1 add newVector null_to_zero /tt set
1217: tt nn (-1).. put
1218: tt
1219: }
1220: {
1221: (coneForTotalFan.2. Not implemented.) error
1222: } ifelse
1223:
1224: % cone.local $B$,(B 1 $B$N;~(B
1225: % 0 ~ d-1 $B$G$O(B -u_i >= 0
1226: cone.local {
1227: 0 1 d 1 sub {
1228: /ii set
1229: nn 1 add newVector null_to_zero /tt set
1230: tt ii (-1).. put
1231: tt
1232: } for
1233: } { } ifelse
1234: ] /rr set
1235: /arg1 rr to_univNum def
1236: ] pop
1237: popVariables
1238: arg1
1239: } def
1240:
1241: %<
1242: % Usages: n d parametrizeTotalFan
1243: % n : x $BJQ?t$N?t(B.
1244: % d : 0 $B$K$7$J$$?t(B.
1245: % $B<!$NBg0hJQ?t$b@_Dj$5$l$k(B.
1246: % cone.W : weight $B$r%Q%i%a!<%?$E$1$9$k%Y%/%H%k$NAH(B.
1247: % 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,
1248: % i $B$,(B Wpos ~ $B$NHO0O$N$H$-(B V[i] $B$X$O(B Z $B$N85$r3]$1;;$7$F$h$$(B.
1249: % cone.w_ineq : weight space $B$NITEy<0@)Ls(B. $B0J8e$N7W;;$G>o$KIU2C$9$k(B.
1250: % cone.w_ineq $B$r(B getConeInfo $B$7$?7k2L$O(B cone.w_cone
1251: % Example: /cone.local 1 def ; 3 parametrizeSmallFan pmat
1252: % Example: /cone.local 0 def ; 3 parametrizeSmallFan pmat
1253: % local $B$,(B 1 $B$@$H(B u_i <= 0 $B$K$J$k(B.
1254: %>
1255: /parametrizeTotalFan {
1256: /arg2 set
1257: /arg1 set
1258: [/n /d /vv /coneray] pushVariables
1259: [
1260: /n arg1 def /d arg2 def
1261: {
1262: cone.type 2 eq { n d coneEqForTotalFan.2 /cone.w_ineq set exit}
1263: { } ifelse
1264: (This cone.type has not yet been implemented.) error
1265: } loop
1266: cone.w_ineq getConeInfo /cone.w_cone set
1267: cone.w_cone 1 get (VERTICES) getNode 2 get 0 get
1268: removeFirstFromPolymake /vv set
1269:
1270: vv cone.w_ineq toQuotientCone /coneray set
1271: coneray length /cone.Wpos set
1272:
1273: coneray cone.w_cone 0 get 2 get join /cone.W set
1274: /arg1 cone.W def
1275: ] pop
1276: popVariables
1277: arg1
1278: } def
1279:
1280: %<
1281: % Usages: vlist wlist cone_wtowv
1282: % [x y Dx Dy h] [-1 0 1 0 0] ==> [(x) -1 (Dx) 1] $B$r:n$k(B.
1283: %>
1284: /cone_wtowv {
1285: /arg2 set /arg1 set
1286: [/vlist /wlist /ii] pushVariables
1287: [
1288: /vlist arg1 def
1289: /wlist arg2 def
1290: wlist length vlist length eq {
1291: } { (cone_wtowv: length of the argument must be the same.) error} ifelse
1292:
1293: wlist to_int32 /wlist set
1294: [
1295: 0 1 wlist length 1 sub {
1296: /ii set
1297: wlist ii get 0 eq { }
1298: { vlist ii get wlist ii get } ifelse
1299: } for
1300: ] /arg1 set
1301: ] pop
1302: popVariables
1303: arg1
1304: } def
1305:
1306: %<
1307: % Usages: pruneZeroVector
1308: % genPo, getConeInfo $BEy$NA0$K;H$&(B. 0 $B%Y%/%H%k$O0UL#$N$J$$@)Ls$J$N$G=|$/(B.
1.2 takayama 1309: % $BF1$8@)Ls>r7o$b$N$>$/(B. polymake FACET $B$,@5$7$/F0$+$J$$>l9g$,$"$k$N$G(B.
1310: % cf. pear/OpenXM_tmp/x3y2.poly, x^3+y^2, x^2+y^3 data/test15.sm1
1.1 takayama 1311: %>
1312: /pruneZeroVector {
1313: /arg1 set
1314: [/mm /ii /jj /tt] pushVariables
1315: [
1316: /mm arg1 def
1317: mm to_univNum /mm set
1.2 takayama 1318: [ [ ] ] mm join shell rest uniq /mm set
1.1 takayama 1319: [
1320: 0 1 mm length 1 sub {
1321: /ii set
1322: mm ii get /tt set
1323: {
1324: 0 1 tt length 1 sub {
1325: /jj set
1326: tt jj get (0).. eq { }
1327: { tt exit } ifelse
1328: } for
1329: exit
1330: } loop
1331: } for
1332: ] /arg1 set
1333: ] pop
1334: arg1
1335: } def
1336:
1337: %<
1338: % Usages: a projectIneq v , dim(a) = n, dim(v) = d
1339: % a*cone.Wt*cone.Lpt
1340: %>
1341: /projectIneq {
1342: cone.Wt mul cone.Lpt mul
1343: } def
1344:
1345: %<
1346: % Usages: v liftWeight [w vw], dim(v) = d, dim(w) = n, vw : vw $B7A<0$N(B weight
1347: % v*cone.Lp*cone.W cone.vlist w cone_wtowv
1348: %>
1349: /liftWeight {
1350: /arg1 set
1351: [/v /w /vw] pushVariables
1352: [
1353: /v arg1 def
1354: v cone.Lp mul cone.W mul /w set
1355: [w cone.vlist w cone_wtowv] /arg1 set
1356: ] pop
1357: popVariables
1358: arg1
1359: } def
1360:
1361: %<
1362: % Usage: m isZero
1363: % dr.sm1 $B$X0\$9(B.
1364: %>
1365: /isZero {
1366: /arg1 set
1367: [/mm /ans /ii] pushVariables
1368: [
1369: /mm arg1 def
1370: /ans 1 def
1371: mm isArray {
1372: 0 1 mm length 1 sub {
1373: /ii set
1374: mm ii get isZero /ans set
1375: ans 0 eq { exit } { } ifelse
1376: } for
1377: } {
1378: {
1379: mm tag 1 eq {/ans mm 0 eq def exit} { } ifelse
1380: mm isPolynomial { /ans mm (0). eq def exit } { } ifelse
1381: mm isUniversalNumber { /ans mm (0).. eq def exit } { } ifelse
1382: /ans 0 def exit
1383: } loop
1384: } ifelse
1385: /arg1 ans def
1386: ] pop
1387: popVariables
1388: arg1
1389: } def
1390: [(isZero)
1391: [(m isZero bool)]] putUsages
1392:
1393: %<
1394: % Usage: m isNonNegative
1395: % dr.sm1 $B$X0\$9(B.
1396: %>
1397: /isNonNegative {
1398: /arg1 set
1399: [/mm /ans /ii] pushVariables
1400: [
1401: /mm arg1 def
1402: /ans 1 def
1403: mm isArray {
1404: 0 1 mm length 1 sub {
1405: /ii set
1406: mm ii get isNonNegative /ans set
1407: ans 0 eq { exit } { } ifelse
1408: } for
1409: } {
1410: {
1411: mm tag 1 eq {/ans mm 0 gt mm 0 eq or def exit} { } ifelse
1412: mm isUniversalNumber { /ans mm (0).. gt mm (0).. eq or def exit }
1413: { } ifelse
1414: mm isRational { mm (numerator) dc mm (denominator) dc mul /mm set
1415: /ans mm (0).. gt mm (0).. eq or def exit } { } ifelse
1416: /ans 0 def exit
1417: } loop
1418: } ifelse
1419: /arg1 ans def
1420: ] pop
1421: popVariables
1422: arg1
1423: } def
1424: [(isNonNegative)
1425: [(m isNonNegative bool)
1426: (In case of matrix, m[i,j] >= 0 must hold for all i,j.)
1427: ]] putUsages
1428:
1429: % Global variable: cone.weightBorder
1430: % /cone.weightBorder null def $BITMW$G$"$m$&(B. getStartingCone $B$G@_Dj$5$l$k(B.
1431:
1432: %<
1433: % Usages: cone i isOnWeigthBorder
1434: % cone $B$N(B i $BHVL\$N(B facet $B$,(B weight $B6u4V$N6-3&$K$"$k$+(B?
1435: % $BBg0hJQ?t(B cone.weightBorder $B$,@_Dj$5$l$F$k$3$H(B.
1436: % $B$3$NJQ?t$O(B cone $B$N(B facet $B%Y%/%H%k$N%j%9%H(B.
1437: % $B$3$NJQ?t$O(B setWeightBorder $B$G@_Dj(B
1438: % cone.weightBorder[0] or cone.weightBorder[1] or ...
1439: % /ccone cone.startingCone def ccone 0 isOnWeightBorder
1440: % ccone 1 isOnWeightBorder
1441: %>
1442: /isOnWeightBorder {
1443: /arg2 set /arg1 set
1444: [/cone /facet_i /i /j /vv /co /ans] pushVariables
1445: [
1446: /cone arg1 def /facet_i arg2 def
1447: facet_i to_int32 /facet_i set
1448: /ans 0 def
1449: cone (facetsv) getNode 2 get facet_i get /vv set % Facet $B$r(B vertex $BI=8=(B.
1450: {
1451: 0 1 cone.weightBorder length 1 sub {
1452: /i set
1453: cone.weightBorder i get /co set % co $B$K@)Ls>r7o(B
1454: vv cone.Lp mul % vv $B$r(B weight space $B$X(B lift.
1455: co mul isZero
1456: { /ans 1 def exit } { } ifelse
1457: } for
1458: exit
1459: } loop
1460: /arg1 ans def
1461: ] pop
1462: popVariables
1463: arg1
1464: } def
1465:
1466: %<
1467: % Usages: cone i markFlipped
1468: % 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.
1469: % cone $B$O(B class-tree. Constructor $B$O(B newCone
1470: %>
1471: /markFlipped {
1472: /arg2 set /arg1 set
1473: [/cone /facet_i /vv] pushVariables
1474: [
1475: /cone arg1 def /facet_i arg2 def
1476: facet_i to_int32 /facet_i set
1477: cone (flipped) getNode 2 get /vv set
1478: vv facet_i (1).. put
1479: ] pop
1480: popVariables
1481: } def
1482:
1483:
1484:
1485: %<
1486: % Usages: cone getNextFacet i
1487: % flipped $B$N(B mark $B$N$J$$(B facet $B$N(B index facet_i $B$rLa$9(B.
1488: % $B$=$l$,$J$$$H$-$O(B null
1489: %>
1490: /getNextFacet {
1491: /arg1 set
1492: [/cone /facet_i /vv /ii] pushVariables
1493: [
1494: /cone arg1 def
1495: /facet_i null def
1496: cone (flipped) getNode 2 get /vv set
1497: 0 1 vv length 1 sub {
1498: /ii set
1499: vv ii get to_int32 0 eq { /facet_i ii def exit }
1500: { } ifelse
1501: } for
1502: /arg1 facet_i def
1503: ] pop
1504: popVariables
1505: arg1
1506: } def
1507:
1508: %<
1509: % Usages: cone i epsilon flipWeight
1510: % cone $B$N(B i $BHVL\$N(B facet $B$K$+$s$7$F(B flip $B$9$k(B.
1511: % $B?7$7$$(B weight $B$r5a$a$k(B. cf. liftWeight
1512: %>
1513: /flipWeight {
1514: /arg3 set /arg2 set /arg1 set
1515: [/cone /facet_i /ep /vp /v /v /ii] pushVariables
1516: [
1517: /cone arg1 def /facet_i arg2 def
1518: facet_i to_int32 /facet_i set
1519: /ep arg3 def
1520:
1521: ep to_univNum (1).. div /ep set
1522:
1523: % note: 2004.9.2
1524: cone (facetsv) getNode 2 get facet_i get /v set
1525: cone (facets) getNode 2 get facet_i get /f set
1526: /vp v 0 get def
1527: 1 1 v length 1 sub {
1528: /ii set
1529: vp v ii get add /vp set
1530: } for
1531: vp ep f mul sub /vp set
1532: vp nnormalize_vec /vp set
1533: /arg1 vp def
1534: ] pop
1535: popVariables
1536: arg1
1537: } def
1538:
1539: %<
1540: % Usages: cone1 cone2 isSameCone bool
1541: % cone1 cone2 $B$,Ey$7$$$+(B? facet $B$GHf$Y$k(B.
1542: % cone1, cone2 $B$O(B pointed cone $B$G$J$$$H$$$1$J$$(B.
1543: %>
1544: /isSameCone {
1545: /arg2 set /arg1 set
1546: [/cone1 /cone2 /facets1 /facets2 /ans] pushVariables
1547: [
1548: /cone1 arg1 def
1549: /cone2 arg2 def
1550: /facets1 cone1 (facets) getNode 2 get def
1551: /facets2 cone2 (facets) getNode 2 get def
1552: facets1 length facets2 length eq {
1553: facets1 facets2 sub isZero /ans set
1554: } {
1555: /ans 0 def
1556: } ifelse
1557: /arg1 ans def
1558: ] pop
1559: popVariables
1560: arg1
1561: } def
1562:
1563: %<
1564: % Usages: cone1 cone2 getCommonFacet list
1565: % cone1 $B$NCf$G(B cone2 $B$K4^$^$l$k(B facet $B$N%j%9%H(B
1566: % cone2 $B$NCf$G(B cone1 $B$K4^$^$l$k(B facet $B$N%j%9%H$r$b$I$9(B.
1567: % [1 [i] [j]] $B$"$k$H$-(B. [0 [ ] [ ]] $B$J$$$H$-(B.
1568: % cone1 $B$N(B facetsv[i] $B$,(B cone2 $B$K4^$^$l$k$+D4$Y$k(B.
1569: % cone2 $B$N(B facetsv[i] $B$,(B cone1 $B$K4^$^$l$k$+D4$Y$k(B.
1570: % cone1, cone2 $B$O(B pointed cone $B$G$J$$$H$$$1$J$$(B.
1571: %>
1572: /getCommonFacet {
1573: /arg2 set /arg1 set
1574: [/cone1 /cone2 /facets /ineq /ans1 /ans2 /i /tt] pushVariables
1575: [
1576: /cone1 arg1 def
1577: /cone2 arg2 def
1578:
1579: /facets cone1 (facetsv) getNode 2 get def
1580: /ineq cone2 (inequalities) getNode 2 get def
1581: /ans1 [
1582: 0 1 facets length 1 sub {
1583: /i set
1584: facets i get /tt set % facetsv[i] $B$r(B tt $B$X(B.
1585: ineq tt transpose mul isNonNegative {
1586: i
1587: } { } ifelse
1588: } for
1589: ] def
1590:
1591: /facets cone2 (facetsv) getNode 2 get def
1592: /ineq cone1 (inequalities) getNode 2 get def
1593: /ans2 [
1594: 0 1 facets length 1 sub {
1595: /i set
1596: facets i get /tt set % facetsv[i] $B$r(B tt $B$X(B.
1597: ineq tt transpose mul isNonNegative {
1598: i
1599: } { } ifelse
1600: } for
1601: ] def
1602: ans1 length 1 gt ans2 length 1 gt or {
1603: (getCommonFacet found more than 1 common facets.) error
1604: } { } ifelse
1605: % $B6&DL(B facet $B$,$"$l$P(B 1, $B$J$1$l$P(B 0.
1606: ans1 length 1 eq ans2 length 1 eq and {
1607: /tt 1 def
1608: } {
1609: /tt 0 def
1610: } ifelse
1611: /arg1 [tt ans1 ans2] def
1612: ] pop
1613: popVariables
1614: arg1
1615: } def
1616:
1617: %
1618: % -------------------------------------------------
1619: % test8 $B$O(B aux-cone.sm1 $B$X0\F0(B.
1620: % $B0J2<$$$h$$$h0lHL$N%W%m%0%i%`$N:n@.3+;O(B.
1621: % -------------------------------------------------
1622: %
1623:
1624: %<
1625: % Usages: setWeightBorder
1626: % cone.weightBorder (weight cone $B$N(B facet $B%Y%/%H%k$N=89g(B) $B$r@_Dj$9$k(B.
1627: % $B$"$HI{;:J*$H$7$F(B cone.w_cone_projectedWt (doPolymakeObj)
1628: % cone.w_ineq_projectedWt
1629: % cone.m $B<!85$N%Y%/%H%k(B.
1630: % cone.W, cone.Wt, cone.w_ineq $B$,$9$G$K7W;;$:$_$G$J$$$H$$$1$J$$(B.
1631: %>
1632: /setWeightBorder {
1633: [
1634: (Entering setWeightBorder ) message
1635: cone.w_ineq cone.Wt mul pruneZeroVector /cone.w_ineq_projectedWt set
1636: {
1637: cone.w_ineq_projectedWt length 0 eq {
1638: % weight $B$N6u4V$K(B border $B$,$J$$>l9g(B.
1639: /cone.weightBorder [ ] def
1640: exit
1641: } { } ifelse
1642: % weight $B$N6u4V$K(B border $B$,$"$k>l9g(B.
1643: cone.w_ineq_projectedWt getConeInfo /cone.w_cone_projectedWt set
1644: cone.w_cone_projectedWt 0 get 0 get to_int32 cone.m to_int32 eq {
1645: } {
1646: (setWeightBorder : internal error.) message
1647: } ifelse
1648: cone.w_cone_projectedWt 1 get (FACETS) getNode 2 get 0 get
1649: removeFirstFromPolymake /cone.weightBorder set
1650: exit
1651: } loop
1652: (cone.weightBorder=) message
1653: cone.weightBorder pmat
1654: ] pop
1655: } def
1656:
1657: %
1658: % -------------------------------------------------
1659: % $B%W%m%0%i%`$NN.$l(B.
1660: % Global: cone.fan cone $B$rG[Ns$H$7$F3JG<$9$k(B.
1661: %
1662: % ncone (next cone) $B$,?75,$KF@$i$l$?(B cone $B$G$"$k$H$9$k(B.
1663: % $B$3$N$H$-<!$NA`:n$r$9$k(B.
1664: % 0. ncone $B$,(B cone.fan $B$K$9$G$K$J$$$+D4$Y$k(B. $B$"$l$P(B, internal error.
1665: % 1. ncone markBorder ; ncone $B$NCf$N(B border $B>e$N(B facet $B$r(B mark
1666: % 2. cone.fan $B$NCf$N(B cone $B$H6&DL(B facet $B$,$J$$$+D4$Y(B (getCommonFacet),
1667: % $B$"$l$P$=$l$i$r(B mark $B$9$k(B.
1668: % global: cone.incidence $B$K(B $B6&DL(Bfacet $B$r;}$DAH$_$N>pJs$r2C$($k(B.
1669: % 3. ncone $B$r(B cone.fan $B$N:G8e$K2C$($k(B.
1670: % $B0J>e$NA`:n$r$^$H$a$?$b$N$,(B ncone updateFan
1671: %
1672: % 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.
1673: % $B$J$1$l$P(B null $B$rLa$9(B. null $B$,La$l$P%W%m%0%i%`=*N;(B.
1674: %
1675: % getStargingCone $B$O7W;;$r=PH/$9$Y$-?75,$N(B cone $B$r7W;;$9$k(B. $BBg0hJQ?t(B cone.Lt, cone.W
1676: % $B$J$I$b$3$NCf$G@_Dj$9$k(B.
1677: % $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
1678: % $B$H$7$FF~NO$7$F$*$/(B.
1679: %
1680: % reduced gb $B$O(B $B4X?t(B input weight cone.gb reduced_G $B$G7W;;$9$k(B.
1681: %
1682: %
1683: % [ccone i] getNextCone ncone : flip $B$K$h$j<!$N(B cone $B$rF@$k(B.
1684: %
1685: % 1. clearGlobals ; $BF~NOBg0hJQ?t$N@_Dj(B.
1686: % 2. getStartingCone /ncone set
1687: % 3. { ncone updateFan
1688: % 4. getNextFlip /cone.nextflip set
1689: % 6. cone.nextflip isNull { exit } { } ifelse
1690: % 7. cone.nextflip getNextCone /ncone set
1691: % 8. } loop
1692: %
1693: %
1694: % -------------------------------------------------
1695: %
1696:
1697: %<
1698: % Usages: input weight cone.gb_Dh reduced_G
1699: % gb in h[1,1](D)
1700: %>
1701: /cone.gb_Dh {
1702: /arg2 set /arg1 set
1703: [/ff /ww /gg] pushVariables
1704: [
1705: /ff arg1 def
1706: /ww arg2 def
1707: [(AutoReduce) 1] system_variable
1708: [cone.vv ring_of_differential_operators
1709: [ww] weight_vector 0] define_ring
1710: [ff {toString .} map] groebner 0 get /gg set
1711: /cone.gb_Dh.g gg def
1712: /arg1 gg def
1713: ] pop
1714: popVariables
1715: arg1
1716: } def
1717:
1718: %<
1719: % Usages: cone.boundp
1720: %
1721: /cone.boundp {
1722: dup boundp 2 1 roll tag 0 eq not and
1723: } def
1724:
1725: %<
1726: % Usages: clearGlobals
1727: % cf. cone.boundp
1728: % polymake $B$r:FEY8F$V$?$a$K(B global $BJQ?t$r%/%j%"$9$k(B.
1729: % $B$^$@ESCf(B.
1730: %>
1731: /clearGlobals {
1732: /cone.W null def
1733: /cone.Wt null def
1734:
1735: /cone.cinit null def
1736: /cone.weightBorder null def
1737:
1738: } def
1739:
1740: %<
1741: % Usages: getStartingCone ncone
1742: % getStargingCone $B$O7W;;$r=PH/$9$Y$-?75,$N(B cone $B$r7W;;$9$k(B.
1743: % $B@_Dj$9$Y$-Bg0hJQ?t$O0J2<$r8+$h(B.
1744: %>
1745:
1746: /getStartingCone.test {
1747: %------------------Globals----------------------------------------
1748: % --------------- $BF~NO%G!<%?MQBg0hJQ?t$N@_Dj(B --------------------------
1749: %
1750: % cone.input : $BF~NOB?9`<07O(B
1751: /cone.input
1752: [(t1-x-y) (h*t2-x^2-y^2) (2*x*Dt2+h*Dt1+h*Dx) (2*y*Dt2+h*Dt1+h*Dy)]
1753: def
1754:
1755: % cone.vlist : $BA4JQ?t$N%j%9%H(B
1756: /cone.vlist [(t1) (t2) (x) (y) (Dt1) (Dt2) (Dx) (Dy) (h)] def
1757:
1758: % cone.vv : define_ring $B7A<0$NJQ?t%j%9%H(B.
1759: % t1,t2, x,y : t-space $B$N(B Grobner fan (local) $B$r5a$a$k(B.
1760: /cone.vv (t1,t2,x,y) def
1761:
1762: % cone.parametrizeWeightSpace : weight $B6u4V$r(B parametrize $B$9$k4X?t(B.
1763: % $BBg0hJQ?t(B cone.W , cone.Wpos $B$b$-$^$k(B.
1764: /cone.parametrizeWeightSpace {
1765: 4 2 parametrizeSmallFan
1766: } def
1767:
1768: % cone.w_start : weight$B6u4V$K$*$1$k(B weight $B$N=i4|CM(B.
1769: % $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.
1770: /cone.w_start
1771: [ 1 4 ]
1772: def
1773:
1774: % cone.gb : gb $B$r7W;;$9$k4X?t(B.
1775: /cone.gb {
1776: cone.gb_Dh
1777: } def
1778:
1779: %
1780: % ----------------- $B$*$o$j(B ---------------------------
1781: %
1782: } def % end of getStartingCone.test
1783:
1784: /getStartingCone {
1785: [/wv_start /w_start /reduced_G] pushVariables
1786: [
1787: % cone.n $B$O<+F0E*$K$-$a$i$l$k(B.
1788: % cone.n $B$O(B GB $B$r7W;;$9$k6u4V$N<!85(B.
1789: /cone.n cone.vlist length def
1790: %[1] cone.W, cone.Wpos $B$r5a$a$k(B. cone.m $B$O(B cone.W $B$h$j<+F0E*$K$-$^$k(B.
1791: % cone.m $B$O(B weight $B6u4V$N<+M3EY(B. cone.W $B$G<M1F$5$l$k@h$N<!85(B.
1792: /cone.W cone.boundp {
1793: (Skip cone.parametrizeWeightSpace. cf. clearGlobals) message
1794: } {
1795: cone.parametrizeWeightSpace
1796: } ifelse
1797: (parametrizing weight space: cone.W = ) messagen cone.W message
1798: /cone.Wt cone.W transpose def
1799: /cone.m cone.W length def
1800: % WeightBorder $B$N>r7oH=Dj(B facet $B$r@_Dj(B.
1801: /cone.weightBorder cone.boundp {
1802: (Skip setWeightBorder cf. clearGlobals) message
1803: } {
1804: setWeightBorder
1805: } ifelse
1806:
1807: %[2] weight vector wv_start $B$r@8@.$9$k(B.
1808: % wv_start $B$r@_Dj(B.
1809: cone.w_start tag 0 eq {
1810: % cone.w_start $B$,(B null $B$J$i(B random $B$K(B weight $B$r@_Dj(B.
1811: /cone.w_start cone.m cone_random_vec def
1812: } {
1813: cone.w_start length cone.m to_int32 eq {
1814: } {
1815: (Error: cone.w_start has wrong length.) error
1816: /cone.w_start cone.m cone_random_vec def
1817: } ifelse
1818: } ifelse
1819: /w_start cone.w_start cone.W mul def
1820:
1821: {
1822: cone.vlist w_start cone_wtowv /wv_start set
1823: (Trying a starting weight vector : ) messagen
1824: wv_start pmat
1825: %[3] reduced GB $B$N7W;;(B.
1826: cone.input wv_start cone.gb /reduced_G set
1.2 takayama 1827: (Reduced GB is obtained: ) message
1828: %reduced_G pmat
1829: /cone.cgb reduced_G def
1830: [cone.w_start w_start wv_start] /cone.cgb_weight set
1.1 takayama 1831:
1832: %[4] $B<M1F$7$F$+$i(B polytope $B$N%G!<%?$r7W;;(B.
1833: wv_start reduced_G coneEq /cone.g_ineq set
1834: cone.g_ineq cone.w_ineq join /cone.gw_ineq set
1835: cone.gw_ineq cone.Wt mul /cone.gw_ineq_projectedWt set % $B<M1F(B
1836: /cone.cinit cone.boundp {
1837: (Skipping cone.gw_ineq_projectedWt getConeInfo. cf. clearGlobals) message
1838: } {
1839: cone.gw_ineq_projectedWt getConeInfo /cone.cinit set
1840: } ifelse
1841:
1842: (cone.cinit is --- the first number is the dim of cone.) messagen
1843: cone.cinit 0 get pmat
1844: % Maximal dimensional cone $B$+$I$&$+$N8!::(B. $B8!::$K%Q%9$9$l$P(B loop $B$r(B exit
1845: % $B%Q%9$7$J$$>l9g(B w_start $B$r(B cone_random_vec $B$rMQ$$$FJQ99$9$k(B.
1846: cone.cinit 0 get 0 get to_int32 cone.m eq { exit }
1847: {
1848: (Failed to get the max dim cone. Updating the weight ...) messagen
1.2 takayama 1849: cone.m cone_random_vec /cone.w_start set
1850: /w_start cone.w_start cone.W mul def
1.1 takayama 1851: % cone.cinit $B$r:FEY7W;;$9$k$?$a$K(B clear $B$9$k(B.
1852: /cone.cinit null def
1853: } ifelse
1854: } loop
1855:
1856: (cone.m = ) messagen cone.m message
1857: (Suceeded to get the maximal dimensional startingCone.) message
1858:
1859: % Linearity subspace $B$N(B orth complement $B$X$N<M1F9TNs(B.
1860: % $BBg0hJQ?t(B cone.Lp, cone.Lpt $B$r@_Dj(B
1861: cone.cinit 0 get 1 get /cone.Lp set
1862: cone.Lp transpose /cone.Lpt set
1863: % Linearity subspace $B$N9TNs$r@_Dj(B.
1864: % $BBg0hJQ?t(B cone.L $B$r@_Dj(B
1865: cone.cinit 0 get 2 get /cone.L set
1866: % 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.
1867: % $BBg0hJQ?t(B cone.d $B$N@_Dj(B.
1868: /cone.d cone.Lp length def
1869:
1870: cone.m cone.d eq {
1871: (There is no linearity space) message
1872: } {
1873: (Dim of the linearity space is ) messagen cone.m cone.d sub message
1874: (cone.Lp = ) messagen cone.Lp pmat
1875: } ifelse
1876:
1877: %[5] cone.g_ineq * cone.Wt * cone.Lpt
1878: % cone.w_ineq * cone.Wt * cone.Lpt
1879: % $B$G@)Ls$r(B d $B<!85%Y%/%H%k$KJQ49(B.
1880: % W (R^m) $B6u4V$NITEy<0@)Ls$r(B L' (R^d) $B6u4V$X<M1F(B
1881: % cone.gw_ineq_projectedWtLpt
1882: % = cone.g_ineq*cone.Wt*cone.Lpt \/ cone.w_ineq*coneWt*cone.Lpt
1883:
1884: /cone.gw_ineq_projectedWtLpt
1885: cone.gw_ineq_projectedWt cone.Lpt mul
1886: def
1887:
1888: cone.m cone.d eq {
1889: /cone.cinit.d cone.cinit def
1890: } {
1891: % cone.m > cone.d $B$J$i$P(B, $B:FEY(B cone $B$N7W;;$,I,MW(B.
1892: % R^d $B$N(B cone $B$O(B cone.cinit.d $B$XF~$l$k(B.
1893: cone.gw_ineq_projectedWtLpt getConeInfo /cone.cinit.d set
1894: } ifelse
1895:
1896: cone.cinit.d 1 get newCone /cone.startingCone set
1897:
1898: (cone.startingCone is ) message
1899: cone.startingCone message
1900: ] pop
1901: popVariables
1902: cone.startingCone
1903: } def
1904:
1905: %
1906: % data/test9.sm1 $B$N(B test9 1-simplex X 2-simplex
1907: %
1908: % data/test10.sm1 1-simplex X 3-simplex
1909: % data/test11.sm1 SST, p.59
1910: %
1911: % $B$$$h$$$h(B, cone enumeration $B$N%W%m%0%i%`=q$-3+;O(B
1912: %
1913:
1914: %<
1915: % Usages: cone markBorder
1916: % cone->facets[i] $B$,(B weight space $B$N(B border $B$K$"$k$H$-(B
1917: % cone->flipped[i] = 2 $B$H$9$k(B.
1918: % $B$3$l$r(B cone $B$N$9$Y$F$N(B facet $B$KBP$7$F7W;;(B.
1919: %>
1920: /markBorder {
1921: /arg1 set
1922: [/cone /facets_t /flipped_t /kk] pushVariables
1923: [
1924: /cone arg1 def
1925: cone (facets) getNode 2 get /facets_t set
1926: cone (flipped) getNode 2 get /flipped_t set
1927: 0 1 flipped_t length 1 sub {
1928: /kk set
1929: flipped_t kk get (0).. eq {
1930: cone kk isOnWeightBorder {
1931: % Border $B$N>e$K$"$k$N$G(B flip $B:Q$N%^!<%/$r$D$1$k(B.
1932: flipped_t kk (2).. put
1933: } { } ifelse
1934: } { } ifelse
1935: } for
1936: ] pop
1937: popVariables
1938: } def
1939:
1940: %<
1941: % Usages: ncone updateFan
1942: % $B%0%m!<%P%kJQ?t(B cone.fan $B$r99?7$9$k(B.
1943: %>
1944: %
1945: % updateFan $B$N(B debug $B$O(B data/test8 $B$G$H$j$"$($:$d$k(B.
1946: % test8 /ncone set $B$r<B9T$7$F$+$i(B ncone updateFan
1947:
1948: % global: cone.fan
1949: /cone.fan [ ] def
1950: % global: cone.incidence
1951: /cone.incidence [ ] def
1.2 takayama 1952: % global: cone.gblist gb's standing for each cones in cone.fan.
1953: /cone.gblist [ ] def
1.1 takayama 1954:
1955: /updateFan {
1956: /arg1 set
1957: [/ncone /kk /cfacet /ii /jj /tcone /flipped_t] pushVariables
1958: [
1959: /ncone arg1 def
1960: /cone.fan.n cone.fan length def
1.2 takayama 1961: % -1. cone.cgb ($BD>A0$K7W;;$5$l$?(B gb) $B$H(B cone.cgb_weight ($BD>A0$N7W;;$N(B weight)
1962: % $B$r(B cone.gblist $B$X3JG<$9$k(B.
1963: cone.gblist [ [cone.cgb cone.cgb_weight] newConeGB ] join /cone.gblist set
1.1 takayama 1964: % 0. ncone $B$,(B cone.fan $B$K$9$G$K$"$l$P%(%i!<(B
1965: 0 1 cone.fan.n 1 sub {
1966: /kk set
1967: ncone cone.fan kk get isSameCone {
1968: (Internal error updateFan: ncone is already in cone.fan) error
1969: } { } ifelse
1970: } for
1971:
1972: % 1. ncone $B$NCf$N(B border $B>e$N(B facet $B$r$9$Y$F(B mark.
1973: ncone markBorder
1974:
1975: % 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
1976: 0 1 cone.fan.n 1 sub {
1977: /kk set
1978: ncone cone.fan kk get getCommonFacet /cfacet set
1979: cfacet 0 get
1980: {
1981: % $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.
1982: /ii cfacet 1 get 0 get def
1983: /jj cfacet 2 get 0 get def
1984: cone.incidence [ [[cone.fan.n ii] [kk jj]] ] join /cone.incidence set
1985: % flipped $B$r(B mark $B$9$k(B.
1986: ncone ii markFlipped
1987: cone.fan kk get /tcone set
1988: tcone jj markFlipped
1989: } { } ifelse
1990: } for
1991: % 3. ncone $B$r2C$($k(B.
1992: cone.fan [ncone] join /cone.fan set
1993: ] pop
1994: popVariables
1995: } def
1996:
1997: %<
1998: % usages: getNextFlip [cone, k]
1999: % 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.
2000: % $B$b$&$J$$$H$-$K$O(B null $B$rLa$9(B.
2001: %>
2002: /getNextFlip {
2003: [/tcone /ans /ii ] pushVariables
2004: [
2005: /ans null def
2006: 0 1 cone.fan length 1 sub {
2007: /ii set
2008: cone.fan ii get /tcone set
2009: tcone getNextFacet /ans set
2010: ans tag 0 eq { } { exit } ifelse
2011: } for
2012: ans tag 0 eq { /arg1 null def }
2013: { /arg1 [tcone ans] def } ifelse
2014: ] pop
2015: popVariables
2016: arg1
2017: } def
2018:
2019: % global variable : cone.epsilon , cone.epsilon.limit
2020: % flip $B$N;~$N(B epsilon
2021: /cone.epsilon (1).. (10).. div def
2022: /cone.epsilon.limit (1).. (100).. div def
2023:
2024: %<
2025: % Usages: result_getNextFlip getNextCone ncone
2026: % flip $B$7$F?7$7$$(B ncone $B$rF@$k(B.
2027: %>
2028: /getNextCone {
2029: /arg1 set
2030: [/ncone /ccone /kk /w /next_weight_w_wv] pushVariables
2031: [
2032: /ccone arg1 def
2033: /ncone null def
2034: /kk ccone 1 get def
2035: ccone 0 get /ccone set
2036: {
2037: ccone tag 0 eq { exit } { } ifelse
2038:
2039: % ccone $B$N(B kk $BHVL\$N(B facet $B$K$D$$$F(B flip $B$9$k(B.
2040: ccone kk cone.epsilon flipWeight /w set
2041: (Trying new weight is ) messagen w message
2042: w liftWeight /next_weight_w_wv set
2043: (Trying new weight [w,wv] is ) messagen next_weight_w_wv message
2044:
2045: cone.input next_weight_w_wv 1 get cone.gb /cone.cgb set
1.2 takayama 2046: [w] next_weight_w_wv join /cone.cgb_weight set
1.1 takayama 2047: next_weight_w_wv 1 get cone.cgb coneEq /cone.g_ineq set
2048: cone.g_ineq cone.w_ineq join cone.Wt mul cone.Lpt mul
2049: pruneZeroVector /cone.gw_ineq_projectedWtLpt set
2050:
2051: (cone.gw_ineq_projectedWtLpt is obtained.) message
2052:
2053: cone.gw_ineq_projectedWtLpt getConeInfo /cone.nextConeInfo set
2054: % $B<!85$rD4$Y$k(B. $B$@$a$J$i(B retry
2055: cone.nextConeInfo 0 get 0 get to_int32 cone.d eq {
2056: cone.nextConeInfo 1 get newCone /ncone set
2057: ccone ncone getCommonFacet 0 get {
2058: (Flip succeeded.) message
2059: exit
2060: } { } ifelse
2061: } { } ifelse
2062: % common face $B$,$J$1$l$P(B $B$d$O$j(B epsilon $B$r>.$5$/(B.
2063: cone.nextConeInfo 0 get 0 get to_int32 cone.d eq {
2064: (ccone and ncone do not have a common facet.) message
2065: } {
2066: (ncone is not maximal dimensional. ) message
2067: } ifelse
2068: (Decreasing epsilon to ) messagen
2069: cone.epsilon (1).. (2).. div mul /cone.epsilon set
2070: cone.epsilon cone.epsilon.limit sub numerator (0).. lt {
2071: (Too small cone.epsilon ) error
2072: } { } ifelse
2073: cone.epsilon message
2074: } loop
2075: /arg1 ncone def
2076: ] pop
2077: popVariables
2078: arg1
2079: } def
2080:
2081: %<
2082: % Usages: set globals and getGrobnerFan
2083: % cf. clearGlobals
2084: % getStartingCone $B$9$k$H(B weightSpace $B$H$+$N7W;;$,$G$-$k(B. isOnWeightBorder $B$,(B
2085: % $B7h$a$i$l$k(B.
2086: %>
2087: % $B$H$j$"$($:(B (data/test8.sm1) run $B$7$F$+$i(B getGrobnerFan
2088: /getGrobnerFan {
2089: getStartingCone /cone.ncone set
2090: {
2091: cone.ncone updateFan
2092: ( ) message
2093: (----------------------------------------------------------) message
2094: (getGrobnerFan #cone.fan=) messagen cone.fan length message
2095: cone.ncone /cone.ccone set
2096: getNextFlip /cone.nextflip set
2097: cone.nextflip tag 0 eq { exit } { } ifelse
2098: cone.nextflip getNextCone /cone.ncone set
2099: } loop
1.2 takayama 2100: (Construction is completed. See cone.fan, cone.incidence and cone.gblist.)
2101: message
2102: } def
2103:
2104: %<
2105: % Usages: vlist generateD1_1
2106: % -1,1 weight $B$r@8@.$9$k(B.
2107: % vlist $B$O(B (t,x,y) $B$+(B [(t) (x) (y)]
2108: %
2109: %>
2110: /generateD1_1 {
2111: /arg1 set
2112: [/vlist /rr /rr /ii /vv] pushVariables
2113: [
2114: /vlist arg1 def
2115: vlist isString {
2116: [vlist to_records pop] /vlist set
2117: } { } ifelse
2118: [
2119: 0 1 vlist length 1 sub {
2120: /ii set
2121: vlist ii get /vv set
2122: vv -1
2123: [@@@.Dsymbol vv] cat 1
2124: } for
2125: ] /rr set
2126: /arg1 rr def
2127: ] pop
2128: popVariables
2129: arg1
2130: } def
2131:
2132: /listNodes {
2133: /arg1 set
2134: [/in-listNodes /ob /rr /rr /ii] pushVariables
2135: [
2136: /ob arg1 def
2137: /rr [ ] def
2138: {
2139: ob isClass {
2140: ob (array) dc /ob set
2141: } { exit } ifelse
2142: rr [ob 0 get] join /rr set
2143: ob 2 get /ob set
2144: 0 1 ob length 1 sub {
2145: /ii set
2146: rr ob ii get listNodes join /rr set
2147: } for
2148: exit
2149: } loop
2150: /arg1 rr def
2151: ] pop
2152: popVariables
2153: arg1
2154: } def
2155: [(listNodes)
2156: [(ob listNodes)
2157: (cf. getNode)
2158: (Example:)
2159: ( /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
2160: ( /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
2161: ( /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
2162: ( ma listNodes )
2163: ]] putUsages
2164:
2165: %<
2166: % Usages: obj printTree
2167: %>
2168: /printTree {
2169: /arg1 set
2170: [/ob /rr /rr /ii /keys /tt] pushVariables
2171: [
2172: /ob arg1 def
2173: /rr [ ] def
2174: /keys ob listNodes def
2175: keys 0 get /tt set
2176: keys rest /keys set
2177: keys { ob 2 1 roll getNode } map /rr set
2178: (begin ) messagen tt messagen
2179: ( ---------------------------------------) message
2180: 0 1 rr length 1 sub {
2181: /ii set
2182: keys ii get messagen (=) message
2183: rr ii get 2 get pmat
2184: } for
2185: (--------------------------------------- end ) messagen
2186: tt message
2187: /arg1 rr def
2188: ] pop
2189: popVariables
2190: arg1
2191: } def
2192:
2193: %<
2194: % Usages $B$O(B (inputForm) usages $B$r$_$h(B.
2195: %>
2196: /inputForm {
2197: /arg1 set
2198: [/ob /rr /i ] pushVariables
2199: [
2200: /ob arg1 def
2201: /rr [ ] def
2202: {
2203: ob isArray {
2204: rr [ ([) ] join /rr set
2205: 0 1 ob length 1 sub {
2206: /i set
2207: i ob length 1 sub lt {
2208: rr [ob i get inputForm $ , $] join /rr set
2209: } {
2210: rr [ob i get inputForm] join /rr set
2211: } ifelse
2212: } for
2213: rr [ (]) ] join cat /rr set
2214: exit
2215: } { } ifelse
2216: ob isClass {
2217: ob etag 263 eq { % tree
2218: /rr ob inputForm.tree def exit
2219: } { /rr [( $ this etag is not implemented $ )] cat def exit } ifelse
2220: } { } ifelse
2221: ob isUniversalNumber {
2222: [$($ ob toString $)..$] cat /rr set
2223: exit
2224: } { } ifelse
2225: ob isPolynomial {
2226: [$($ ob toString $).$] cat /rr set
2227: exit
2228: } { } ifelse
2229: ob isRational {
2230: [$ $ ob (numerator) dc inputForm $ $
2231: ob (denominator) dc inputForm $ div $ ] cat /rr set
2232: exit
2233: } { } ifelse
2234: ob isString {
2235: [$($ ob $)$ ] cat /rr set
2236: exit
2237: } { } ifelse
2238: ob toString /rr set
2239: exit
2240: } loop
2241: rr /arg1 set
2242: ] pop
2243: popVariables
2244: arg1
2245: } def
2246: [(inputForm)
2247: [(obj inputForm str)
2248: ]] putUsages
2249: % should be moved to dr.sm1
2250:
2251: /inputForm.tree {
2252: /arg1 set
2253: [/ob /key /rr /rr /ii] pushVariables
2254: [
2255: /ob arg1 def
2256: /rr [ ] def
2257: {
2258: ob (array) dc /ob set
2259: /rr [ $[$ ob 0 get inputForm $ , $
2260: ob 1 get inputForm $ , $
2261: ] def
2262: rr [ob 2 get inputForm ] join /rr set
2263: rr [$ ] $] join /rr set
2264: rr [ $ [(class) (tree)] dc $ ] join /rr set
2265: rr cat /rr set
2266: exit
2267: } loop
2268: /arg1 rr def
2269: ] pop
2270: popVariables
2271: arg1
2272: } def
2273:
2274: %<
2275: % Usages: str inputForm.value str
2276: %>
2277: /inputForm.value {
2278: /arg1 set
2279: [/key /val /valstr /rr] pushVariables
2280: [
2281: arg1 /key set
2282: key isString { } {(inputForm.value: argument must be a string) error } ifelse
2283: key boundp {
2284: [(parse) key] extension pop
2285: /val set
2286: val inputForm /valstr set
2287: [( ) valstr ( /) key ( set )] cat /rr set
2288: } {
2289: /valstr [] cat /rr set
2290: } ifelse
2291: rr /arg1 set
2292: ] pop
2293: popVariables
2294: arg1
2295: } def
2296:
2297: % global: cone.withGblist
2298: /cone.withGblist 0 def
2299: %<
2300: % Usages: saveGrobnerFan str
2301: % GrobnerFan $B$N%G!<%?$r(B inputForm $B$KJQ99$7$FJ8;zNs$KJQ$($k(B.
2302: % $B$3$N%G!<%?$r(B parse $B$9$k$H(B GrobnerFan $B$rF@$k$3$H$,2DG=(B.
2303: % BUG: $BB?9`<0$NB0$9$k4D$N%G!<%?$NJ]B8$O$^$@$7$F$J$$(B.
2304: %>
2305: /saveGrobnerFan {
2306: [/rr] pushVariables
2307: [
2308: (cone.withGblist=) messagen cone.withGblist message
2309: [
2310: % $B%f!<%6$N@_Dj$9$k%Q%i%a!<%?(B. cone.gb, cone.parametrizeWeightSpace $BEy$N4X?t$b$"$j(B.
2311: (cone.comment)
2312: (cone.type) (cone.local) (cone.h0)
2313: (cone.vlist) (cone.vv)
2314: (cone.input)
2315:
2316: % $B%W%m%0%i%`Cf$GMxMQ$9$k(B, $BBg;v$JBg0hJQ?t(B. weight vector $B$N<M1F9TNs$,=EMW(B.
2317: (cone.n) (cone.m) (cone.d)
2318: (cone.W) (cone.Wpos) (cone.Wt)
2319: (cone.L) (cone.Lp) (cone.Lpt)
2320: (cone.weightBorder)
2321: (cone.w_ineq)
2322: (cone.w_ineq_projectedWt)
2323: (cone.epsilon)
2324:
2325: % $B7k2L$NMWLs(B.
2326: (cone.fan)
2327: cone.withGblist { (cone.gblist) } { } ifelse
2328: (cone.incidence)
2329:
2330: ] { inputForm.value nl } map /rr set
1.3 ! takayama 2331: rr cat /rr set
! 2332: % ring $B$r(B save $B$7$F$J$$$N$GEv:B$NBP=h(B.
! 2333: [ ([) cone.vv inputForm ( ring_of_differential_operators 0 ] define_ring )
! 2334: nl nl rr] cat /arg1 set
1.2 takayama 2335: ] pop
2336: popVariables
2337: arg1
2338: } def
2339:
2340: /printGrobnerFan.1 {
2341: /arg1 set
2342: [/key /rr] pushVariables
2343: [
2344: /key arg1 def
2345: key boundp {
2346: [(parse) key] extension pop /rr set
2347: rr isArray {
2348: key messagen ( = ) message rr pmat
2349: } {
2350: key messagen ( = ) messagen rr message
2351: } ifelse
2352: }{
2353: key messagen ( = ) message
2354: } ifelse
2355: ] pop
2356: popVariables
2357: } def
2358:
2359: /printGrobnerFan {
2360: [/i] pushVariables
2361: [
2362: (========== Grobner Fan ====================) message
2363: [
2364: (cone.comment)
2365: (cone.vlist) (cone.vv)
2366: (cone.input)
2367: (cone.type) (cone.local) (cone.h0)
2368: (cone.n) (cone.m) (cone.d)
2369: (cone.W) (cone.Wpos) (cone.Wt)
2370: (cone.L) (cone.Lp) (cone.Lpt)
2371: (cone.weightBorder)
2372: (cone.incidence)
2373: ] { printGrobnerFan.1 } map
2374: ( ) message
2375: 0 1 cone.fan length 1 sub {
2376: /ii set
2377: ii messagen ( : ) messagen
2378: cone.fan ii get printTree
2379: } for
2380: cone.withGblist {
2381: 0 1 cone.gblist length 1 sub {
2382: /ii set
2383: ii messagen ( : ) messagen
2384: cone.gblist ii get printTree
2385: } for
2386: } { } ifelse
2387:
2388:
2389: (=========================================) message
2390: (cone.withGblist = ) messagen cone.withGblist message
2391: ( ) message
2392: ] pop
2393: popVariables
2394: } def
2395:
2396: %<
2397: % Usages: m uniq
2398: % Remove duplicated lines.
2399: %>
2400: /uniq {
2401: /arg1 set
2402: [/mm /prev /i /rr] pushVariables
2403: [
2404: /mm arg1 def
2405: {
2406: mm length 0 eq { [ ] /rr set exit } { } ifelse
2407: /prev mm 0 get def
2408: [
2409: prev
2410: 1 1 mm length 1 sub {
2411: /i set
2412: mm i get prev sub isZero { }
2413: { /prev mm i get def prev } ifelse
2414: } for
2415: ] /rr set
2416: exit
2417: } loop
2418: rr /arg1 set
2419: ] pop
2420: popVariables
2421: arg1
2422: } def
1.3 ! takayama 2423:
! 2424: %<
! 2425: % Usages: [vlist vw_vector] getGrRing [vlist vGlobal sublist]
! 2426: % example: [(x,y,z) [(x) -1 (Dx) 1 (y) 1 (Dy) 2]] getGrRing
! 2427: % [(x,y,z,y') [(x)] [[(Dy) (y')]]]
! 2428: % h[0,1](D_0) $B@lMQ$N(B getGrRing.
! 2429: % u_i + v_i > 0 $B$J$i(B Dx_i ==> x_i' ($B2D49$JJQ?t(B). sublist $B$X(B.
! 2430: % u_i < 0 $B$J$i(B x_i $B$O(B vGlobal $B$X(B.
! 2431: % ii [vlist vGlobal sublist] toGrRing /ii set
! 2432: % [ii jj vlist [(partialEcartGlobalVarX) vGlobal]] ecart.isSameIdeal $B$H;H$&(B.
! 2433: %>
! 2434: /getGrRing {
! 2435: /arg1 set
! 2436: [/vlist /vw_vector /ans /vGlobal /sublist /newvlist
! 2437: /dlist /tt /i /u /v /k
! 2438: ] pushVariables
! 2439: [
! 2440: /vlist arg1 0 get def
! 2441: /vw_vector arg1 1 get def
! 2442:
! 2443: vlist isString { [vlist to_records pop] /vlist set } { } ifelse
! 2444: vlist { toString } map /vlist set
! 2445: % dlist $B$O(B [(Dx) (Dy) (Dz)] $B$N%j%9%H(B.
! 2446: vlist { /tt set [@@@.Dsymbol tt] cat } map /dlist set
! 2447:
! 2448: /newvlist [ ] def /sublist [ ] def /vGlobal [ ] def
! 2449: % $B2D49$J?7$7$$JQ?t$r(B newvlist $B$X(B. $BCV49I=$r(B sublist $B$X(B.
! 2450: 0 1 vlist length 1 sub {
! 2451: /i set
! 2452: % (u,v) $B$O(B (x_i, Dx_i) $B$KBP$9$k(B weight vector
! 2453: /u vlist i get , vw_vector getGrRing.find def
! 2454: u -1 gt {
! 2455: vw_vector , u 1 add , get /u set
! 2456: } { /u 0 def } ifelse
! 2457:
! 2458: /v dlist i get , vw_vector getGrRing.find def
! 2459: v -1 gt {
! 2460: vw_vector , v 1 add , get /v set
! 2461: } { /v 0 def } ifelse
! 2462: u to_int32 /u set , v to_int32 /v set
! 2463:
! 2464: u v add , 0 gt {
! 2465: newvlist [vlist i get] join /newvlist set
! 2466: } { } ifelse
! 2467: u 0 lt {
! 2468: vGlobal [vlist i get] join /vGlobal set
! 2469: } { } ifelse
! 2470: } for
! 2471:
! 2472: newvlist { /tt set [ [@@@.Dsymbol tt] cat [tt (')] cat ] } map
! 2473: /sublist set
! 2474:
! 2475: /ans [ vlist , newvlist { /tt set [tt (')] cat } map , join from_records
! 2476: vGlobal sublist] def
! 2477: /arg1 ans def
! 2478: ] pop
! 2479: popVariables
! 2480: arg1
! 2481: } def
! 2482:
! 2483: %<
! 2484: % Usages: a uset getGrRing.find index
! 2485: %>
! 2486: /getGrRing.find {
! 2487: /arg2 set /arg1 set
! 2488: [/a /uset /ans /i] pushVariables
! 2489: [
! 2490: /a arg1 def /uset arg2 def
! 2491: /ans -1 def
! 2492: { /ans -1 def
! 2493: 0 1 , uset length 1 sub {
! 2494: /i set
! 2495: a tag , uset i get tag eq {
! 2496: a , uset i get eq {
! 2497: /ans i def exit
! 2498: } { } ifelse
! 2499: } { } ifelse
! 2500: } for
! 2501: exit
! 2502: } loop
! 2503: /arg1 ans def
! 2504: ] pop
! 2505: popVariables
! 2506: arg1
! 2507: } def
! 2508:
! 2509: %<
! 2510: % Usages: g1 g2 isSameGrRing bool
! 2511: % g1, g2 $B$O(B getGrRing $B$NLa$jCM(B.
! 2512: %>
! 2513: /isSameGrRing {
! 2514: /arg2 set /arg1 set
! 2515: [/g1 /g2 /ans] pushVariables
! 2516: [
! 2517: /g1 arg1 def /g2 arg2 def
! 2518: {
! 2519: /ans 1 def
! 2520: g1 0 get , g2 0 get eq { } { /ans 0 def exit } ifelse
! 2521: exit
! 2522: g1 1 get , g2 1 get eq { } { /ans 0 def exit } ifelse
! 2523: } loop
! 2524: /arg1 ans def
! 2525: ] pop
! 2526: popVariables
! 2527: arg1
! 2528: } def
! 2529:
! 2530: %<
! 2531: % Usages: [[ii i_vw_vector] [jj j_vw_vector] vlist] isSameInGrRing_h
! 2532: %>
! 2533: /isSameInGrRing_h {
! 2534: /arg1 set
! 2535: [/ii /i_vw_vector /jj /j_vw_vector /vlist
! 2536: /i_gr /j_gr /rrule /ans] pushVariables
! 2537: [
! 2538: /ii arg1 [0 0] get def
! 2539: /i_vw_vector arg1 [0 1] get def
! 2540: /jj arg1 [1 0] get def
! 2541: /j_vw_vector arg1 [1 1] get def
! 2542: /vlist arg1 2 get def
! 2543: {
! 2544: [vlist i_vw_vector] getGrRing /i_gr set
! 2545: [vlist j_vw_vector] getGrRing /j_gr set
! 2546: i_gr j_gr isSameGrRing { } { /ans [0 [i_gr j_gr]] def exit} ifelse
! 2547:
! 2548: % bug: in case of module
! 2549: [i_gr 0 get , ring_of_differential_operators 0] define_ring
! 2550:
! 2551: % H $B$r(B 1 $B$K(B.
! 2552: /rrule [ [@@@.Hsymbol . (1).] ] def
! 2553:
! 2554: i_gr 2 get length 0 eq {
! 2555: } {
! 2556: rrule i_gr 2 get { { . } map } map join /rrule set
! 2557: } ifelse
! 2558: ii { toString . rrule replace toString } map /ii set
! 2559: jj { toString . rrule replace toString } map /jj set
! 2560:
! 2561: [ii jj i_gr 0 get , i_gr 1 get] ecartd.isSameIdeal_h /ans set
! 2562: [ans [i_gr] rrule ecartd.isSameIdeal_h.failed] /ans set
! 2563:
! 2564: exit
! 2565: } loop
! 2566: /arg1 ans def
! 2567: ] pop
! 2568: popVariables
! 2569: arg1
! 2570: } def
! 2571:
! 2572: /test1.isSameInGrRing_h {
! 2573: [(parse) (data/test8-data.sm1) pushfile] extension
! 2574:
! 2575: cone.gblist 0 get (initial) getNode 2 get /ii set
! 2576: cone.gblist 0 get (weight) getNode [2 0 2] get /iiw set
! 2577:
! 2578: cone.gblist 1 get (initial) getNode 2 get /jj set
! 2579: cone.gblist 1 get (weight) getNode [2 0 2] get /jjw set
! 2580:
! 2581: (Doing [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ff set) message
! 2582: [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ff set
! 2583:
! 2584: ff pmat
! 2585:
! 2586: } def
! 2587:
! 2588:
! 2589: %<
! 2590: % Usages: i j IsSameCone_h [bool, ...]
! 2591: % $B%F%9%HJ}K!(B. (data/test8.sm1) run (data/test8-data.sm1) run 0 1 IsSameCone_h
! 2592: %>
! 2593: /IsSameCone_h {
! 2594: /arg2 set /arg1 set
! 2595: [/i /j /ans /ii /iiw /jj /jjw] pushVariables
! 2596: [
! 2597: /i arg1 def /j arg2 def
! 2598: cone.debug { (Comparing ) messagen [i j] message } { } ifelse
! 2599:
! 2600: cone.gblist i get (initial) getNode 2 get /ii set
! 2601: cone.gblist i get (weight) getNode [2 0 2] get /iiw set
! 2602:
! 2603: cone.gblist j get (initial) getNode 2 get /jj set
! 2604: cone.gblist j get (weight) getNode [2 0 2] get /jjw set
! 2605:
! 2606: [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ans set
! 2607:
! 2608: ans /arg1 set
! 2609: ] pop
! 2610: popVariables
! 2611: arg1
! 2612: } def
! 2613:
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