% $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.17 2004/05/13 05:52:53 takayama Exp $
%% hol.sm1, 1998, 11/8, 11/10, 11/14, 11/25, 1999, 5/18, 6/5. 2000, 6/8
%% rank, rrank, characteristic
%% This file is error clean.
/hol.version (2.990515) def
hol.version [(Version)] system_variable gt
{ [(This package hol.sm1 requires the latest version of kan/sm1) nl
   (Please get it from http://www.math.kobe-u.ac.jp/KAN) 
  ] cat
  error
} { } ifelse

$hol.sm1, basic package for holonomic systems (C) N.Takayama, 2000, 06/08 $ 
message-quiet

/gb.warning 0 def
/gb.oxRingStructure [ ] def
/rank.v [(x) (y) (z)] def   %% default value of v (variables).
/rank.ch [ ] def  %% characteristic variety.
/rank.verbose 0 def
/rank {
  /arg1 set
  [/in-rank /aa /typev /setarg /f /v /vsss /vddd
   /gg /wv /vd /vdweight /chv
   /one
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> rank) error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v rank.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    setarg { } { (rank : Argument mismatch) error } ifelse
    
    [(KanGBmessage) rank.verbose ] system_variable

    f { toString } map /f set  
    v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map  
    /vddd set   %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
    v { @@@.Dsymbol 2 1 roll 2 cat_n } map 
    /vd set     %% vd = [(Dx) (Dy) (Dz)]
    /vdweight 
       vd { [ 2 1 roll -1 ] } map  %% vdweight=[[(Dx) -1] [(Dy) -1] [(Dz) -1]] 
    def   
    
    [v from_records
     ring_of_differential_operators [vddd] weight_vector 0] define_ring
    f { . dehomogenize } map /f set
    [f] groebner_sugar 0 get /gg set

    /wv vddd weightv def
    gg { wv init } map /chv set  %%obtained the characteristic variety.
    /rank.ch chv def
    chv { toString } map /chv set
   
    [ v vd join from_records
      ring_of_polynomials
      [vddd]  vdweight join weight_vector
      0
    ] define_ring
    [chv {.} map] groebner_sugar 0 get { init } map /chii set

    /rank.chii chii def
    rank.verbose { chii message } {  } ifelse
    v {[ 2 1 roll . (1).]} map /one set 
    %% [[(x). (1).] [(y). (1).] [(z). (1).]]
    %% chii { one replace } map  %% buggy code.
    %% Arg of hilb should be a reduced GB.
    [chii { one replace } map] groebner 0 get
    vd hilb /arg1 set
  ] pop
  popEnv
  popVariables
  arg1
} def


[(rank)
 [( a rank b)
  ( array a;  number b)
  (Example 1 : )
  $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rank :: $
  (Example 2 : )
  $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] rank :: $
 ]
] putUsages
(rank ) messagen-quiet

/characteristic.verbose 0 def
/characteristic.v [(x) (y) (z)] def
/characteristic.ch [ ] def
/ch { characteristic } def
/characteristic {
  /arg1 set
  [/in-rank /aa /typev /setarg /f /v /vsss /vddd
   /gg /wv /vd  /chv
   /one
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> characteristic) error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v characteristic.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    setarg { } { (rank : Argument mismatch) error } ifelse
    
    [(KanGBmessage) characteristic.verbose ] system_variable

    f { toString } map /f set  
    v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map  
    /vddd set   %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
    v { @@@.Dsymbol 2 1 roll 2 cat_n } map 
    /vd set     %% vd = [(Dx) (Dy) (Dz)]
    
    [v from_records
     ring_of_differential_operators [vddd] weight_vector 0] define_ring
    f { . dehomogenize } map /f set
    [f] groebner_sugar 0 get /gg set

    /wv vddd weightv def
    gg { wv init } map /chv set
    /characteristic.ch [chv] def
%%    gg { wv init toString} map /chv set  %%obtained the characteristic variety.
%%    /characteristic.ch chv def
   
%%    [ v vd join from_records
%%      ring_of_polynomials
%%      [vddd] weight_vector
%%      0
%%    ] define_ring
%%    [chv {.} map] groebner_sugar 0 get /characteristic.ch set

    characteristic.ch /arg1 set
  ] pop
  popEnv
  popVariables
  arg1
} def

[(characteristic)
 [( a characteristic b)
  ( array a;  number b)
  (b is the generator of the characteristic variety of a.)
  (For the algorithm, see Japan J. of Industrial and Applied Math., 1994, 485--497.)
  (Example 1 : )
  $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] characteristic :: $
  (Example 2 : )
  $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] characteristic :: $
 ]
] putUsages
(characteristic ) messagen-quiet
[(ch)
 [(ch is the abbreviation of characteristic.)
  ( a ch b)
  ( array a;  number b)
  (b is the generator of the characteristic variety of a.)
  (For the algorithm, see, Japan J. of Industrial and Applied Math., 1994, 485--497.)
  (Example 1 : )
  $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] ch :: $
  (Example 2 : )
  $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] ch :: $
 ]
] putUsages
(ch ) messagen-quiet

