Annotation of OpenXM/src/kan96xx/Doc/gkz.sm1, Revision 1.2
1.2 ! takayama 1: %% gkz.sm1, 1998, 11/6, 11/8, 2007-06-03
! 2: /gkz.version (3.000000) def
1.1 maekawa 3: gkz.version [(Version)] system_variable gt
4: { (This package requires the latest version of kan/sm1) message
5: (Please get it from http://www.math.kobe-u.ac.jp/KAN) message
6: error
7: } { } ifelse
8:
1.2 ! takayama 9: $gkz.sm1 generates gkz, mgkz systems (C) N.Takayama, 1998-2007, cf. rrank in hol.sm1 $ message-quiet
1.1 maekawa 10: /gkz.verbose 0 def
11: /gkz.A [[1 1 1 1] [0 1 2 3]] def
12: /gkz.b [3 5] def
13:
14:
15: /gkz {
16: /arg1 set
17: [/in-gkz /aa /typev /setarg /A /b /vx /vy /vyi /w /n /k
18: /vvv /www /At /i /ff /ttt /vxd /ttt2 /ttt /i /vxrule
19: ] pushVariables
20: [(CurrentRingp) (KanGBmessage)] pushEnv %% push current global environment.
21: [
22: /aa arg1 def
23: aa isArray { } { (array gkz) message (gkz) usage error } ifelse
24: /setarg 0 def
25: aa { tag } map /typev set
26: typev [ ArrayP ArrayP ] eq
27: { /A aa 0 get def
28: /b aa 1 get def
29: /setarg 1 def
30: } { } ifelse
31: typev [ ] eq
32: {
33: /A gkz.A def
34: /b gkz.b def
35: /setarg 1 def
36: } { } ifelse
37: typev [ ArrayP ] eq
38: { /A aa 0 get def
39: /b [ 1 1 A length { pop 0 } for ] def
40: /setarg 1 def
41: } { } ifelse
42: setarg { } { (Argument mismatch) message error } ifelse
43:
44: [(KanGBmessage) gkz.verbose] system_variable
45: b length /k set
46: A 0 get length /n set
47:
48: %% vy = [ (y1) (y2)] , vyi = [(yi1) (yi2)], vx = [(x1) (x2) (x3) (x4)]
49: [ 1 1 k { } for ] { (y) 2 1 roll gensym } map /vy set
50: [ 1 1 k { } for ] { (yi) 2 1 roll gensym } map /vyi set
51: [ 1 1 n { } for ] { (x) 2 1 roll gensym } map /vx set
52:
53: %% vvv = [(y1) (y2) (yi1) (yi2) (x1) (x2) (x3) (x4)]
54: /vvv vy vyi join vx join def
55: %% www = [(y1) 1 (y2) 1 (yi1) 1 (yi2) 1]
56: /www vy vyi join { 1 } map def
57: [ vvv from_records ring_of_polynomials
58: [www] weight_vector 0] define_ring
59:
60: /At A transpose def
61: %% ff = [ x1 - y1 , x2 - y1 y2, x3 - y1 y2^2 , x4 - y1 y2^3 ]
62: [
63: 1 1 n {
64: /i set
65: (x) i gensym . vy vyi << At i 1 sub get >> gkz.prod sub
66: } for
67: 1 1 k {
68: /i set
69: (1). (y) i gensym . (yi) i gensym . mul sub %% 1- y_i yi_i
70: } for
71: ] /ff set
72: gkz.verbose { ff message } { } ifelse
73: [ff] groebner_sugar 0 get
74: vy vyi join eliminatev /ttt set
75: ttt { toString } map /ttt set
76: %%% ttt <== toric ideal
77:
78: [ vx from_records ring_of_differential_operators 0] define_ring
79: %%D-clean /vvv [ 1 1 n { /i set [(x) i gensym . (Dx) i gensym . mul] } for ] def
80: /vvv [ 1 1 n { /i set [(x) i gensym . [@@@.Dsymbol (x)] cat i gensym . mul] } for ] def
81: A { {(universalNumber) dc} map } map vvv mul transpose 0 get /ff set
82:
83: ff b {(universalNumber) dc} map sub {toString} map /ff set
84: %%% ff <== linear equations.
85:
86: %%% vxd = [(Dx1) ... (Dx4)]
87: /vxd vx {@@@.Dsymbol 2 1 roll 2 cat_n} map def
88: %% fix 1999, 3/3 for non-homogeneous toric ideal.
89: /vxrule [ 0 1 vx length 1 sub {
90: /i set
91: [vx i get . vxd i get .] } for
92: ] def
93: %% ttt { . vx vxd join laplace0 toString } map /ttt2 set
94: ttt { . vxrule replace toString } map /ttt2 set
95:
96: /arg1 [ << ff ttt2 join >> vx ] def
97: ] pop
98: popEnv
99: popVariables
100: arg1
101: } def
102:
103:
104: %% \prod y_j^{v_j}
105: %% [(y1) (y2)] [(yi1) (yi2)] [ 1 3] gkz.prod ==> y1 y2^3
106: /gkz.prod {
107: /arg3 set
108: /arg2 set
109: /arg1 set
110: [/in-gkz.prod /yy /yyi /vec /ans /i /mm] pushVariables
111: [
112: /yy arg1 def
113: /yyi arg2 def
114: /vec arg3 def
115: /ans (1). def
116: 0 1 << vec length 1 sub >> {
117: /i set
118: << vec i get >> 0 lt {
119: /mm yyi i get . << 0 vec i get sub >> npower def
120: }
121: { /mm yy i get . << vec i get >> npower def }
122: ifelse
123: /ans ans mm mul def
124: } for
125: /arg1 ans def
126: ] pop
127: popVariables
128: arg1
129: } def
130: (gkz ) messagen-quiet
131:
132: [(gkz)
133: [([ A b] gkz [eq v])
134: ([ A ] gkz [eq v])
135: ([ ] gkz [eq v])
136: (array of array of integer A; array of integer b;)
137: (eq is the GKZ system defined by the matrix A and the parameter b.)
138: (v is the list of variables.)
139: (Default values of A and b are in gkz.A and gkz.b)
140: (For details, see Functional analysis and its applications, 23, 1989, 94--106.)
141: ( Grobner deformations of hypergeometric differential equations, Springer, 1999)
142: (Example 1: [ [[1 1 1 1] [0 1 3 4]] [1 2]] gkz rrank :: )
143: (Example 2: [ [[1 1 1 1] [0 1 3 4]] [0 0]] gkz rrank :: )
144: ]
145: ] putUsages
146:
1.2 ! takayama 147:
! 148: /mgkz.A [[1 1 1 1] [0 1 2 3]] def
! 149: /mgkz.w [4 0 0 2] def
! 150: /mgkz.b [3 5] def
! 151:
! 152:
! 153: /mgkz {
! 154: /arg1 set
! 155: [/in-mgkz /aa /typev /setarg /A /b /vx /vy /vyi /w /n /k
! 156: /vvv /www /At /i /ff /ttt /vxd /ttt2 /ttt /i /vxrule
! 157: /w /mrulex /mruled
! 158: ] pushVariables
! 159: [(CurrentRingp) (KanGBmessage)] pushEnv %% push current global environment.
! 160: [
! 161: /aa arg1 def
! 162: aa isArray { } { (array mgkz) message (mgkz) usage error } ifelse
! 163: /setarg 0 def
! 164: aa { tag } map /typev set
! 165: typev [ ArrayP ArrayP ArrayP] eq
! 166: { /A aa 0 get def
! 167: /w aa 1 get def
! 168: /b aa 2 get def
! 169: /setarg 1 def
! 170: } { } ifelse
! 171: typev [ ] eq
! 172: {
! 173: /A mgkz.A def
! 174: /w mgkz.w def
! 175: /b mgkz.b def
! 176: /setarg 1 def
! 177: } { } ifelse
! 178: setarg { } { (Argument mismatch) message error } ifelse
! 179:
! 180: b [0] join /b set
! 181: [(KanGBmessage) gkz.verbose] system_variable
! 182: b length /k set
! 183: A w append /A set
! 184: A transpose , [ 2 1 k { pop 0 } for 1] append /A set
! 185: A transpose /A set
! 186: A 0 get length /n set
! 187:
! 188: %% vy = [ (y1) (y2) (y3)] , vyi = [(yi1) (yi2) (yi3)],
! 189: %% vx = [(x1) (x2) (x3) (x4) (x5)]
! 190: [ 1 1 k { } for ] { (y) 2 1 roll gensym } map /vy set
! 191: [ 1 1 k { } for ] { (yi) 2 1 roll gensym } map /vyi set
! 192: [ 1 1 n { } for ] { (x) 2 1 roll gensym } map /vx set
! 193:
! 194: %% vvv = [(y1) (y2) (y3) (yi1) (yi2) (yi3) (x1) (x2) (x3) (x4) (x5)]
! 195: /vvv vy vyi join vx join def
! 196: %% www = [(y1) 1 (y2) 1 (y3) 1 (yi1) 1 (yi2) 1 (yi3) 1]
! 197: /www vy vyi join { 1 } map def
! 198: [ vvv from_records ring_of_polynomials
! 199: [www] weight_vector 0] define_ring
! 200:
! 201: /At A transpose def
! 202: %% Apply an algorithm to get the toric ideal.
! 203: %% Negative components are accepted. yi1=y1^(-1), ...
! 204: [
! 205: 1 1 n {
! 206: /i set
! 207: (x) i gensym . vy vyi << At i 1 sub get >> gkz.prod sub
! 208: } for
! 209: 1 1 k {
! 210: /i set
! 211: (1). (y) i gensym . (yi) i gensym . mul sub %% 1- y_i yi_i
! 212: } for
! 213: ] /ff set
! 214: gkz.verbose { ff message } { } ifelse
! 215: [ff] groebner_sugar 0 get
! 216: vy vyi join eliminatev /ttt set
! 217: ttt { toString } map /ttt set
! 218: %%% ttt <== toric ideal
! 219:
! 220: [ vx from_records ring_of_differential_operators 0] define_ring
! 221: %%D-clean /vvv [ 1 1 n { /i set [(x) i gensym . (Dx) i gensym . mul] } for ] def
! 222: /vvv [ 1 1 n { /i set [(x) i gensym . [@@@.Dsymbol (x)] cat i gensym . mul] } for ] def
! 223: A { {(universalNumber) dc} map } map vvv mul transpose 0 get /ff set
! 224:
! 225: ff b {(universalNumber) dc} map sub /ff set
! 226:
! 227: /mrulex vx , n 1 sub , get . /mrulex set
! 228: [[mrulex , (0). mrulex sub]] /mrulex set
! 229: %%% [[(x5). (-x5).]] mrulex
! 230: ff {mrulex replace} map {toString} map /ff set
! 231: %%% ff <== linear equations.
! 232:
! 233: %%% vxd = [(Dx1) ... (Dx4) (Dx5)]
! 234: /vxd vx {@@@.Dsymbol 2 1 roll 2 cat_n} map def
! 235:
! 236: [[vxd , n 1 sub , get .
! 237: vx , n 1 sub , get .]] /mruled set
! 238:
! 239: %% fix 1999, 3/3 for non-homogeneous toric ideal.
! 240: /vxrule [ 0 1 vx length 1 sub {
! 241: /i set
! 242: [vx i get . vxd i get .] } for
! 243: ] def
! 244: %% ttt { . vx vxd join laplace0 toString } map /ttt2 set
! 245: ttt { . vxrule replace , mruled replace , toString } map /ttt2 set
! 246:
! 247: /arg1 [ << ff ttt2 join >> vx ] def
! 248: ] pop
! 249: popEnv
! 250: popVariables
! 251: arg1
! 252: } def
! 253:
! 254: [(mgkz)
! 255: [([A w b] gkz [eq v])
! 256: ([ ] gkz [eq v])
! 257: (array of array of integer A; array of integer w, b;)
! 258: (eq is the modified GKZ system defined by the matrix A, weight w, )
! 259: (and the parameter b.)
! 260: (v is the list of variables. The last variable is the deformation variable.)
! 261: (Default values of A and b are in gkz.A and gkz.b)
! 262: (For details, see a paper Modified A-hypergeometric system, N.Takayama --- private note.)
! 263: (Example : [ [[1 2 3]] [1 2 1] [0]] mgkz rank :: )
! 264: (Example : [ [[1 2 3]] [0]] gkz rank :: )
! 265: (Example : [ [[1 1 1] [1 2 3]] [1 2 1] [1 0]] mgkz message )
! 266: ]
! 267: ] putUsages
! 268:
! 269:
1.1 maekawa 270: ( ) message-quiet ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to gkz.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc