Return to r-interface.sm1 CVS log

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

o import OpenXM sources

%% oaku/Restriction/r-interface.sm1   1998,  4/30. 5/8. 5/12, 11/14
%% 1999, 9/9
%% lib/r-interface.sm1
%%
%% r-interface.sm1 is kept in this directory for the compatibility to
%% old demo programs and packages.  It is being merged to 
%%     resol0.sm1        cf. tower.sm1, tower-sugar.sm1, restall_s.sm1,
%%                           restall.sm1
%% 1999, 9/9 : this file is stilled being modified for vector input.
%%             wbfRoots (oxasir.sm1, intw.sm1) is used to get b-function
%%             for modules. Note that wbfRoots works only for generic
%%             weights.
%%
/r-interface.version (2.981105) def
/r-interface.verbose 0 def
/deRham.verbose 0 def
%% /BFnotruncate 1 def  Controlled from cohom.sm1

r-interface.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

[(restriction)
 [
  ( [[f1 f2 ...] [t1 t2 ...] [vars params] [k0 k1 limitdeg ]] restriction )
  (  [ 0-th cohomology group,  (-1)-th cohomology group, .... ] )
  ( )
  ( [[f1 f2 ...] [t1 t2 ...] [vars params] limitdeg] restriction )
  ( )
  (This function can be used by loading the experimental package cohom.sm1.)
  (Restriction of the D-ideal [f1 f2 ...] to t1=0, t2=0, ... is computed. )
  (vars is a list of the variables and params is a list of parameters. )
  (k0 is the minimum integral root of the b-function and k1 is the maximum)
  (integral root of the b-function. If these values are not given and)
  (they are small, then they are automatically computed. The program returns)
  ( 0-th, ..., -limitdeg-th cohomology groups.)
  ([vars params] and [k0 k1 deg] are optional arguments.)
  (If vars and params are not given, the values of the global variables)
  (BFvarlist and BFparlist will be used.)
  (   )
  (For the algorithm, see math.AG/9805006, http://xxx.langl.gov)
  (  )
  (Example 1: cf. math.AG/9801114, Example 1.4 )
  $  [[(- 2 x Dx - 3 y Dy +1) (3 y Dx^2 - 2 x Dy)] $
  $     [(x) (y)] [[(x) (y)] [ ]]] restriction  ::   $
  $[    [    0 , [   ]  ]  , [    1 , [   ]  ]  , [    1 , [   ]  ]  ] $
  $       H^0 = 0,     H^(-1)= C^1/(no relation), H^(-2)=C^1/(no relation).$
  (Example 2: )
  $[[(x Dx-1) (Dy^2)] [(y)] [[(x) (y)] [ ]]] restriction ::$
  $[    [    2 , [    -x*Dx+1 , -x*e*Dx+e ]  ]  , [    0 , [   ]  ]  ]$
  $     H^0=D_1^2/([-x Dx+1,0],[0, -x Dx + 1]),  H^(-1) = 0 $
  $     where  e^0, e^1, e^2, ..., e^(m-1) are standard basis vectors of$
  $            rank m free module (D_1)^m. D_1 is the ring of differential$
  $            opertors of one variable x.$
  (Example 3: )
  $[[(x Dx-1) (Dy^2)] [(y)] [[(x) (y)] [ ]] 0] restriction ::$
  (Example 4: )
  $[[[(0) (x^2 Dx+x)] [(Dx^2+x Dx^3) (0)]] [(x)] [[(x)] [ ]]] restriction ::$
  $In case of vector input,  RESTRICTION VARIABLES MUST APPEAR FIRST$
  $in the list of variable. We are using wbfRoots to get the roots of $
  $b-functions, so we can use only generic weight vector for now.$
]
] putUsages

/restriction {
  /arg1 set
  [/in-restriction /ppp /verbose /nnn /k0 /k1 /limitdeg
   /x-vars  /params  /mmm /zzz /rest.bfunc
   /gg  %% it is not used in restriction, but restall*.sm1 destroys gg.
   /vectorInput /wvec
  ] pushVariables
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
     /ppp arg1 def
     /verbose 1 def
     ppp 
     (restriction: argument must be an array.) 
     rest.listq pop

     /nnn ppp length def
     nnn 2 lt nnn 4 gt or
     { (restriction: too many or too few arguments) message
       (restriction) usage  error } { } ifelse

     nnn 3 eq nnn 4 eq or
     {
       %% set up global variables.
       ppp 2 get 
       (restriction: the third argument must be [vars params] or [vars]. For example, [[(x) (y)]].)
       rest.listq pop

       ppp 2 get length 2 eq { }
       { ppp 2 get length 1 eq {
         ppp 2 << ppp 2 get [ ] append  >> put
         }
         { 
          (restriction: the third argument must be [vars params]) message 
           error } ifelse
       } ifelse
       ppp 2 get 0 get (vars must be an array.) rest.listq 
                       { toString} map /x-vars set
       ppp 2 get 1 get (params must be an array.) rest.listq 
                       { toString} map /params set
     }
     {/x-vars BFvarlist def /params BFparlist def } ifelse


     
     /mmm ppp 0 get def  %% module
     /zzz ppp 1 get def  %% algebraic set (zero set)
     mmm 
     (restriction: the first argument must be list of polynomials) 
     rest.listq pop

     mmm length 0 eq {
       (restriction: the input matrix does not contain generators.) message
        error
     } { } ifelse
     mmm 0 get isArray {
       /vectorInput 1 def
     } {
       /vectorInput 0 def
     } ifelse
     %% (vectorInput=) messagen vectorInput message

     zzz 
     (restriction: the second argument must be list of polynomials)
     rest.listq pop

     [x-vars params join from_records ring_of_differential_operators 0] 
     define_ring
     vectorInput {
       mmm { {toString . dehomogenize}map } map /mmm set

       mmm { {toString} map } map /mmm set
     }{
       mmm { toString . dehomogenize } map /mmm set

       mmm { toString } map /mmm set
     } ifelse
     zzz { toString } map /zzz set

     x-vars rest.checkReserved
     params rest.checkReserved

     /BFvarlist x-vars def /BFparlist params def

     [(KanGBmessage) r-interface.verbose] system_variable


     nnn 2 eq nnn 3 eq or
     {  %% set up k0, k1 and limitdeg by computing b-functions.
        vectorInput {
          r-interface.load.oxasir.wint
          /wvec zzz { -1 } map zzz { xtoDx } map { 1 } map join def
          [mmm BFvarlist wvec] messagen ( wbfRoots ) message
          [mmm BFvarlist wvec] wbfRoots /tmp set
        }{
          [mmm zzz] messagen (bfm ) message
          mmm zzz bfm /rest.bfunc00 set
          rest.bfunc00 length 0 eq {
            (restriction: No b-function. The input may not be holonomic.) error
          } { } ifelse
          rest.bfunc00 0 get /rest.bfunc set
          (b-function is ) messagen rest.bfunc message
          rest.bfunc findIntegralRoots /tmp set
        } ifelse
        tmp length 0 eq
        { (All cohomology groups are zero.) message
           /arg1 null def
           /r-interface.sortir goto
        } { } ifelse
        tmp 0 get /k0 set
        tmp << tmp length 1 sub >> get /k1 set
        /limitdeg zzz length def
      } 
      { 
         ppp 3 get isInteger
         {
            /limitdeg ppp 3 get def
            vectorInput {
	      r-interface.load.oxasir.wint
              /wvec zzz { -1 } map zzz { xtoDx } map { 1 } map join def
              [mmm BFvarlist wvec] messagen ( wbfRoots ) message
              [mmm BFvarlist wvec] wbfRoots /tmp set
            }{
              [mmm zzz] messagen (bfm ) message
              mmm zzz bfm /rest.bfunc00 set
              rest.bfunc00 length 0 eq {
                (restriction: No b-function. The input may not be holonomic.) error
              } { } ifelse
              rest.bfunc00 0 get /rest.bfunc set
              (b-function is ) messagen rest.bfunc message
              rest.bfunc findIntegralRoots /tmp set
            } ifelse
            tmp length 0 eq
            { (All cohomology groups are zero.) message
              /arg1 null def
             /r-interface.sortir goto
            } { } ifelse
            tmp 0 get /k0 set
            tmp << tmp length 1 sub >> get /k1 set
         } { 
          ppp 3 get
          (restriction: the fourth argument must be [k0 k1 limitdeg]) 
          rest.listq pop

          ppp 3 get length 3 eq { }
          { (restriction: the fourth argument must be [k0 k1 limitdeg]) message 
            error } ifelse
          ppp 3 get 0 get /k0 set
          ppp 3 get 1 get /k1 set
          ppp 3 get 2 get /limitdeg set
         }ifelse
      } ifelse

     BFnotruncate {
       [mmm zzz k1 limitdeg] messagen ( restall1_s ) message
        mmm zzz k1 limitdeg restall1_s /arg1 set
     } {
       [mmm zzz k0 k1 limitdeg] messagen ( restall_s ) message
        mmm zzz k0 k1 limitdeg restall_s /arg1 set
     } ifelse
     /r-interface.sortir
   ] pop
   popEnv
   popVariables
   arg1
} def
  