%%%% developing rrank.sm1
/rrank.v [(x) (y) (z)] def   %% default value of v (variables).
/rrank.init [ ] def  %% initial ideal.
/rrank.verbose 0 def
/rrank {
  /arg1 set
  [/in-rrank /aa /typev /setarg /f /v /vsss /vddd
   /gg /wv /vd /vdweight
   /one /i /chv
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> rrank) error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v rrank.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    setarg { } { (rrank : Argument mismatch) error } ifelse
    
    [(KanGBmessage) rrank.verbose ] system_variable

    f { toString } map /f set  
    v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map  

    v { @@@.Dsymbol 2 1 roll 2 cat_n } map 
    /vd set     %% vd = [(Dx) (Dy) (Dz)] , v = [(x) (y) (z)]
    /vdweight 
      [ 0 1 v length 1 sub { /i set v i get << 0 i sub >>
                                    vd i get << i >> } for ]
    def   
    rrank.verbose { vdweight message } { } ifelse
    
    [v from_records
     ring_of_differential_operators [vdweight] weight_vector 0] define_ring
    f { . dehomogenize homogenize } map /f set
    [f] groebner 0 get {dehomogenize} map /gg set

    /wv vdweight weightv def
    gg { wv init } map /rrank.init set  %%obtained the initial ideal
    rrank.init {toString} map /chv set 
    /arg1 [chv v] rank def
  ] pop
  popEnv
  popVariables
  arg1
} def


[(rrank)
 [( a rrank b)
  ( array a;  number b)
  (It computes the holonomic rank for regular holonomic system.)
  (For the algorithm, see Grobner deformations of hypergeometric differential equations, 1999, Springer.)
  (Chapter 2.)
  (Example 1 : )
  $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rrank :: $
 ]
] putUsages
(rrank ) messagen-quiet

