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