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