/gb.v 1 def
/gb.verbose 0 def
/gb.options [ ] def
/gb.characteristic 0 def
/gb.homogenized 0 def
/gb.autoHomogenize 1 def
/gb {
  /arg1 set
  [/in-gb /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /rr /mm
   /degreeShift  /env2
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> gb) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v gb.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP RingP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /setarg 1 def
    } { } ifelse

    /env1 getOptions def

    setarg { } { (gb : Argument mismatch) error } ifelse
    
    [(KanGBmessage) gb.verbose ] system_variable

    %%% Start of the preprocess
    v tag RingP eq {
       /rr v def 
    }{
      f getRing /rr set
    } ifelse
    %% To the normal form : matrix expression.
    f gb.toMatrixOfString /f set
    /mm gb.itWasMatrix def

    rr tag 0 eq 
    v isInteger not 
    or {
      %% Define our own ring
      v isInteger {
        (Error in gb: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
        gb.characteristic] define_ring
        /termorder 1 def
      }{
       degreeShift isInteger {
         [v ring_of_differential_operators 
          wv weight_vector
         gb.characteristic] define_ring
         wv gb.isTermOrder /termorder set
       }{
         [v ring_of_differential_operators 
          wv weight_vector
          gb.characteristic
          [(degreeShift) degreeShift]
          ] define_ring
         wv gb.isTermOrder /termorder set
       } ifelse
      } ifelse
    } {
      %% Use the ring structre given by the input.
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse
    %%% Enf of the preprocess

    termorder {
      /gb.homogenized 0 def
    }{
     /gb.homogenized 1 def
    } ifelse
    gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
    termorder {
      f { {,,, dehomogenize} map } map /f set
      [f gb.options] groebner_sugar 0 get /gg set
    }{
      f { {,,, dehomogenize} map} map /f set
      gb.autoHomogenize {
        f fromVectors { homogenize } map /f set
      } {  } ifelse
      [f gb.options] groebner 0 get /gg set
    }ifelse
    wv isInteger {
      /ans [gg gg {init} map] def
    }{
      /ans [gg gg {wv 0 get weightv init} map] def
    }ifelse

    %% Postprocess : recover the matrix expression.
    mm {
      ans { /tmp set [mm tmp] toVectors } map
      /ans set
    }{ }
    ifelse
    ans getRing (oxRingStructure) dc /gb.oxRingStructure set
    %% 
    env1 restoreOptions  %% degreeShift changes "grade"

    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(gb ) messagen-quiet 

/pgb {
  /arg1 set
  [/in-pgb /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /rr /mm
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { (<< array >> pgb) error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v gb.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (pgb : Argument mismatch) error } ifelse
    
    [(KanGBmessage) gb.verbose ] system_variable

    %%% Start of the preprocess
    f getRing /rr set
    %% To the normal form : matrix expression.
    f gb.toMatrixOfString /f set
    /mm gb.itWasMatrix def

    rr tag 0 eq {
      %% Define our own ring
      v isInteger {
        (Error in pgb: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_polynomials
        gb.characteristic] define_ring
        /termorder 1 def
      }{
        [v ring_of_polynomials
         wv weight_vector
        gb.characteristic] define_ring
        wv gb.isTermOrder /termorder set
      } ifelse
    } {
      %% Use the ring structre given by the input.
      v isInteger not {
        gb.warning {
         (Warning : the given ring definition is not used.) message
        } { } ifelse
      } {  } ifelse
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse
    %%% Enf of the preprocess

    gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
    termorder {
      f { {. dehomogenize} map } map /f set
      [(UseCriterion1) 1] system_variable
      [f gb.options] groebner_sugar 0 get /gg set
      [(UseCriterion1) 0] system_variable
    }{
      f { {. dehomogenize} map} map /f set
      f fromVectors { homogenize } map /f set
      [(UseCriterion1) 1] system_variable
      [f gb.options] groebner 0 get /gg set
      [(UseCriterion1) 0] system_variable
    }ifelse
    wv isInteger {
      /ans [gg gg {init} map] def
    }{
      /ans [gg gg {wv 0 get weightv init} map] def
    }ifelse

    %% Postprocess : recover the matrix expression.
    mm {
      ans { /tmp set [mm tmp] toVectors } map
      /ans set
    }{ }
    ifelse
    %% 

    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def

/pgb.old {
  /arg1 set
  [/in-pgb /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { (array pgb) message (pgb) usage error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v gb.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (pgb : Argument mismatch) message error } ifelse
    
    [(KanGBmessage) gb.verbose ] system_variable

    %% Input must not be vectors.
    f { toString } map /f set  

    wv isInteger {        
      [v ring_of_polynomials
      0] define_ring
      /termorder 1 def
    }{
      [v ring_of_polynomials
       wv weight_vector
      0] define_ring
      wv gb.isTermOrder /termorder set
    } ifelse
    termorder {
      f { . dehomogenize } map /f set
      [(UseCriterion1) 1] system_variable
      [f] groebner_sugar 0 get /gg set
      [(UseCriterion1) 0] system_variable
    }{
      f { . dehomogenize homogenize} map /f set
      [(UseCriterion1) 1] system_variable
      [f] groebner 0 get /gg set
      [(UseCriterion1) 0] system_variable
    }ifelse
    wv isInteger {
      /ans [gg gg {init} map] def
    }{
      /ans [gg gg {wv 0 get weightv init} map] def
    }ifelse
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(pgb ) messagen-quiet 

/gb.toMatrixOfString {
  /arg1 set
  [/in-gb.toMatrixOfString /ff /aa /ans] pushVariables
  [
     /aa arg1 def
     aa length 0 eq { /ans [ ] def /gb.toMatrixOfString.LLL goto }{ } ifelse
     aa 0 get isArray {
       /gb.itWasMatrix aa 0 get length def
     }{
       /gb.itWasMatrix 0 def 
     } ifelse
     aa {
       /ff set
       ff isArray {
         ff {toString} map /ff set
       }{
         [ff toString] /ff set
       } ifelse
       ff
     } map /ans set
    /gb.toMatrixOfString.LLL
    /arg1 ans def
  ] pop
  popVariables
  arg1
} def
[(gb.toMatrixOfString)
[(It translates given input into a matrix form which is a data structure)
 (for computations of kernel, image, cokernel, etc.)
 (gb.itWasMatrix is set to the length of the input vector.)
 $Example 1: $
 $  [ (x). (y).] gb.toMatrixOfString ==> [[(x)] [(y)]] $
 $  gb.itWasMatrix is 0.$
 $Example 2: $
 $  [ [(x). (1).] [(y). (0).]] gb.toMatrixOfString ==>  [ [(x) (1)] [(y) (0)]] $ 
 $  gb.itWasMatrix is 2.$
]] putUsages

/gb.toMatrixOfPoly {
  /arg1 set
  [/in-gb.toMatrixOfPoly /ff /aa /ans] pushVariables
  [
     /aa arg1 def
     aa length 0 eq { /ans [ ] def /gb.toMatrixOfPoly.LLL goto }{ } ifelse
     aa 0 get isArray {
       /gb.itWasMatrix aa 0 get length def
     }{
       /gb.itWasMatrix 0 def 
     } ifelse
     aa {
       /ff set
       ff isArray {
       }{
         [ff] /ff set
       } ifelse
       ff
     } map /ans set
    /gb.toMatrixOfPoly.LLL
    /arg1 ans def
  ] pop
  popVariables
  arg1
} def
[(gb.toMatrixOfPoly)
[(It translates given input into a matrix form which is a data structure)
 (for computations of kernel, image, cokernel, etc.)
 (gb.itWasMatrix is set to the length of the input vector.)
 $Example 1: $
 $  [ (x). (y).] gb.toMatrixOfPoly ==> [[(x)] [(y)]] $
 $  gb.itWasMatrix is 0.$
 $Example 2: $
 $  [ [(x). (1).] [(y). (0).]] gb.toMatrixOfPoly ==>  [ [(x) (1)] [(y) (0)]] $ 
 $  gb.itWasMatrix is 2.$
]] putUsages

/gb.getWeight {
  /arg1 set
  [/in-gb.getWeight /rr /ww /vv /ans /nn /ii] pushVariables
  [(CurrentRingp)] pushEnv
  [
     /rr arg1 def
     rr ring_def
     getVariableNames /vv set
     [(orderMatrix)] system_variable 0 get /ww set
     /nn vv length 1 sub def
     [0 1 nn {
        /ii set
        ww ii get 0 eq {
        } {
          vv ii get
          ww ii get
        } ifelse
      } for
     ] /ans set
     /arg1 [ans] def
  ] pop
  popEnv
  popVariables
  arg1
} def
[(gb.getWeight)
[(ring gb.getWeight wv)
 (It gets the weight vector field of the ring ring.)
]] putUsages


/gb.isTermOrder {
  /arg1 set
  [/in-gb.isTermOrder /vv /ww /yes /i /j] pushVariables
  [
     /vv arg1 def
     /yes 1 def
     0 1 vv length 1 sub {
       /i set
       /ww vv i get def
       0 1 ww length 1 sub {
          /j set
          ww j get isInteger {
            ww j get 0 lt { /yes 0 def } { } ifelse
          }{ } ifelse
       }for
     }for
     /arg1 yes def
  ] pop
  popVariables
  arg1
} def
[(gb)
 [(a gb b)
  (array a; array b;)
  (b : [g ii];  array g; array in; g is a Grobner basis of f)
  (             in the ring of differential operators.)
   $            ii is the initial ideal in case of w is given or <<a>> belongs$
   $            to a ring. In the other cases, it returns the initial monominal.$
  (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
  (a : [f v];   array f; string v;  v is the variables. )
  (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
  (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
  (                array ds; ds is the degree shift )
  (  )
  (gb.authoHomogenize 1 [default])
  (gb.oxRingStructure )
  ( )
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 ] ] ] gb pmat ; $
  (Example 2: )
  (To put h=1, type in, e.g., )
  $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
  $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] gb /gg set gg dehomogenize pmat ;$
  (  )
  $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 (Dy) 1] ] ] gb pmat ; $
  (  )
  $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ] ] gb pmat ; $
  (  )
  $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ]  [[0 1] [-3 1] ] ] gb pmat ; $
  (  )
  (cf. gb, groebner, groebner_sugar, syz. )
]] putUsages

