===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.1
retrieving revision 1.6
diff -u -p -r1.1 -r1.6
--- OpenXM/src/kan96xx/Doc/ecart.sm1	2003/07/25 01:00:38	1.1
+++ OpenXM/src/kan96xx/Doc/ecart.sm1	2003/08/13 03:52:25	1.6
@@ -1,4 +1,4 @@
-% $OpenXM$ 
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.5 2003/08/04 11:42:42 takayama Exp $ 
 %[(parse) (hol.sm1) pushfile] extension
 %[(parse) (appell.sm1) pushfile] extension
 
@@ -219,22 +219,24 @@
       } {  } ifelse
       wv isInteger {        
         [v ring_of_differential_operators 
-         [ v ecart.wv1 v ecart.wv2 ] weight_vector
-         0
+%         [ 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
-          0
+%          [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
-          0
+%          [v ecart.wv1 v ecart.wv2] wv join weight_vector
+          wv  weight_vector
+          gb.characteristic
           [(degreeShift) degreeShift] opt join 
           ] define_ring
 
@@ -254,7 +256,7 @@
     %%% Enf of the preprocess
 
     ecart.gb.verbose {
-      (The first and the second weight vectors are automatically set as follows)
+      (The first and the second weight vectors for automatic homogenization: )
        message
        v ecart.wv1 message
        v ecart.wv2 message
@@ -265,6 +267,9 @@
        } ifelse
     } { } ifelse
 
+    %%BUG: case of v is integer
+    v ecart.checkOrder
+
     ecart.begin
 
     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
@@ -338,7 +343,7 @@
   (               not to dehomogenize and homogenize)
   ( )
   $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
-  $             [ [ (Dx) 1 ] ] ] ecart.gb pmat ; $
+  $             [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.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) $
@@ -348,10 +353,10 @@
   $             [ [ (Dx) 1 (Dy) 1] ] ] ecart.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] ] ] ecart.gb pmat ; $
+  $             [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.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] ] ] ecart.gb pmat ; $
+  $             [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ]  [[0 1] [-3 1] ] ] ecart.gb pmat ; (buggy infinite loop)$
   (  )
   (cf. gb, groebner, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
   (    ecart.dehomogenize, ecart.dehomogenizeH)
@@ -392,3 +397,439 @@
   (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 >> 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
+      }{
+        /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
+    } 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
+  ] pushVariables 
+  [(CurrentRingp) (KanGBmessage)] pushEnv
+  [
+    /aa arg1 def
+    aa isArray { } { ( << array >> 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
+    $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
+
+    ecart.begin
+    [(EcartAutomaticHomogenization) 1] system_variable
+
+    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
+
+    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
+      }{
+        /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
+    } ifelse
+
+    ecart.end
+    [(EcartAutomaticHomogenization) 0] system_variable
+
+    %% 
+    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 
+
+( ) message-quiet 
+