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     ! 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 ;