[(pgb)
 [(a pgb b)
  (array a; array b;)
  (b : [g ii];  array g; array in; g is a Grobner basis of f)
  (             in the ring of polynomials.)
  $             ii is the initial ideal in case of w is given or <<a>>belongs$
  $             to a ring. In the other cases, it returns the initial monominal.$
  (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
  (a : [f v];   array f; string v;  v is the variables.)
  (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
  $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
  $           [ [(x^2+y^2-4). (x y -1).] ] pgb :: $
  $Example 2: [ [(x^2+y^2) (x y)]   (x,y)  [ [(x) -1 (y) -1] ] ] pgb :: $
  (cf. gb, groebner, groebner_sugar, syz. )
]] putUsages


%/syz.v 1 def
/syz.v 1 def
/syz.verbose 0 def
/syz {
  /arg1 set
  [/in-syz /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
   /rr /mm
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { (<< array >> syz) error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v syz.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP RingP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP RingP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (syz : Argument mismatch) error } ifelse
    
    [(KanGBmessage) syz.verbose ] system_variable



    %%% Start of the preprocess
    v tag RingP eq {
      /rr v def
    }{
       f getRing /rr set
    } ifelse
    %% To the normal form : matrix expression.
    f gb.toMatrixOfString /f set
    /mm gb.itWasMatrix def
    mm 0 gt {
      /vectorInput 1 def
    }{
      /vectorInput 1 def
    } ifelse

    rr tag 0 eq {
      %% Define our own ring
      v isInteger {
        (Error in syz: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
        0] define_ring
        /termorder 1 def
      }{
        [v ring_of_differential_operators 
         wv weight_vector
        0] define_ring
        wv gb.isTermOrder /termorder set
      } ifelse
    }{
      %% Use the ring structre given by the input.
      v isInteger not {
        gb.warning {
         (Warning : the given ring definition is not used.) message
        } { } ifelse
      } {  } ifelse
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse
    %%% Enf of the preprocess

    termorder {
      f { {. dehomogenize} map } map /f set
      [f [(needBack) (needSyz)]] groebner_sugar /ggall set
      ggall 2 get /gg set
    }{
      f { {. dehomogenize } map homogenize } map /f set
      [f [(needBack) (needSyz)]] groebner /ggall set 
      ggall 2 get /gg set
    }ifelse
    vectorInput {
      /vsize f 0 get length def  %% input vector size.
      /gtmp ggall 0 get def
       [vsize gtmp] toVectors /gtmp set
       ggall 0 gtmp put
    }{  } ifelse
      /arg1 [gg dehomogenize ggall] def
  ] pop
  popEnv
  popVariables
  arg1
} def
(syz ) messagen-quiet 

[(syz)
 [(a syz [b c])
  (array a; array b; array c)
  (b is a set of generators of the syzygies of f.)
  (c = [gb, backward transformation, syzygy without dehomogenization].)
  (See groebner.)
  (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
  (a : [f v];   array f; string v;  v is the variables.)
  (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
  ( v may be a ring object. )
  $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
  $           [ [(x^2+y^2-4). (x y -1).] ] syz :: $
  $Example 2: [ [(x^2+y^2) (x y)]   (x,y)  [ [(x) -1 (y) -1] ] ] syz :: $
  $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 ] ] ] syz pmat ; $
  $Example 4:  [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
  $             [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
  $Example 5:  [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
  $              (x,y) ] syz pmat ;$
  $Example 6:  [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
  $              (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
  $Example 7:  [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
  $              [(x) (y)]] syz pmat ;$
]] putUsages


%%%%%%%%%%%%%%%%%% package fs  %%%%%%%%%%%%%%%%%%%%%%%
[(genericAnn)
 [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
   (L1, ..., Lm are annihilating ideal for f^s.)
   (f is a polynomial of v1, ..., vn)
   (<string> | <poly>  f, s, v1, ..., vn ; <poly>  L1, ..., Lm )
   $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
 ]
] putUsages ( genericAnn ) messagen-quiet
/fs.verbose 0 def
/genericAnn {
  /arg2 set /arg1 set
  [/in-genericAnn /f /vlist /s  /vvv /nnn /rrr
   /v1  /ops /ggg /ggg0 
   ] pushVariables
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
    /f arg1 def  /vlist arg2 def
    f toString /f set
    vlist { toString } map /vlist set
    [(KanGBmessage) fs.verbose] system_variable
    /s vlist 0 get def
    /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
         s nnn 2 add cat_n def
    fs.verbose { vvv message } {  }ifelse
    [vvv ring_of_differential_operators
     [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
   
    [ (_u*_t). f . sub  (_u*_v-1). ]
    vlist rest { /v1 set  
%%D-clean   f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
        f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
        @@@.Dsymbol v1 2 cat_n . add } map
    join
    /ops set
    ops {[[(h). (1).]] replace } map /ops set
    fs.verbose { ops message  } {  }ifelse
    [ops] groebner_sugar 0 get /ggg0 set
    fs.verbose { ggg0 message } { } ifelse
    ggg0 [(_u) (_v)] eliminatev
%%D-clean        { [(_t).] [ (D_t).] [s .] distraction 
        { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction 
          [[s . << (0). s . sub (1). sub >>]] replace
         } map /arg1 set
  ] pop
  popEnv
  popVariables
  arg1
} def

%% Find differential equations for  f^(m), r0 the minimal integral root.
[(annfs)
 [( [ f v m r0] annfs g )
  (It returns the annihilating ideal of f^m where r0 must be smaller)
  (or equal to the minimal integral root of the b-function.)
  (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
  (where r0 is the minial integral root of b.)
  (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
  (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
  $           It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
  (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
  $           It returns the annihilating ideal of f^r0 and [r0, b-function]$
  $           where r0 is the minimal integral root of the b-function.$
  (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
  (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
  (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
  (            (t,x1,x2,x3) -1 -2] annfs :: )
  (           Note that the example 4 uses huge memory space.)
]] putUsages
( annfs ) messagen-quiet
/annfs.verbose fs.verbose def
/annfs.v [(x) (y) (z)] def
/annfs.s (_s) def
%% The first variable must be s.
/annfs {
  /arg1 set
  [/in-annfs /aa /typev /setarg  /v /m /r0 /gg /ss /fs /gg2
   /ans /vtmp /w2 /velim /bbb /rrr /r0
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> annfs) error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    /r0 [ ] def 
    /m  [ ]  def
    /v annfs.v def
    aa 0 << aa 0 get toString >> put
    typev [ StringP ] eq
    {  /f aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [StringP StringP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /setarg 1 def
    } { } ifelse
    typev [StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [StringP ArrayP IntegerP IntegerP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /m aa 2 get def
       /r0 aa 3 get def
       /setarg 1 def
    } { } ifelse
    typev [StringP StringP IntegerP IntegerP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /m aa 2 get def
       /r0 aa 3 get def
       /setarg 1 def
    } { } ifelse
    setarg 1 eq { } { (annfs : wrong argument) error } ifelse

    [annfs.s] v join /v set

    /ss v 0 get def
    annfs.verbose {
       (f, v, s, f^{m}, m+r0 = ) messagen
       [ f  (, ) v  (, )  ss  (, ) 
         (f^) m (,) m (+)  r0 ] {messagen} map ( ) message
    } { } ifelse

    f v genericAnn /fs set

    annfs.verbose {
      (genericAnn is ) messagen fs message
    } { } ifelse
    [(KanGBmessage) annfs.verbose] system_variable

    m isArray {
      %% Now, let us find  the b-function. /vtmp /w2 /velim /bbb /rrr /r0
      v rest { /vtmp set vtmp  @@@.Dsymbol vtmp 2 cat_n } map /velim set
      velim { 1 } map /w2 set
      annfs.verbose { w2 message } {  } ifelse
      [v from_records ring_of_differential_operators 
       [w2] weight_vector 0] define_ring
      [ fs { toString . } map [ f toString . ] join ]
      groebner_sugar 0 get velim eliminatev 0 get /bbb set
      [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
      bbb toString . [[annfs.s . (s).]] replace /bbb set
      annfs.verbose { bbb message } {  } ifelse
      bbb findIntegralRoots  /rrr set
      rrr 0 get /r0 set  %% minimal integral root.
      annfs.verbose { rrr message } {  } ifelse
      fs 0 get (ring) dc ring_def
      fs { [[annfs.s . r0 toString .]] replace } map /ans set
      /ans [ans [r0 bbb]] def
      /annfs.label1 goto
    } { } ifelse
    m 0 ge {
      (annfs works only for getting annihilating ideal for f^(negative))
      error
    } { } ifelse
    r0 isArray {
      [(Need to compute the minimal root of b-function) nl
       (It has not been implemented.) ] cat
      error
    } {  } ifelse

    [v from_records ring_of_differential_operators 0] define_ring
    fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace} 
       map /gg set
    annfs.verbose { gg message } { } ifelse

    [ [f . << m r0 sub >> npower ] gg join  
      [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
    
    gg2 { 0 get } map /ans set
    /ans ans { dup (0). eq {pop} { } ifelse } map def

    /annfs.label1
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1 
} def
  
/genericAnnWithL.s (s) def
/annfs.verify 0 def
/genericAnnWithL {
  /arg1 set
  [/in-genericAnnWithL /aa /typev /setarg  /v /m /r0 /gg /ss /fs /gg2
   /ans /vtmp /w2 /velim /bbb /rrr /r0  /myL /mygb /jj
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> annfs) error } ifelse
    /setarg 0 def
    aa { tag } map /typev set
    /r0 [ ] def 
    /m  [ ]  def
    /v annfs.v def
    aa 0 << aa 0 get toString >> put
    typev [ StringP ] eq
    {  /f aa 0 get def
       /setarg 1 def
    } { } ifelse
    typev [StringP StringP] eq
    {  /f aa 0 get def
       /v [ aa 1 get to_records pop ] def
       /setarg 1 def
    } { } ifelse
    typev [StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse

    [genericAnnWithL.s] v join /v set

    /ss v 0 get def
    annfs.verbose {
       (f, v, s, f^{m}, m+r0 = ) messagen
       [ f  (, ) v  (, )  ss  (, ) 
         (f^) m (,) m (+)  r0 ] {messagen} map ( ) message
    } { } ifelse

    f v genericAnn /fs set

    annfs.verbose {
      (genericAnn is ) messagen fs message
    } { } ifelse
    [(KanGBmessage) annfs.verbose] system_variable

    m isArray {
      %% Now, let us find  the b-function. /vtmp /w2 /velim /bbb /rrr /r0
      v rest { /vtmp set vtmp  @@@.Dsymbol vtmp 2 cat_n } map /velim set
      velim { 1 } map /w2 set
      annfs.verbose { w2 message } {  } ifelse
      [v from_records ring_of_differential_operators 
       [w2] weight_vector 0] define_ring

      [ [ f toString . ] fs { toString . } map join [(needBack)]]
      groebner_sugar /mygb set
      mygb 0 get velim eliminatev 0 get /bbb set
      mygb 0 get bbb position /jj set
      mygb 1 get jj get 0 get /myL set

      annfs.verbose { bbb message } {  } ifelse

      annfs.verify {
        (Verifying L f - b belongs to genericAnn(f)) message
        [(Homogenize) 0] system_variable
        << myL f . mul bbb sub >> 
        [fs { toString . } map] groebner_sugar 0 get
        reduction 0 get message
        (Is it zero? Then it's fine.) message
      } { } ifelse

      /ans [bbb [myL fs] ] def
      /annfs.label1 goto
    } { } ifelse

    /annfs.label1
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1 
} def


[(genericAnnWithL)
[$[f v] genericAnnWithL [b [L I]]$
 $String f,v; poly b,L; array of poly I;$
 $f is a polynomial given by a string. v is the variables.$
 $ v must not contain names  s, e.$
 $b is the b-function (Bernstein-Sato polynomial) for f and$
 $ L is the operator satisfying L f^{s+1} = b(s) f^s $
 $ I is the annihilating ideal of f^s.$
 $cf. bfunction, annfs, genericAnn.$
 $Example 1:  [(x^2+y^2) (x,y)] genericAnnWithL ::$
 $Example 2:  [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
 $Example 3:  [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
]] putUsages

/reduction*.noH 0 def
/reduction* {
  /arg1 set
  [/in-reduction* /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
   /opt
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { ( << array >> reduction*) error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [StringP ArrayP ArrayP] eq
    typev [ArrayP ArrayP ArrayP] eq or
    typev [PolyP ArrayP ArrayP] eq or
    {  /h aa 0 get def
       /f aa 1 get def
       /v aa 2 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [StringP ArrayP ArrayP ArrayP] eq
    typev [ArrayP ArrayP ArrayP ArrayP] eq or
    typev [PolyP ArrayP ArrayP ArrayP] eq or
    {  /h aa 0 get def
       /f aa 1 get def
       /v aa 2 get from_records def
       /wv aa 3 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (reduction* : Argument mismatch) error } ifelse
    
    [(KanGBmessage) gb.verbose ] system_variable

    %%% Start of the preprocess
    f getRing /rr set
    

    rr tag 0 eq {
      %% Define our own ring
      v isInteger {
        (Error in reduction*: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
        0] define_ring
        /termorder 1 def
      }{
        [v ring_of_differential_operators 
         wv weight_vector
        0] define_ring
        wv gb.isTermOrder /termorder set
      } ifelse
    } {
      %% Use the ring structre given by the input.
      v isInteger not {
        gb.warning {
         (Warning : the given ring definition is not used.) message
        } { } ifelse
      } {  } ifelse
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse
    %%% Enf of the preprocess

    f 0 get isArray {
      /size f 0 get length def
      f { { toString . } map } map /f set
      f fromVectors /f set
    }{
      /size -1 def
      f { toString . } map /f set
    } ifelse 

    h isArray {
      h { toString . } map /h set
      [h] fromVectors 0 get /h set
    }{ 
      h toString . /h set
    } ifelse
    f { toString . } map /f set
    getOptions /opt set
    [(ReduceLowerTerms) 1] system_variable
    reduction*.noH {
      h f reduction-noH /ans set
    } {
      h f reduction /ans set
    } ifelse
    opt restoreOptions
    size -1 eq not {
      [size ans 0 get] toVectors /a0 set
      [size ans 3 get] toVectors /a3 set
      /ans [a0 ans 1 get ans 2 get a3] def
    } { } ifelse
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1  
} def 


[(reduction*)
[([f base v] reduction* [h c0 syz input])
 ([f base v weight] reduction* [h c0 syz input])
 (reduction* is an user interface for reduction and reduction-noH.)
 (If reduction*.noH is one, then reduction-noH will be called.)
 (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
 (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
 (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
]] putUsages



%%  2000, 6/7,  at Sevilla, Hernando Colon
%% macros that deal with homogenized inputs.
%%  Sample:  [ [(h+x). (x^3).] [(x). (x).]] /ff set
%%           [(Homogenize_vec) 0] system_varialbe
%%           (grade) (grave1v) switch_function
%%  YA homogenization:  [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
%%                          4+0         3+1      2+0    1+1
/gb_h {
  /arg1 set
  [/in-gb_h /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /rr /mm
   /gb_h.opt
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
  [

    /aa arg1 def
    gb.verbose { (Getting in gb_h) message } {  } ifelse
    aa isArray { } { ( << array >> gb_h) error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v gb.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP RingP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (gb_h : Argument mismatch) error } ifelse
    
    [(KanGBmessage) gb.verbose ] system_variable

    %%% Start of the preprocess
    v tag RingP eq {
      /rr v def
    }{
      f getRing /rr set
    } ifelse
    %% To the normal form : matrix expression.
    f gb.toMatrixOfString /f set
    /mm gb.itWasMatrix def

    rr tag 0 eq {
      %% Define our own ring
      v isInteger {
        (Error in gb_h: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
        0] define_ring
        /termorder 1 def
      }{
        [v ring_of_differential_operators 
         wv weight_vector
        0] define_ring
        wv gb.isTermOrder /termorder set
      } ifelse
    } {
      %% Use the ring structre given by the input.
      v isInteger not {
        gb.warning {
         (Warning : the given ring definition is not used.) message
        } { } ifelse
      } {  } ifelse
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse
    getOptions /gb_h.opt set
    (grade) (module1v) switch_function
    [(Homogenize_vec) 0] system_variable
    %%% End of the preprocess

    gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
    termorder {
      f { {. } map } map /f set
      [f gb.options] groebner 0 get /gg set %% Do not use sugar.
    }{
      f { {. } map} map /f set
      f fromVectors /f set
      [f gb.options] groebner 0 get /gg set
    }ifelse
    wv isInteger {
      /ans [gg gg {init} map] def
    }{
      /ans [gg gg {wv 0 get weightv init} map] def
    }ifelse

    %% Postprocess : recover the matrix expression.
    mm {
      ans { /tmp set [mm tmp] toVectors } map
      /ans set
    }{ }
    ifelse
    gb_h.opt restoreOptions 
    gb.verbose { (Getting out of gb_h) message } {  } ifelse
    %% 

    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(gb_h ) messagen-quiet
[(gb_h)
 [(a gb_h b)
  (array a; array b;)
  (b : [g ii];  array g; array in; g is a Grobner basis of f)
  (             in the ring of homogenized differential operators.)
  ( The input must be homogenized properly.)
  ( Inproper homogenization may cause an infinite loop.)
  ( Each element of vectors must be homogenized. If you are using )
  ( non-term orders, all elements of vectors must have the same degree with)
  ( a proper degree shift vector.)
   $            ii is the initial ideal in case of w is given or <<a>> belongs$
   $            to a ring. In the other cases, it returns the initial monominal.$
  $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$ 
  (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
  (a : [f v];   array f; string v;  v is the variables. )
  (a : [f r];   array f; ring r )
  (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
  (  )
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
  $             [ [ (Dx) 1 ] ] ] gb_h pmat ; $
  $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
  $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
  $              [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
  $  Infinite loop: see by [(DebugReductionRed) 1] system_variable$
  $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
  $              [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
  $  This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
  (  )
  (cf. gb, groebner, syz_h. )
]] putUsages

/syz_h {
  /arg1 set
  [/in-syz_h /aa /typev /setarg /f /v 
   /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
   /rr /mm
   /syz_h.opt
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [

    /aa arg1 def
    aa isArray { } { (<< array >> syz_h) error } ifelse
    /setarg 0 def
    /wv 0 def
    aa { tag } map /typev set
    typev [ ArrayP ] eq
    {  /f aa 0 get def
       /v syz.v def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP RingP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /setarg 1 def
    } { } ifelse

    setarg { } { (syz_h : Argument mismatch) error } ifelse
    
    [(KanGBmessage) syz.verbose ] system_variable



    %%% Start of the preprocess
    v tag RingP eq {
       /rr v def 
    }{
      f getRing /rr set
    } ifelse
    %% To the normal form : matrix expression.
    f gb.toMatrixOfString /f set
    /mm gb.itWasMatrix def
    mm 0 gt {
      /vectorInput 1 def
    }{
      /vectorInput 1 def
    } ifelse

    rr tag 0 eq {
      %% Define our own ring
      v isInteger {
        (Error in syz_h: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
        0] define_ring
        /termorder 1 def
      }{
        [v ring_of_differential_operators 
         wv weight_vector
        0] define_ring
        wv gb.isTermOrder /termorder set
      } ifelse
    }{
      %% Use the ring structre given by the input.
      v isInteger not {
        gb.warning {
         (Warning : the given ring definition is not used.) message
        } { } ifelse
      } {  } ifelse
      rr ring_def
      /wv rr gb.getWeight def
      wv gb.isTermOrder /termorder set
    } ifelse

    getOptions /syz_h.opt set
    (grade) (module1v) switch_function
    [(Homogenize_vec) 0] system_variable
    %%% End of the preprocess

    termorder {
      f { {. } map } map /f set
      [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
      ggall 2 get /gg set
    }{
      f { {. } map  } map /f set
      [f [(needBack) (needSyz)]] groebner /ggall set 
      ggall 2 get /gg set
    }ifelse
    vectorInput {
      /vsize f 0 get length def  %% input vector size.
      /gtmp ggall 0 get def
       [vsize gtmp] toVectors /gtmp set
       ggall 0 gtmp put
    }{  } ifelse

    syz_h.opt restoreOptions 
    %% 

      /arg1 [gg ggall] def
  ] pop
  popEnv
  popVariables
  arg1
} def
(syz_h ) messagen-quiet

[(syz_h)
 [(a syz_h [b c])
  (array a; array b; array c)
  (b is a set of generators of the syzygies of f in the ring of)
  (homogenized differential operators.)
  ( The input must be homogenized properly.)
  ( Inproper homogenization may cause an infinite loop.)
  ( Each element of vectors must be homogenized. If you are using )
  ( non-term orders, all elements of vectors must have the same degree with)
  ( a proper degree shift vector.)
  (c = [gb, backward transformation, syzygy without dehomogenization].)
  (See gb_h.)
  $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$ 
  (a : [f ];    array f;  f is a set of generators of an ideal in a ring.)
  (a : [f v];   array f; string v;  v is the variables.)
  (a : [f r];   array f; ring r )
  (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
  $             [ [ (Dx) 1 ] ] ] syz_h pmat ; $
  $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
  $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
  $              [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
  $  Infinite loop: see by [(DebugReductionRed) 1] system_variable$
  $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
  $              [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
  $             [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
  $  This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
  $Example 5:  [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
  $              [(x) (y)]] syz pmat ;$
]] putUsages


/isSameIdeal {
  /arg1 set
  [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
  [(CurrentRingp)] pushEnv
  [
    /aa arg1 def
    %% comparison of hilbert series has not yet been implemented.
    aa length 3 eq {    }
    { ([ii jj vv] isSameIdeal) error } ifelse
    gb.verbose { (Getting in isSameIdeal) message } { } ifelse
    /ii aa 0 get def
    /jj aa 1 get def
    /vv aa 2 get def
    ii length 0 eq jj length 0 eq and 
    { /ans 1 def /LLL.isSame goto } {  } ifelse
    [ii vv] gb  /iigg set
    [jj vv] gb  /jjgg set

    iigg getRing ring_def

    /ans 1 def
    iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
    /iigg set
    jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
    /jjgg set

    gb.verbose { ( ii < jj ?) messagen } {  } ifelse
    iigg length /n set
    0 1 n 1 sub {
      /k set
      iigg  k get 
      jjgg  reduction-noH 0 get
      (0). eq not { /ans 0 def /LLL.isSame goto} {  } ifelse
      gb.verbose { (o) messagen } {  } ifelse
    } for
    gb.verbose { ( jj < ii ?) messagen } {  } ifelse
    jjgg length /n set
    0 1 n 1 sub {
      /k set
      jjgg k get 
      iigg reduction-noH 0 get
      (0). eq not { /ans 0 def /LLL.isSame goto} {  } ifelse
      gb.verbose { (o) messagen } {  } ifelse
    } for
    /LLL.isSame
    gb.verbose { ( Done) message } {  } ifelse
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(isSameIdeal ) messagen-quiet

[(isSameIdeal)
[([ii jj vv] isSameIdeal bool)
 (ii, jj : ideal, vv : variables)
 (Note that ii and jj will be dehomogenized and compared in the ring)
 (of differential operators. cf. isSameIdeal_h)
 $Example 1: [ [(x^3) (y^2)]  [(x^2+y) (y)] (x,y)] isSameIdeal $
 $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
 $             [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
]] putUsages

/isSameIdeal_h {
  /arg1 set
  [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
   /isSameIdeal_h.opt
   ] pushVariables
  [(CurrentRingp) (Homogenize_vec)] pushEnv
  [
    /aa arg1 def
    gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
    %% comparison of hilbert series has not yet been implemented.
    aa length 3 eq {    }
    { ([ii jj vv] isSameIdeal_h) error } ifelse
    /ii aa 0 get def
    /jj aa 1 get def
    /vv aa 2 get def
    ii length 0 eq jj length 0 eq and 
    { /ans 1 def /LLL.isSame_h goto } {  } ifelse

    [ii vv] gb_h  /iigg set
    [jj vv] gb_h  /jjgg set

    iigg getRing ring_def

    getOptions /isSameIdeal_h.opt set
    (grade) (module1v) switch_function
    [(Homogenize_vec) 0] system_variable
    /ans 1 def
    iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
    /iigg set
    jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
    /jjgg set

    gb.verbose { (Comparing) message iigg message (and) message jjgg message }
    {  } ifelse
    gb.verbose { ( ii < jj ?) messagen } {  } ifelse
    iigg length /n set
    0 1 n 1 sub {
      /k set
      iigg  k get 
      jjgg  reduction 0 get
      (0). eq not { /ans 0 def /LLL.isSame_h goto} {  } ifelse
      gb.verbose { (o) messagen } {  } ifelse
    } for
    gb.verbose { ( jj < ii ?) messagen } {  } ifelse
    jjgg length /n set
    0 1 n 1 sub {
      /k set
      jjgg k get 
      iigg reduction 0 get
      (0). eq not { /ans 0 def /LLL.isSame_h goto} {  } ifelse
      gb.verbose { (o) messagen } {  } ifelse
    } for
    /LLL.isSame_h
    gb.verbose { ( Done) message } {  } ifelse
    isSameIdeal_h.opt restoreOptions 
    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(isSameIdeal_h ) messagen-quiet

[(isSameIdeal_h)
[([ii jj vv] isSameIdeal_h bool)
 (ii, jj : ideal, vv : variables)
 (Note that ii and jj will be compared in the ring)
 (of homogenized differential operators. Each element of the vector must be)
 (homogenized.)
 $Example 1: [ [(x Dx - h^2) (Dx^2)]  [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
 $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
 $       [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
]] putUsages

/gb.reduction {
  /arg2 set
  /arg1 set
  [/in-gb.reduction /gbasis /flist /ans /gbasis2
  ] pushVariables
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
     /gbasis arg2  def
     /flist  arg1  def
     gbasis 0 get tag 6 eq { }
     { (gb.reduction: the second argument must be a list of lists) error }
     ifelse

     gbasis length 1 eq {
       gbasis getRing ring_def
       /gbasis2 gbasis 0 get def
     } {
       [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
       /gbasis2 gbasis 0 get ,,, def
     } ifelse


     flist ,,, /flist set
     flist tag 6 eq {
       flist { gbasis2 reduction } map /ans set
     }{
       flist gbasis2 reduction /ans set
     } ifelse
     /arg1 ans def

  ] pop
  popEnv
  popVariables
  arg1
} def

/gb.reduction.test {
  [
    [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
    (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
  gb /gg set

  ((h-x-y)*Dx) [gg 0 get] gb.reduction /gg2 set
  gg2 message
  (-----------------------------) message

    [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )]
      (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
   ((h-x-y)*Dx) ggg gb.reduction /gg4 set
   gg4 message
  (-----------------------------) message
  [gg2 gg4]
} def
[(gb.reduction)
[ (f basis gb.reduction r)
  (f is reduced by basis by the normal form algorithm.)
  (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
  (r is the return value format of reduction;)
  (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
  (basis is given in the argument format of gb.)
  $h[1,1](D)-homogenization is used.$
  (cf. reduction, gb, ecartd.gb, gb.reduction.test )
  $Example:$
  $ [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )] $
  $   (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
  $ ((h-x-y)^2*Dx*Dy) ggg gb.reduction :: $
]] putUsages

( ) message-quiet ;