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