/rest.listq {
  /arg2 set /arg1 set
  [/in-rest.listq /sss /aaa] pushVariables
  [
     /aaa arg1 def /sss arg2 def
     aaa isArray { }
     {  sss message
        error
     } ifelse
     /arg1 aaa def
   ]pop
   popVariables
  arg1
} def

/rest.checkReserved {
   % check if s is used.
  /arg1 set
  [/in-rest.checkReserved /vlist /tmp] pushVariables
  [ /vlist arg1 def
    vlist (s) position /tmp set
    tmp -1 gt
    { (s is the reserved variable.) error }
    { } ifelse
  ] pop
  popVariables
} def 

[(integration)
[
  ( [[f1 f2 ...] [t1 t2 ...] [vars params] [k0 k1 limitdeg ]] integration )
  (  [ 0-th cohomology group,  (-1)-th cohomology group, .... ] )
  ( )
  ( [[f1 f2 ...] [t1 t2 ...] [vars params] limitdeg] integration )
  ( )
  (This function can be used by loading the experimental package cohom.sm1.)
  (Integration of the D-ideal [f1 f2 ...] to t1=0, t2=0, ... is computed. )
  (vars is a list of the variables and params is a list of parameters. )
  (k0 is the minimum integral root of the b-function and k1 is the maximum)
  (integral root of the b-function. If these values are not given and)
  (they are small, then they are automatically computed. The program returns)
  ( 0-th, ..., -limitdeg-th cohomology groups.)
  ([vars params] and [k0 k1 deg] are optional arguments.)
  (If vars and params are not given, the values of the global variables)
  (BFvarlist and BFparlist will be used.)
  (The operator restriciton will be used after the laplace transformation.)
  (   )
  (For the algorithm, see math.AG/9805006, http://xxx.langl.gov)
  (  )
  (Example 1: )
  $[[(x (x-1)) (x) ] annfs 0 get 
     [(x)] [[(x)] [ ]]] integration ::$
  (Example 2: )
  $[ [(Dt - (3 t^2-x)) (Dx + t)] [(t)]
     [[(t) (x)] [ ]] 0] integration ::$
  (Example 3: )
  $[ [[(Dt - (3 t^2-x)) (0)] [ (Dx + t) (0)]] [(t)]
     [[(t) (x)] [ ]] 0] integration ::$
  $In case of vector input, INTEGRAL VARIABLES MUST APPEAR FIRST$
  $in the list of variable. We are using wbfRoots to get the roots of $
  $b-functions, so we can use only generic weight vector for now.$
]
] putUsages

/integration {
  /arg1 set
  [/in-integration /intvars /intvarsD /vars /params /inputs /aaa
   /vectorInput
  ] pushVariables
  [
     /aaa arg1 def
     /inputs aaa 0 get def
     /intvars aaa 1 get def
     /vars   aaa 2 get 0 get def
     /params aaa 2 get 1 get def
     [ vars params join from_records ring_of_differential_operators 0]
     define_ring  pop
     inputs 0 get isArray {
       /vectorInput 1 def
     }{
       /vectorInput 0 def
     } ifelse
     vectorInput {
       inputs { {toString . dehomogenize} map } map /inputs set
     }{
       inputs { toString . dehomogenize } map /inputs set
     } ifelse
     /intvarsD  intvars { @@@.Dsymbol 2 1 roll 2 cat_n } map def
     vectorInput {
       inputs { {intvars intvarsD join laplace0}map } map /inputs set
     }{
       inputs { intvars intvarsD join laplace0 } map /inputs set
     } ifelse

     aaa 0 get messagen ( ==> ) messagen inputs message  
     aaa 0 inputs put
     aaa restriction /arg1 set

  ] pop
  arg1
} def
  

[(deRham)
 [([f v] deRham c)
 (string f; string v;  f is a polynomial given by a string.)
 (This function can be used by loading the experimental package cohom.sm1. )
 (The dimensions of the deRham cohomology groups H^i(C^n - V(f),C) i=0, i=1, ..)
 (.., n are returned in c.)
 (For example, if c=[1 4 6 4], then it means that dim H^0(C^3-V(f),C) = 1,)
 (dim H^1(C^3-V(f),C) = 4, and so on.)
 (For the algorithm, see "An algorithm for de Rham cohomology groups of the)
 (complement of an affine variety via D-module computation", )
 $Journal of pure and applied algebra, 139 (1999), 201--233. math.AG/9801114$
 (  )
 (Example 0:  [(x (x-1) (x-2)) (x)] deRham )
 (Example 1: [(x y (x+y-1)(x-2)) (x,y)] deRham )
 (Example 2: [(x^3-y^2) (x,y)] deRham )
 (Example 3: [(x^3-y^2 z^2) (x,y,z)] deRham )
 (Example 4: [(x y z (x+y+z-1)) (x,y,z)] deRham )
]] putUsages
%% [(x+y+z) (x,y,z)] deRham  ---> error in bfm, 1998, 11/27
/deRham {
 /arg1 set
 [/in-deRham /f /v /vlist /vlist0 /ff0 /ff2 /ttt
  /r-interface.verbose /tower.verbose /fs.verbose /ans
 ] pushVariables
 [
   /r-interface.verbose deRham.verbose def
   /tower.verbose deRham.verbose def
   /fs.verbose deRham.verbose def
   /f arg1 0 get def
   /v arg1 1 get def
   v isArray {
     /v v {toString} map from_records def
   } {  } ifelse
   /vlist0 [v to_records pop] def
   /vlist [v to_records pop] dup { /ttt set @@@.Dsymbol ttt 2 cat_n } map
          join def
   [f v] annfs  0 get /ff0 set

    ff0 { vlist laplace0 } map /ff2 set
   [ff2 vlist0 [vlist0 [ ]]] restriction /ans set
   /arg1 ans {deRham.simp} map reverse def
 ] pop
 popVariables
 arg1
} def

%% [3 , [1, e]] ==> 1
/deRham.simp {
  /arg1 set
  [/in-deRham.simp /gg /kk] pushVariables
  [(KanGBmessage)] pushEnv
  [
    /kk arg1 0 get def
    /gg arg1 1 get def
    [(KanGBmessage) r-interface.verbose] system_variable
    gg length 0 eq {    }
    {
      kk [gg] groebner_sugar 0 get length sub /kk set
    } ifelse
    /arg1 kk def
  ] pop
  popEnv
  popVariables
  arg1
} def
  

/r-interface.load.oxasir.wint {
 [
  oxasir.sm1.loaded tag 0 eq {
    (Loading oxasir.sm1 )  messagen
    [(parse) (oxasir.sm1) pushfile] extension
  }{
  } ifelse
  intw.sm1.loaded tag 0 eq {
    (Loading intw.sm1 )  messagen
    [(parse) (intw.sm1) pushfile] extension
  }{
  } ifelse
 ] pop
} def