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