% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.14 2003/08/27 03:11:13 takayama Exp $ 
%[(parse) (hol.sm1) pushfile] extension
%[(parse) (appell.sm1) pushfile] extension

(ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet
/ecart.begin { beginEcart } def
/ecart.end   { endEcart } def
/ecart.autoHomogenize 1 def
/ecart.needSyz 0 def
/ecartd.begin { 
  ecart.begin
  [(EcartAutomaticHomogenization) 1] system_variable
} def
/ecartd.end {  
  ecart.end 
  [(EcartAutomaticHomogenization) 0] system_variable
} def

/ecart.dehomogenize {
 /arg1 set
 [/in.ecart.dehomogenize /ll /rr] pushVariables
 [
   /ll arg1 def
   ll tag 6 eq {
     ll { ecart.dehomogenize } map /ll set
   } {  
     ll (0). eq {
     } {
       ll getRing /rr set
       ll [ [ (H) rr ,, (1) rr ,, ] 
            [ (h) rr ,, (1) rr ,, ]] replace
       /ll set
     } ifelse
   } ifelse
   /arg1 ll def
 ] pop
 popVariables
 arg1
} def
[(ecart.dehomogenize)
 [(obj ecart.dehomogenize r)
  (h->1, H->1)
]] putUsages

/ecart.dehomogenizeH {
 /arg1 set
 [/in.ecart.dehomogenize /ll /rr] pushVariables
 [
   /ll arg1 def
   ll tag 6 eq {
     ll { ecart.dehomogenize } map /ll set
   } {  
     ll (0). eq {
     } {
       ll getRing /rr set
       ll [ [ (H) rr ,, (1) rr ,, ] ] replace
       /ll set
     } ifelse
   } ifelse
   /arg1 ll def
 ] pop
 popVariables
 arg1
} def
[(ecart.dehomogenizeH)
 [(obj ecart.dehomogenizeH r)
  (H->1, h is not changed.)
]] putUsages

/ecart.homogenize01 {
 /arg1 set
 [/in.ecart.homogenize01 /ll /ll0] pushVariables
 [
   /ll arg1 def
   ll tag ArrayP eq {
     ll 0 get tag ArrayP eq not {
       [(degreeShift) [ ] ll ] homogenize   /arg1 set
     } {
       ll { ecart.homogenize01 } map /arg1 set
     } ifelse
   } {
       [(degreeShift) [ ] ll ] homogenize   /arg1 set
   } ifelse
 ] pop
 popVariables
 arg1
} def
[(ecart.homogenize01)
 [(obj ecart.homogenize01 r)
  (Example:  )
  (  [(x1,x2) ring_of_differential_operators )
  (   [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
  (    [(h) 1 (Dx1) 1 (Dx2) 1] )
  (    [(Dx1) 1 (Dx2) 1]   )
  (    [(x1) -1 (x2) -1])
  (   ] weight_vector )
  (   0  )
  (   [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
  (  ] define_ring)
  ( ecart.begin)
  ( [[1 -4 -2 5]] appell4 0 get /eqs set)
  ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
  ( {ecart.homogenize01} map /eqs2 set)
  ( [eqs2] groebner )
]] putUsages

/ecart.homogenize01_with_shiftVector {
 /arg2.set
 /arg1 set
 [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
 [
   /sv arg2 def
   /ll arg1 def
   ll tag ArrayP eq {
     ll 0 get tag ArrayP eq not {
       [(degreeShift) sv ll ] homogenize   /arg1 set
     } {
       ll { ecart.homogenize01_with_shiftVector } map /arg1 set
     } ifelse
   } {
       [(degreeShift) sv ll ] homogenize   /arg1 set
   } ifelse
 ] pop
 popVariables
 arg1
} def
[(ecart.dehomogenize01_with_degreeShift)
 [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
  (cf. homogenize)
]] putUsages

%% Aux functions to return the default weight vectors.
/ecart.wv1 {
  /arg1 set
  [/in.ecart.wv1 /v] pushVariables
  [
    /v arg1 def
    [(H) (h) v to_records pop] /v set
    v { 1 } map /v set
    /arg1 v def
  ] pop
  popVariables
  arg1 
} def
/ecart.wv2 {
  /arg1 set
  [/in.ecart.wv2 /v] pushVariables
  [
    /v arg1 def
    [v to_records pop] /v set
    v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
    [(h) 1 ] v join /v set
    /arg1 v def
  ] pop
  popVariables
  arg1 
} def

/ecart.gb {ecartd.gb}  def

[(ecart.gb)
 [(a ecart.gb b)
  (array a; array b;)
  $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
  (             in the ring of differential operators.)
  (The computation is done by using Ecart division algorithm and )
  (the double homogenization.)
  (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
   $            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 for the ring. )
  (a : [f v w ds hdShift]; array f; string v; array of array w; w is the weight matirx.)
  (        array ds; ds is the degree shift for the ring. )
  (        array hsShift is the degree shift for the homogenization. cf.homogenize )
  $a : [f v w ds (no)]; array f; string v; array of array w; w is the weight matirx.$
  (       No automatic homogenization.)
  (  )
  $cf. ecarth.gb (homogenized),  ecartd.gb (dehomogenize) $
  ( )
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
  (Example 2: )
  $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
  $   [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb  /ff set ff pmat ;$
  (To set the current ring to the ring in which ff belongs )
  (      ff getRing ring_def  )
  (  )
  $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
  (   This example will cause an error on order.)
  (  )
  $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] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
  (   This example will cause an error on order.)
  (  )
  $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
  $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  [[0 1] [-3 1] ] ] ecart.gb pmat ; $
  (  )
  (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
  (    ecart.dehomogenize, ecart.dehomogenizeH)
  ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
  (                                                          define_ring )
  (/ecart.autoHomogenize 0 def )
  (               not to dehomogenize and homogenize)
]] putUsages

/ecart.gb.verbose 1 def
%ecarth.gb  s(H)-homogenized outputs.  GG's original version of ecart gb.
/ecarth.gb {
  /arg1 set
  [/in-ecarth.gb /aa /typev /setarg /f /v 
   /gg /wv /vec /ans /rr /mm
   /degreeShift  /env2 /opt /ans.gb
   /hdShift
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
    /aa arg1 def
    aa isArray { } { ( << array >> ecarth.gb) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    /hdShift 0 def 
    /opt [(weightedHomogenization) 1] 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 StringP ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /hdShift aa 4 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
    typev [ArrayP 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
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       aa 4 get (no) eq {
         /hdShift -1 def
       } {  
         (Unknown keyword for the 5th argument) error
       } ifelse
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get  def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       aa 4 get (no) eq {
         /hdShift -1 def
       } {  
         (Unknown keyword for the 5th argument) error
       } ifelse
       /setarg 1 def
    } { } ifelse

    /env1 getOptions def

    ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } {  } ifelse
    setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
    
    [(KanGBmessage) ecart.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: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
%         [ v ecart.wv1 v ecart.wv2 ] weight_vector
         gb.characteristic
         opt
        ] define_ring
      }{
       degreeShift isInteger {
         [v ring_of_differential_operators 
%          [v ecart.wv1 v ecart.wv2] wv join weight_vector
          wv weight_vector
          gb.characteristic
          opt
         ] define_ring

       }{
         [v ring_of_differential_operators 
%          [v ecart.wv1 v ecart.wv2] wv join weight_vector
          wv  weight_vector
          gb.characteristic
          [(degreeShift) degreeShift] opt join 
          ] define_ring

       } ifelse
      } 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

    } ifelse
    %%% Enf of the preprocess

    ecart.gb.verbose {
      (The first and the second weight vectors for automatic homogenization: )
       message
       v ecart.wv1 message
       v ecart.wv2 message
       degreeShift isInteger { }
       {
         (The degree shift is ) messagen
         degreeShift message
       } ifelse
    } { } ifelse

    %%BUG: case of v is integer
    v ecart.checkOrder

    ecart.begin

    ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse


    hdShift tag 1 eq {
     ecart.autoHomogenize not hdShift -1 eq or {
% No automatic h-s-homogenization.
       f { {. } map} map /f set   
     } {
% Automatic h-s-homogenization without degreeShift
    (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
      message
       f { {. ecart.dehomogenize} map} map /f set   
       f ecart.homogenize01 /f set
     } ifelse
   } {
% Automatic h-s-homogenization with degreeShift
    (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
      message
       f { {. ecart.dehomogenize} map} map /f set   
       f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
   }ifelse

    ecart.needSyz {
      [f [(needSyz)] gb.options join ] groebner /gg set
    } {  
      [f gb.options] groebner 0 get /gg set
    } ifelse

    ecart.needSyz {
      mm {
       gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
       } { /ans.gb gg 0 get def } ifelse
       /ans [gg 2 get , ans.gb , gg 1 get , f ] def
%      ans pmat ;
    } { 
      wv isInteger {
        /ans [gg gg {init} map] def
      }{
       degreeShift isInteger {
         /ans [gg gg {wv 0 get weightv init} map] def
       } {
         /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
       } ifelse
      }ifelse

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

    ecart.end

    %% 
    env1 restoreOptions  %% degreeShift changes "grade"

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

[(ecarth.gb)
 [(a ecarth.gb b)
  (array a; array b;)
  $b : [g ii];  array g; array in; g is a standard (Grobner) basis of f$
  (             in the ring of differential operators.)
  (The computation is done by using Ecart division algorithm.)
  $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$
  (they are not dehomogenized.)
  (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
   $            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 )
  (  )
  (/ecart.autoHomogenize 0 def )
  (               not to dehomogenize and homogenize)
  ( )
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
  (Example 2: )
  (To put H and 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]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
  (  )
  $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 (Dy) 1] ] ] ecarth.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] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
  (  )
  $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
  $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  [[0 1] [-3 1] ] ] ecarth.gb pmat ; (buggy infinite loop)$
  (  )
  (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
  (    ecart.dehomogenize, ecart.dehomogenizeH)
  ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
  (                                                          define_ring )
]] putUsages


/ecart.syz {
  /arg1 set
  [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
  [
    /ff arg1 def
    /ecart.save.needSyz ecart.needSyz def
    /ecart.needSyz 1 def
    ff ecart.gb /ff.ans set
    /ecart.needSyz ecart.save.needSyz def
    /arg1 ff.ans def
  ] pop
  popVariables
  arg1
} def
(ecart.syz ) messagen-quiet 

[(ecart.syz)
 [(a ecart.syz b)
  (array a; array b;)
  $b : [syzygy gb tmat input];  gb = tmat * input $
  $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) (  x y Dx Dy -1)] (x,y) $
  $             [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
  $ ff 0 get ff 3 get mul pmat $
  $ ff 2 get  ff 3 get mul [ff 1 get ] transpose sub pmat ; $
  (  )
  (To set the current ring to the ring in which ff belongs )
  (      ff getRing ring_def  )
  $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
  $             [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ]  [[0 1] [-3 1] ] ] ecart.syz pmat ; $
  (  )
  (cf. ecart.gb)
  (    /ecart.autoHomogenize 0 def )
]] putUsages


/ecartn.begin { 
  (red@) (standard) switch_function
%%  (red@) (ecart) switch_function
  [(Ecart) 1] system_variable
  [(CheckHomogenization) 0] system_variable
  [(ReduceLowerTerms) 0] system_variable
  [(AutoReduce) 0] system_variable
  [(EcartAutomaticHomogenization) 0] system_variable
} def
/ecartn.gb {
  /arg1 set
  [/in-ecartn.gb /aa /typev /setarg /f /v 
   /gg /wv /vec /ans /rr /mm
   /degreeShift  /env2 /opt /ans.gb
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
    /aa arg1 def
    aa isArray { } { ( << array >> ecartn.gb) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    /opt [(weightedHomogenization) 1] 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 { } { (ecart.gb : Argument mismatch) error } ifelse
    
    [(KanGBmessage) ecart.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: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        [v ring_of_differential_operators 
         [ v ecart.wv1 v ecart.wv2 ] weight_vector
         gb.characteristic
         opt
        ] define_ring
      }{
       degreeShift isInteger {
         [v ring_of_differential_operators 
          [v ecart.wv1 v ecart.wv2] wv join weight_vector
          gb.characteristic
          opt
         ] define_ring

       }{
         [v ring_of_differential_operators 
          [v ecart.wv1 v ecart.wv2] wv join weight_vector
          gb.characteristic
          [(degreeShift) degreeShift] opt join 
          ] define_ring

       } ifelse
      } 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

    } ifelse
    %%% Enf of the preprocess

    ecart.gb.verbose {
      (The first and the second weight vectors are automatically set as follows)
       message
       v ecart.wv1 message
       v ecart.wv2 message
       degreeShift isInteger { }
       {
         (The degree shift is ) messagen
         degreeShift message
       } ifelse
    } { } ifelse

    %%BUG: case of v is integer
    v ecart.checkOrder

    ecartn.begin

    ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
    ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
    ecart.autoHomogenize {
      (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
      message
    } { } ifelse
    ecart.autoHomogenize {
      f { {. ecart.dehomogenize} map} map /f set   
      f ecart.homogenize01 /f set
    }{
      f { {. } map } map /f set
    } ifelse
    ecart.needSyz {
      [f [(needSyz)] gb.options join ] groebner /gg set
    } {  
      [f gb.options] groebner 0 get /gg set
    } ifelse

    ecart.needSyz {
      mm {
       gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
      } { /ans.gb gg 0 get def } ifelse
      /ans [gg 2 get , ans.gb , gg 1 get , f ] def
%      ans pmat ;
    } { 
      wv isInteger {
        /ans [gg gg {init} map] def
      }{
       degreeShift isInteger {
         /ans [gg gg {wv 0 get weightv init} map] def
       } {
         /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
       } ifelse
      }ifelse

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

    ecart.end

    %% 
    env1 restoreOptions  %% degreeShift changes "grade"

    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(ecartn.gb[gb by non-ecart division] ) messagen-quiet 

/ecartd.gb {
  /arg1 set
  [/in-ecart.gb /aa /typev /setarg /f /v 
   /gg /wv /vec /ans /rr /mm
   /degreeShift  /env2 /opt /ans.gb
   /hdShift
  ] pushVariables 
  [(CurrentRingp) (KanGBmessage)] pushEnv
  [
    /aa arg1 def
    aa isArray { } { ( << array >> ecartd.gb) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    /hdShift 0 def
    /opt [(weightedHomogenization) 1] 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
    typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP 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
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get from_records def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       aa 4 get (no) eq {
         /hdShift -1 def
       } {  
         (Unknown keyword for the 5th argument) error
       } ifelse
       /setarg 1 def
    } { } ifelse
    typev [ArrayP StringP ArrayP ArrayP StringP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       aa 4 get (no) eq {
         /hdShift -1 def
       } {  
         (Unknown keyword for the 5th argument) error
       } ifelse
       /setarg 1 def
    } { } ifelse

    /env1 getOptions def

    setarg { } { (ecart.gb : Argument mismatch) error } ifelse
    
    [(KanGBmessage) ecart.gb.verbose ] system_variable
    $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message

    %%% 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: Specify variables) error
      } {  } ifelse
      wv isInteger {        
        (Give an weight vector such that x < 1) error
      }{
       degreeShift isInteger {
         [v ring_of_differential_operators 
           wv weight_vector
          gb.characteristic
          opt
         ] define_ring

       }{
         [v ring_of_differential_operators 
           wv weight_vector
          gb.characteristic
          [(degreeShift) degreeShift] opt join 
          ] define_ring

       } ifelse
      } 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

    } ifelse
    %%% Enf of the preprocess

    ecart.gb.verbose {
       degreeShift isInteger { }
       {
         (The degree shift is ) messagen
         degreeShift message
       } ifelse
    } { } ifelse

    %%BUG: case of v is integer
    v ecart.checkOrder

    ecartd.begin

    ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse

    hdShift tag 1 eq {
     ecart.autoHomogenize not hdShift -1 eq  or {
% No automatic h-homogenization.
       f { {. } map} map /f set   
     } {
% Automatic h-homogenization without degreeShift
       (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
       f { {. ecart.dehomogenize} map} map /f set   
       f ecart.homogenize01 /f set
       f { { [[(H). (1).]] replace } map } map /f set
     } ifelse
   } {
% Automatic h-homogenization with degreeShift
       (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
       f { {. ecart.dehomogenize} map} map /f set   
       f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
       f { { [[(H). (1).]] replace } map } map /f set
   }ifelse

    ecart.needSyz {
      [f [(needSyz)] gb.options join ] groebner /gg set
    } {  
      [f gb.options] groebner 0 get /gg set
    } ifelse

    ecart.needSyz {
      mm {
       gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
      } { /ans.gb gg 0 get def } ifelse
      /ans [gg 2 get , ans.gb , gg 1 get , f ] def
%      ans pmat ;
    } { 
      wv isInteger {
        /ans [gg gg {init} map] def
      }{
%% Get the initial ideal
       degreeShift isInteger {
         /ans [gg gg {wv 0 get weightv init} map] def
       } {
         /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
       } ifelse
      }ifelse

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

    ecartd.end

    %% 
    env1 restoreOptions  %% degreeShift changes "grade"

    /arg1 ans def
  ] pop
  popEnv
  popVariables
  arg1
} def
(ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet 

/ecart.checkOrder {
  /arg1 set
  [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
  [
    /vv arg1 def
    vv isArray
    { } { [vv to_records pop] /vv set } ifelse
    vv {toString} map /vv set
    vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
    % Starting the checks. 
    0 1 vv length 1 sub {
       /i set
       vv i get . dd i get . mul /tt set
       tt @@@.hsymbol . add init tt eq { }
       { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
    } for

    0 1 vv length 1 sub {
       /i set
       vv i get . /tt set
       tt (1). add init (1). eq { }
       { [vv i get ( is larger than 1 ) ] cat error} ifelse
    } for
    /arg1 1 def
  ] pop
  popVariables
  arg1
} def
[(ecart.checkOrder)
 [(v ecart.checkOrder bool checks if the given order is relevant)
  (for the ecart division.)
  (cf. ecartd.gb, ecart.gb, ecartn.gb)
 ]
] putUsages 

/ecart.wv_last {
  /arg1 set
  [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
  [
    /vv arg1 def
    vv isArray
    { } { [vv to_records pop] /vv set } ifelse
    vv {toString} map /vv set
    vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
    vv {  -1 } map
    dd {   1 } map join /arg1 set 
  ] pop
  popVariables
  arg1
} def
[(ecart.wv_last)
 [(v ecart.wv_last wt )
  (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
  (Use this weight vector as the last weight vector for ecart division)
  (if ecart.checkOrder complains about the order given.)
 ]
] putUsages 

/ecart.mimimalBase.test {
 [ 
    [    (0) , (-2*Dx) , (2*t) , (y) , (x^2) ] 
    [    (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ] 
    [    (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ] 
    [    (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )] 
    [    (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ] 
    [  (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ] 
    [  (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ] 
    [  (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ] 
  ]
  /ff set

  /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
  /shift [ [1 0 1 0 0] ] def
  /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def

  [ff (t,x,y) weight shift nmshift] ecart.minimalBase


}  def
/test {ecart.mimimalBase.test} def

%(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
/ecart.minimalBase.D1 {
  /arg1 set
  [/in-ecart.minimalBase.D1  /tt /v]  pushVariables
  [
    /v arg1 def
    [ v to_records pop] /v set
    v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
    v [(h) 1] join /arg1 set
  ] pop
  popVariables
  arg1
} def

% [0 1 2] 1 ecart.removeElem [0 2]
/ecart.removeElem {
  /arg2 set
  /arg1 set
  [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
  [
    /v arg1 def
    /q arg2 def
    /ans v length 1 sub newVector def
    /j 0 def
    0 1 v length 1 sub {
      /i set
      i q eq not {
        ans j  v i get put
        /j j 1 add def
      } {  } ifelse
    } for
  ] pop
  popVariables
  arg1
} def

/ecart.isZeroRow {
  /arg1 set
  [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables
  [ 
     /aa arg1 def
     aa length /n set 
     /yes 1 def
     0 1 n 1 sub {
       /i set
       aa i get (0). eq {
       } {
         /yes 0 def
       } ifelse
     } for
     /arg1 yes def
  ] pop
  popVariables
  arg1
} def

/ecart.removeZeroRow {
  /arg1 set
  [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables
  [ 
     /aa arg1 def
     aa length /n set 
     /ans [ ] def
     0 1 n 1 sub {
       /i set
       aa i get ecart.isZeroRow {
       } {
         ans aa i get append /ans set
       } ifelse
     } for
     /arg1 ans def
  ] pop
  popVariables
  arg1
} def

/ecart.gen_input {
  /arg1 set
  [/in-ecart.gen_input  /aa /typev /setarg /f /v 
   /gg /wv /vec /ans /rr /mm
   /degreeShift  /env2 /opt /ss0
   /hdShift /ff 
   ] pushVariables
  [
    /aa arg1 def
    aa isArray { } { ( << array >> ecart.gen_input) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    /hdShift 0 def 
    aa { tag } map /typev set
    typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP 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
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
    
    [(KanGBmessage) ecart.gb.verbose ] system_variable

    f 0 get tag ArrayP eq {  }
    {  f { /tt set [ tt ] } map /f set } ifelse

    [f v wv degreeShift [hdShift 0 get degreeShift 0 get]]
    ecart.gb /ff set
    ff getRing ring_def 

    ff 0 get { {toString } map } map /ff set
 
    [ff v wv degreeShift [hdShift 0 get degreeShift 0 get]] /arg1 set
  ] pop
  popVariables
  arg1
} def
[(ecart.gen_input)
[([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]]  ecart.gen_input )
 (               [gg_h v weight_vector uv_shift_m [D_shift_n uv_shift_m]] )
 (It generates the input for the minimal filtered free resolution.)
 (Current ring is changed to the ring of gg_h.)
 (cf. ecart.minimalBase)
  $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
  $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
  $           [ [0] ] $
  $           [ [0] [0] ] ] ecart.gen_input /gg set gg pmat $
]] putUsages

  
[(ecart.minimalBase)
[([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]]  ecart.minimalBase )
 (  [mbase gr_of_mbase )
 (     [syz v weight_vector new_uv_shift_m [new_D_shift_n new_uv_shift_m]])
 (     gr_of_syz ])
 (mbase is the minimal generators of ff in D^h in the sense of filtered minimal)
 (generators.)
  $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
  $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
  $           [ [0] ] $
  $           [ [0] [0] ] ] ecart.gen_input /gg0 set $
  $         gg0 ecart.minimalBase /ss0 set $
  $         ss0 2 get ecart.minimalBase /ss1 set $
  $         ss1 2 get ecart.minimalBase /ss2 set $
  $     (---------  minimal filtered resolution -------) message $
  $     ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat  $
  $     (---------  degree shift (n,m) n:D-shift m:uv-shift  -------) message $
  $     gg0       4 get message $
  $     ss0 2 get 4 get message $
  $     ss1 2 get 4 get message $
  $     ss2 2 get 4 get message ; $

]] putUsages
/ecart.minimalBase {
  /arg1 set
  [/in-ecart.minimalBase /ai1 /ai  /aa /typev /setarg /f /v 
   /gg /wv /vec /ans /rr /mm
   /degreeShift  /env2 /opt /ss0
   /hdShift
    /degreeShiftD /degreeShiftUV 
    /degreeShiftDnew /degreeShiftUVnew 
    /tt
    /ai1_gr  /ai_gr
    /s /r /p /q /i /j /k
     /ai1_new /ai_new /ai_new2 
   ] pushVariables
  [
    /aa arg1 def
    aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
    /setarg 0 def
    /wv 0 def
    /degreeShift 0 def
    /hdShift 0 def 
    aa { tag } map /typev set
    typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
    {  /f aa 0 get def
       /v aa 1 get def
       /wv aa 2 get def
       /degreeShift aa 3 get def
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    typev [ArrayP 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
       /hdShift aa 4 get def
       /setarg 1 def
    } { } ifelse
    setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
    
    [(KanGBmessage) ecart.gb.verbose ] system_variable

    f 0 get tag ArrayP eq {  }
    {  f { /tt set [ tt ] } map /f set } ifelse
    [f v wv degreeShift (no)] ecart.syz /ss0 set

    ss0 getRing ring_def
    /degreeShiftD  hdShift 0 get def
    /degreeShiftUV hdShift 1 get def
%      -- ai --> D^r -- ai1 --> D^rr  
    /ai1  f  { { . } map } map def
    /ai  ss0 0 get def
   
   {
    /degreeShiftUVnew 
       ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all  } map
    def
    (degreeShiftUVnew=) messagen degreeShiftUVnew message

    /degreeShiftDnew 
       ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ]  ord_ws_all}
            map
    def
    (degreeShiftDnew=) messagen degreeShiftDnew message

    ai {[wv 0 get weightv  degreeShiftUVnew] init} map /ai_gr set   

%C  Note 2003.8.26

    ai [ ] eq {
      exit
    } {  } ifelse

    /s ai length def
    /r ai 0 get length def

    /itIsMinimal 1 def
    0 1 s 1 sub {
      /i set
      0 1 r 1 sub {
        /j set

        [(isConstantAll) ai_gr i get j get] gbext
        ai_gr i get j get (0). eq not and
        {
           /itIsMinimal 0 def
           /p i def /q j def
        } {  } ifelse
      } for
    } for    


    itIsMinimal { exit } { } ifelse

%    construct new ai and ai1 (A_i and A_{i-1})
     /ai1_new  r 1 sub newVector def
     /j 0 def     
     0 1 r 1 sub {
       /i set
       i q eq not {
          ai1_new j ai1 i get put
          /j  j 1 add def
       } { } ifelse
     } for 

     /ai_new [s  r] newMatrix def
     0 1 s 1 sub {
       /j set
       0 1 r 1 sub {
         /k set
         ai_new [j k] 
            << ai p get q get >> << ai j get k get >> mul
            << ai j get q get >> << ai p get k get >> mul
            sub
         put
       } for
     } for 
    
% remove 0 column
     /ai_new2 [s 1 sub r 1 sub] newMatrix def
     /j 0 def     
     0 1 s 1 sub {
       /i set
       i p eq not {
          ai_new2 j << ai_new i get q ecart.removeElem >> put
          /j  j 1 add def
       } { } ifelse
     } for 

%   ( ) error
     /ai1 ai1_new  def
     /ai ai_new2  ecart.removeZeroRow def 

   } loop   
   /arg1 
     [  ai1 
        ai1 {[wv 0 get weightv  degreeShift 0 get] init} map %Getting gr of A_{i-1}
        [ai v wv [degreeShiftUVnew] [degreeShiftDnew degreeShiftUVnew]] 
        ai {[wv 0 get weightv  degreeShiftUVnew] init} map %Getting gr of A_i
     ] 
   def
  ] pop 
  popVariables
  arg1
} def


( ) message-quiet