%% appell.sm1, 1998,  11/8
% $OpenXM: OpenXM/src/kan96xx/Doc/appell.sm1,v 1.5 2003/08/18 11:28:15 takayama Exp $
/appell.version (2.981108) def
appell.version [(Version)] system_variable gt
{ (This package requires the latest version of kan/sm1) message
  (Please get it from http://www.math.kobe-u.ac.jp/KAN) message
  error
} { } ifelse

$appell.sm1 generates Appell hypergeometric differential equations (C) N.Takayama, 1998, 11/8, cf. rank in hol.sm1 $ message-quiet
/appell.verbose 0 def
/appell.b [1 3 2 11] def

/appell1 {
  /arg1 set
  [/in-appell1 /typev /setarg /b /n /vv /i /a /c /bb /ans /ans2
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv  %% push current global environment.
  [
    /aa arg1 def
    aa isArray { } { (array appell) message (appell1) usage error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /b aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [ ] eq
    {
       /b appell.b def
       /setarg 1 def
    } { } ifelse
    setarg { } { (Argument mismatch) message (appell1) usage error } ifelse

    [(KanGBmessage) appell.verbose] system_variable

    /n b length 2 sub def   %% Lauricella F_D^n
    
    %% vv = [(x1) (x2)]
    [
      1 1 n {
        /i set
        (x) i gensym
      } for
    ] /vv set

    %% b = [a  c  b_1 ... b_n  ]
    /a b 0 get def
    /c b 1 get 1 sub def
    /bb b rest rest def    

    [ 1 1 n { 
        /i set
        [  [@@@.Dsymbol (x)] cat i gensym 
           $ ($  1 n appell.euler c $) - ( $
           1 n appell.euler a $) ($ i i appell.euler bb i 1 sub get $ ) $] cat
      } for
    ] /ans set
    %% Euler-Darboux equations are necessary. Otherwise, the system is
    %% not holonomic for some parameters.
    [ 1 1 n {
        /i set
        i 1 add 1 n {
          /j set
          [$($ $x$ i gensym $-x$ j gensym $) $ 
           [@@@.Dsymbol (x)] cat i gensym $  $
           [@@@.Dsymbol (x)] cat j gensym 
           $ - $  bb j 1 sub get $ $ [@@@.Dsymbol (x)] cat i gensym
           $ + $  bb i 1 sub get $ $ [@@@.Dsymbol (x)] cat j gensym
          ] cat
        } for
      }for
    ] /ans2 set
    /arg1 [ans ans2 join vv] def
  ] pop
  popEnv
  popVariables
  arg1
} def
(appell1 ) messagen-quiet

[(appell1)
 [(param appell1 c)
  (array param; array c;)
  (appell1 returns an annihilating ideal for )
  (the Lauricella function F_D(a,b_1, ..., b_n,c; x_1,...,x_n))
  (for the parameter << param >> = [a, c, b_1, ..., b_n].)
  (In case of n=2, the function is called the Appell function F_1.)
  (c = [ generators,  variables ])
  (Note that for a special set of parameters, the returned differential equation)
  (is not holonomic, e.g., [[1 2 3 4]] appell1 rank ::)
  (This happens because we do not included the Euler-Darboux operators)
  (in the return value of appell1. It will be included in a future.)
  (Example: [ [1 -4 -2 5 6] ] appell1 rank ::)
  (For details, see P.Appell et Kampe de Feriet, Fonction hypergeometrique)
  (et hyperspheriques -- polynomes d'Hermite, Gauthier-Villars, 1926.)
 ]
] putUsages

/appell4 {
  /arg1 set
  [/in-appell4 /typev /setarg /b /n /vv /i /a /c /bb /ans
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv  %% push current global environment.
  [
    /aa arg1 def
    aa isArray { } { (array appell) message (appell4) usage error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /b aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [ ] eq
    {
       /b appell.b def
       /setarg 1 def
    } { } ifelse
    setarg { } { (Argument mismatch) message (appell4) usage error } ifelse

    [(KanGBmessage) appell.verbose] system_variable

    /n b length 2 sub def   %% Lauricella F_C^n
    
    %% vv = [(x1) (x2)]
    [
      1 1 n {
        /i set
        (x) i gensym
      } for
    ] /vv set

    %% b = [a  b  c_1 ... c_n ]
    /a b 0 get def
    /c b 1 get def
    /bb b rest rest def    

    [ 1 1 n { 
        /i set
        [  [@@@.Dsymbol (x)] cat i gensym 
           $ ($  i i appell.euler bb i 1 sub get 1 sub $) - ( $
           1 n appell.euler a $) ($ 1 n appell.euler c $ ) $] cat
      } for
    ] /ans set
    /arg1 [ans vv] def
  ] pop
  popEnv
  popVariables
  arg1
} def
(appell4 ) messagen-quiet

[(appell4)
 [(param appell4 c)
  (array param; array c;)
  (appell4 returns an annihilating ideal for )
  (the Lauricella function F_C(a,b, c_1, ..., c_n; x_1,...,x_n))
  (for the parameter << param >> = [a, b, c_1, ..., c_n].)
  (In case of n=2, the function is called the Appell function F_4.)
  (c = [ generators,  variables ])
  (Note that for a special set of parameters, the returned differential equation)
  (is not holonomic, e.g., [[1 2 3 4]] appell4 rank ::)
  (Example: [ [1 -4 -2 5 6] ] appell4 rank ::)
 ]
] putUsages

/appell4r {
  /arg1 set
  [/in-appell4r /typev /setarg /b /n /vv /i /a /c /bb /ans /rr
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv  %% push current global environment.
  [
    /aa arg1 def
    aa isArray { } { (array appell) message (appell4) usage error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    /rr 0 def
    typev [ ArrayP ] eq
    {  /b aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [ ArrayP RingP] eq
    {  /b aa 0 get def
       /rr aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ ] eq
    {
       /b appell.b def
       /setarg 1 def
    } { } ifelse
    setarg { } { (Argument mismatch) message (appell4) usage error } ifelse
    
    [(KanGBmessage) appell.verbose] system_variable

    /n b length 2 sub def   %% Lauricella F_C^n
    
    %% vv = [(x1) (x2)]
    [
      1 1 n {
        /i set
        (x) i gensym
      } for
    ] /vv set

    rr tag 1 eq { 
      [vv from_records ring_of_differential_operators 0] define_ring
    } {
      rr ring_def
    } ifelse

    %% b = [a  b  c_1 ... c_n ]
    /a b 0 get def
    /c b 1 get def
    /bb b rest rest def    

    [ 1 1 n { 
        /i set
           [@@@.Dsymbol (x)] cat i gensym  .
           i i appellr.euler . bb i 1 sub get (1)..  sub add  
           mul

           1 n appellr.euler . (0).. a add add
           1 n appellr.euler . (0).. c add add 
           mul

           sub  
           (numerator) dc cancelCoeff dehomogenize        
           toString
      } for
    ] /ans set
    /arg1 [ans vv] def
  ] pop
  popEnv
  popVariables
  arg1
} def
%% [ [(1).. (2).. div -4 -2 5 6] ] appell4r
[(appell4r)
 [(param appell4r c)
  (array param; array c;)
  (appell4r returns an annihilating ideal for )
  (the Lauricella function F_C(a,b, c_1, ..., c_n; x_1,...,x_n))
  (for the parameter << param >> = [a, b, c_1, ..., c_n].)
  (In case of n=2, the function is called the Appell function F_4.)
  (c = [ generators,  variables ])
  (Example 1. [ [(1).. (2).. div -4 -2 5 6] ] appell4r rank ::)
  $Example 2. [(a,x1,x2) ring_of_differential_operators 0] define_ring /r set $
  $           [ [(a). (2).. div (a). (1). (1).] r] appell4r $
 ]
] putUsages


/appell.euler {
  /arg2 set
  /arg1 set
  [/n /i /n0] pushVariables
  [
    /n0 arg1 def
    /n arg2 def
    [ n0 1 n { /i set (x) i gensym  ( ) [@@@.Dsymbol (x)] cat i gensym  ( + ) } for ]  cat
    /arg1 set
  ] pop 
  popVariables
  arg1
} def

/appellr.euler {
  /arg2 set
  /arg1 set
  [/n /i /n0] pushVariables
  [
    /n0 arg1 def
    /n arg2 def
    [ n0 1 n { /i set (x) i gensym  ( ) [@@@.Dsymbol (x)] cat i gensym  
               i n eq not { ( + ) } {  } ifelse } for ]  cat
    /arg1 set
  ] pop 
  popVariables
  arg1
} def

/appell2 {
  /arg1 set
  [/in-appell2 /typev /setarg /b /n /vv /i /a /c /bb /ans
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv  %% push current global environment.
  [
    /aa arg1 def
    aa isArray { } { (array appell) message (appell2) usage error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /b aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [ ] eq
    {
       /b [1 [2 3] [4 5]] def
       /setarg 1 def
    } { } ifelse
    setarg { } { (Argument mismatch) message (appell2) usage error } ifelse

    [(KanGBmessage) appell.verbose] system_variable

    /n b 1 get length def   %% Lauricella F_A^n
    
    %% vv = [(x1) (x2)]
    [
      1 1 n {
        /i set
        (x) i gensym
      } for
    ] /vv set

    %% b = [a  [b_1 ... b_n]  [c_1 ... c_n] ]
    /a b 0 get def
    /c b 2 get def
    /bb b 1 get def    

    [ 1 1 n { 
        /i set
        [  [@@@.Dsymbol (x)] cat i gensym 
           $ ($  i i appell.euler c i 1 sub get 1 sub $) - ( $
           1 n appell.euler a $) ($ i i appell.euler bb i 1 sub get $ ) $] cat
      } for
    ] /ans set
    /arg1 [ans vv] def
  ] pop
  popEnv
  popVariables
  arg1
} def
(appell2 ) messagen-quiet
[(appell2)
 [(param appell2 c)
  (array param; array c;)
  (appell2 returns an annihilating ideal for )
  (the Lauricella function F_A(a,b_1, ..., b_n, c_1, ..., c_n; x_1,...,x_n))
  (for the parameter << param >> = [a, [b_1, ..., b_n],[c_1, ..., c_n]].)
  (In case of n=2, the function is called the Appell function F_2.)
  (c = [ generators,  variables ])
  (Example: [ [1 [-4 -2] [5 6]] ] appell2 rank ::)
 ]
] putUsages

/appell2r {
  /arg1 set
  [/in-appell2r /typev /setarg /b /n /vv /i /a /c /bb /ans /r
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv  %% push current global environment.
  [
    /aa arg1 def
    aa isArray { } { (array appell) message (appell2) usage error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    /r 0 def
    typev [ ArrayP ] eq
    {  /b aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [ ArrayP RingP] eq
    {  /b aa 0 get def
       /setarg 1 def
       /r aa 1 get def
    } { } ifelse
    typev [ ] eq
    {
       /b [1 [2 3] [4 5]] def
       /setarg 1 def
    } { } ifelse
    setarg { } { (Argument mismatch) message (appell2) usage error } ifelse

    [(KanGBmessage) appell.verbose] system_variable

    /n b 1 get length def   %% Lauricella F_A^n
    
    %% vv = [(x1) (x2)]
    [
      1 1 n {
        /i set
        (x) i gensym
      } for
    ] /vv set

    r tag 1 eq {
      [vv from_records ring_of_differential_operators 0] define_ring
    } {
      r ring_def
    } ifelse

    %% b = [a  [b_1 ... b_n]  [c_1 ... c_n] ]
    /a b 0 get def
    /c b 2 get def
    /bb b 1 get def    

    [ 1 1 n { 
        /i set
           [@@@.Dsymbol (x)] cat i gensym .
           i i appellr.euler . c i 1 sub get (1).. sub add
           mul

           1 n appellr.euler . (0).. a add add
           i i appellr.euler . (0).. bb i 1 sub get add add
           mul

           sub
           (numerator) dc cancelCoeff dehomogenize        
           toString
      } for
    ] /ans set
    /arg1 [ans vv] def
  ] pop
  popEnv
  popVariables
  arg1
} def
%%[[(1).. (2).. div [(1).. (2).. div (1).. (2).. div] [1 1]] ] appell2r rank ::
[(appell2r)
 [(param appell2r c)
  (array param; array c;)
  (appell2r returns an annihilating ideal for )
  (the Lauricella function F_A(a,b_1, ..., b_n, c_1, ..., c_n; x_1,...,x_n))
  (for the parameter << param >> = [a, [b_1, ..., b_n], [c_1, ..., c_n]].)
  (In case of n=2, the function is called the Appell function F_2.)
  (c = [ generators,  variables ])
  (Example 1. [ [(1).. (2).. div [-4 -2] [5 6]] ] appell2r rank ::)
  $Example 2. [(a,x1,x2) ring_of_differential_operators 0] define_ring /r set $
  $           [ [(a). (2).. div [(a). (1).. (3).. div] [(1). (1).]] r] appell2r $
 ]
] putUsages

( ) message-quiet ;