===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.10
retrieving revision 1.14
diff -u -p -r1.10 -r1.14
--- OpenXM/src/kan96xx/Doc/ecart.sm1	2003/08/23 02:28:40	1.10
+++ OpenXM/src/kan96xx/Doc/ecart.sm1	2003/08/27 03:11:13	1.14
@@ -1,4 +1,4 @@
-% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.9 2003/08/22 23:55:21 takayama Exp $ 
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.13 2003/08/26 12:46:03 takayama Exp $ 
 %[(parse) (hol.sm1) pushfile] extension
 %[(parse) (appell.sm1) pushfile] extension
 
@@ -69,11 +69,18 @@
 
 /ecart.homogenize01 {
  /arg1 set
- [/in.ecart.homogenize01 /ll ] pushVariables
+ [/in.ecart.homogenize01 /ll /ll0] pushVariables
  [
    /ll arg1 def
-   [(degreeShift) [ ] ll ] homogenize
-   /arg1 set
+   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
@@ -88,30 +95,38 @@
   (    [(x1) -1 (x2) -1])
   (   ] weight_vector )
   (   0  )
-  (   [(degreeShift) [[0 0 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 /eqs2 set)
+  ( {ecart.homogenize01} map /eqs2 set)
   ( [eqs2] groebner )
 ]] putUsages
 
 /ecart.homogenize01_with_shiftVector {
  /arg2.set
  /arg1 set
- [/in.ecart.homogenize01 /ll /sv] pushVariables
+ [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
  [
    /sv arg2 def
    /ll arg1 def
-   [(degreeShift) sv ll ] homogenize
-   /arg1 set
+   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.
@@ -157,7 +172,12 @@
   (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 )
+  (                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) $
   ( )
@@ -189,19 +209,22 @@
 ]] 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 >> gb) error } ifelse
+    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
@@ -243,6 +266,15 @@
        /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
@@ -250,10 +282,43 @@
        /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
 
-    setarg { } { (ecart.gb : Argument mismatch) error } ifelse
+    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
 
@@ -328,16 +393,27 @@
     ecart.begin
 
     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
-    ecart.autoHomogenize {
-      (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
+
+
+    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
-    } { } ifelse
-    ecart.autoHomogenize {
-      f { {. ecart.dehomogenize} map} map /f set   
-      f ecart.homogenize01 /f set
-    }{
-      f { {. } map } map /f set
-    } ifelse
+       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
     } {  
@@ -347,9 +423,9 @@
     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 ;
+       } { /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
@@ -387,8 +463,9 @@
   (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.)
+  (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.$
@@ -423,7 +500,6 @@
   (                                                          define_ring )
 ]] putUsages
 
-%% BUG:  " f weight init " works well in case of vectors with degree shift ?
 
 /ecart.syz {
   /arg1 set
@@ -478,7 +554,7 @@
   [(CurrentRingp) (KanGBmessage)] pushEnv
   [
     /aa arg1 def
-    aa isArray { } { ( << array >> gb) error } ifelse
+    aa isArray { } { ( << array >> ecartn.gb) error } ifelse
     /setarg 0 def
     /wv 0 def
     /degreeShift 0 def
@@ -628,7 +704,7 @@
        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 ;
+%      ans pmat ;
     } { 
       wv isInteger {
         /ans [gg gg {init} map] def
@@ -666,14 +742,16 @@
   [/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 >> gb) error } ifelse
+    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
@@ -722,6 +800,46 @@
        /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
 
@@ -792,9 +910,24 @@
 
     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
 
-    f { {. ecart.dehomogenize} map} map /f set   
-    f ecart.homogenize01 /f set
-    f { { [[(H). (1).]] replace } map } map /f set
+    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
@@ -807,11 +940,12 @@
        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 ;
+%      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
        } {
@@ -897,6 +1031,336 @@
   (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