Return to gkz.sm1 CVS log

Up to [local] / OpenXM / src / kan96xx / Doc

Annotation of OpenXM/src/kan96xx/Doc/gkz.sm1, Revision 1.1.1.1

1.1       maekawa     1: %% gkz.sm1, 1998, 11/6, 11/8
                      2: /gkz.version (2.981108) def
                      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:
                      9: $gkz.sm1 generates gkz systems (C) N.Takayama, 1998, 11/8, cf. rrank in hol.sm1 $ message-quiet
                     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:
                    147: ( ) message-quiet ;