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