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