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