===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.18
retrieving revision 1.28
diff -u -p -r1.18 -r1.28
--- OpenXM/src/kan96xx/Doc/ecart.sm1	2003/09/30 00:06:56	1.18
+++ OpenXM/src/kan96xx/Doc/ecart.sm1	2004/05/27 11:13:49	1.28
@@ -1,4 +1,4 @@
-% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.17 2003/09/20 22:10:04 takayama Exp $ 
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.27 2004/05/15 12:00:48 takayama Exp $ 
 %[(parse) (hol.sm1) pushfile] extension
 %[(parse) (appell.sm1) pushfile] extension
 
@@ -7,6 +7,8 @@
 /ecart.end   { endEcart } def
 /ecart.autoHomogenize 1 def
 /ecart.needSyz 0 def
+/ecartd.gb.oxRingStructure [[ ] [ ] ] def
+
 /ecartd.begin { 
   ecart.begin
   [(EcartAutomaticHomogenization) 1] system_variable
@@ -16,6 +18,13 @@
   [(EcartAutomaticHomogenization) 0] system_variable
 } def
 
+/ecart.message.quiet 0 def
+/ecart.message {
+  ecart.message.quiet { pop } { message } ifelse
+} def
+/ecart.messagen {
+  ecart.message.quiet { pop } { messagen } ifelse
+} def
 /ecart.setOpt {
   /arg1 set
   [/in-ecart.setOpt /opt /i /n /ans] pushVariables
@@ -80,7 +89,7 @@
      ll (0). eq {
      } {
        ll getRing /rr set
-       ll [ [ (H) rr ,, (1) rr ,, ] 
+       ll [ [ @@@.Hsymbol rr ,, (1) rr ,, ] 
             [ (h) rr ,, (1) rr ,, ]] replace
        /ll set
      } ifelse
@@ -106,7 +115,7 @@
      ll (0). eq {
      } {
        ll getRing /rr set
-       ll [ [ (H) rr ,, (1) rr ,, ] ] replace
+       ll [ [ @@@.Hsymbol rr ,, (1) rr ,, ] ] replace
        /ll set
      } ifelse
    } ifelse
@@ -188,7 +197,7 @@
   [/in.ecart.wv1 /v] pushVariables
   [
     /v arg1 def
-    [(H) (h) v to_records pop] /v set
+    [@@@.Hsymbol (h) v to_records pop] /v set
     v { 1 } map /v set
     /arg1 v def
   ] pop
@@ -211,6 +220,9 @@
 
 /ecart.gb {ecartd.gb}  def
 
+[(ecartd.gb)
+[(See ecart.gb)]] putUsages
+
 [(ecart.gb)
  [(a ecart.gb b)
   (array a; array b;)
@@ -233,7 +245,8 @@
   (       No automatic homogenization.)
   $  [(degreeShift) ds (noAutoHomogenize) 1 (sugar) 1] -->use the sugar strate $
   (  )
-  $cf. ecarth.gb (homogenized),  ecartd.gb (dehomogenize) $
+  $cf. ecarth.gb (homogenized),  ecartd.gb (dehomogenize), ecartd.reduction $
+  (    ecartd.gb.oxRingStructure )
   ( )
   $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 ; $
@@ -836,7 +849,7 @@
     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
+    $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ ecart.message
 
     %%% Start of the preprocess
     v tag RingP eq {
@@ -854,7 +867,7 @@
         (Error in gb: Specify variables) error
       } {  } ifelse
       wv isInteger {        
-        (Give an weight vector such that x < 1) error
+        (Give a weight vector such that x < 1) error
       }{
        degreeShift isInteger {
          [v ring_of_differential_operators 
@@ -898,7 +911,7 @@
 
     ecartd.begin
 
-    ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
+    ecart.gb.verbose { (gb.options = ) ecart.messagen gb.options ecart.message } { } ifelse
 
     hdShift tag 1 eq {
      ecart.autoHomogenize not hdShift -1 eq  or {
@@ -906,17 +919,17 @@
        f { {. } map} map /f set   
      } {
 % Automatic h-homogenization without degreeShift
-       (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
+       (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) ecart.message
        f { {. ecart.dehomogenize} map} map /f set   
        f ecart.homogenize01 /f set
-       f { { [[(H). (1).]] replace } map } map /f set
+       f { { [[@@@.Hsymbol . (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
+       f { { [[@@@.Hsymbol . (1).]] replace } map } map /f set
    }ifelse
 
     ecart.useSugar {
@@ -961,6 +974,7 @@
 
     ecartd.end
 
+    ans getRing (oxRingStructure) dc /ecartd.gb.oxRingStructure set
     %% 
     env1 restoreOptions  %% degreeShift changes "grade"
 
@@ -1559,6 +1573,269 @@
 } def
 
 %% end of for ecart.define_ring
+
+/ecartd.reduction {
+  /arg2 set
+  /arg1 set
+  [/in-ecartd.reduction /gbasis /flist /ans /gbasis2] pushVariables
+  [(CurrentRingp) (KanGBmessage)] pushEnv
+  [
+     /gbasis arg2  def
+     /flist  arg1  def
+     gbasis 0 get tag 6 eq { }
+     { (ecartd.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 ecartd.gb 0 get getRing ring_def
+       /gbasis2 gbasis 0 get ,,, def
+     } ifelse
+     ecartd.begin
+
+     flist ,,, /flist set
+     flist tag 6 eq {
+       flist { gbasis2 reduction } map /ans set
+     }{
+       flist gbasis2 reduction /ans set
+     } ifelse
+     /arg1 ans def
+
+     ecartd.end
+  ] pop
+  popEnv
+  popVariables
+  arg1
+} def
+
+/ecartd.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]]]
+  ecartd.gb /gg set
+
+  (Dx) [gg 0 get] ecartd.reduction /gg2 set
+  gg2 message
+  (-----------------------------) message
+
+  [(Dx) (Dy) (Dx+x*Dy)] [gg 0 get] ecartd.reduction /gg3 set
+  gg3 message
+
+  (-----------------------------) message
+    [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )]
+      (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
+   (Dx) ggg ecartd.reduction /gg4 set
+   gg4 message
+
+  (----------- reduction by h=1 ---------------) message
+    [[( 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]]] /ggg set
+   [(Homogenize) 0]  system_variable
+   (Dx) ggg ecartd.reduction /gg5 set
+   [(Homogenize) 1]  system_variable
+   gg5 message
+
+  [gg2  gg3 gg4 gg5]
+} def
+
+/ecarth.reduction {
+  /arg2 set
+  /arg1 set
+  [/in-ecarth.reduction /gbasis /flist /ans /gbasis2] pushVariables
+  [(CurrentRingp) (KanGBmessage)] pushEnv
+  [
+     /gbasis arg2  def
+     /flist  arg1  def
+     gbasis 0 get tag 6 eq { }
+     { (ecarth.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 ecarth.gb 0 get getRing ring_def
+       /gbasis2 gbasis 0 get ,,, def
+     } ifelse
+     ecarth.begin
+
+     flist ,,, /flist set
+     flist tag 6 eq {
+       flist { gbasis2 reduction } map /ans set
+     }{
+       flist gbasis2 reduction /ans set
+     } ifelse
+     /arg1 ans def
+
+     ecarth.end
+  ] pop
+  popEnv
+  popVariables
+  arg1
+} def
+
+[(ecartd.reduction)
+[ (f basis ecartd.reduction r)
+  (f is reduced by basis by the tangent cone algorithm.)
+  (The first element of basis <g_1,...,g_m> must be a standard 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 ecartd.gb.)
+  $h[0,1](D)-homogenization is used.$
+  (cf. reduction, ecartd.gb, ecartd.reduction.test )
+  $Example:$
+  $ [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] $
+  $   (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
+  $ (Dx+Dy) ggg ecartd.reduction :: $
+]] putUsages
+
+/ecart.stdOrder {
+  /arg1 set
+  [/in-ecart.stdOrder /vv /tt /dvv /wv1 /wv2
+  ] pushVariables
+  [
+     /vv arg1 def
+     vv isString { [ vv to_records pop] /vv set }
+     { } ifelse
+     vv { toString} map /vv set
+
+     vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set
+     dvv { 1 } map /wv1 set
+     vv { -1 } map dvv { 1 } map join /wv2 set
+     /arg1 [wv1 wv2 ] def
+  ] pop
+  popVariables
+  arg1
+} def
+
+/ecartd.isSameIdeal_h {
+  /arg1 set
+  [/in-ecartd.isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
+   /ecartd.isSameIdeal_h.opt
+   /save-ecart.autoHomogenize  /wv /save-ecart.message.quiet
+   ] pushVariables
+  [(CurrentRingp) (Homogenize_vec)] pushEnv
+  [
+    /aa arg1 def
+    gb.verbose { (Getting in ecartd.isSameIdeal_h) message } { } ifelse
+    %% comparison of hilbert series has not yet been implemented.
+    /save-ecart.message.quiet ecart.message.quiet def
+    aa length 3 eq {    }
+    { ([ii jj vv] ecartd.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.ecartd.isSame_h goto } {  } ifelse
+
+    vv ecart.stdOrder /wv set
+
+    /save-ecart.autoHomogenize ecart.autoHomogenize def
+    /ecart.autoHomogenize 0 def
+    [ii vv wv] ecartd.gb  /iigg set
+    [jj vv wv] ecartd.gb  /jjgg set
+    save-ecart.autoHomogenize /ecart.autoHomogenize set
+
+    iigg getRing ring_def
+
+    getOptions /ecartd.isSameIdeal_h.opt set
+
+    /ans 1 def
+    iigg 0 get /iigg set
+    jjgg 0 get /jjgg set
+    %%Bug: not implemented for the case of module.
+
+    /save-ecart.message.quiet ecart.message.quiet def
+    /ecart.message.quiet 1 def
+    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 vv wv] ecartd.reduction 0 get
+      (0). eq not { /ans 0 def /LLL.ecartd.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 vv wv] ecartd.reduction 0 get
+      (0). eq not { /ans 0 def /LLL.ecartd.isSame_h goto} {  } ifelse
+      gb.verbose { (o) messagen } {  } ifelse
+    } for
+    /LLL.ecartd.isSame_h
+    gb.verbose { ( Done) message } {  } ifelse
+    save-ecart.message.quiet /ecart.message.quiet set
+    ecartd.isSameIdeal_h.opt restoreOptions 
+    /arg1 ans def
+  ] pop
+  popEnv
+  popVariables
+  arg1
+} def
+(ecartd.isSameIdeal_h ) messagen-quiet
+
+[(ecartd.isSameIdeal_h)
+[([ii jj vv] ecartd.isSameIdeal_h bool)
+ (ii, jj : ideal, vv : variables)
+ $The ideals ii and jj will be compared in the ring h[0,1](D).$
+ $ii and jj are re-parsed.$
+ $Example 1: [ [((1-x) Dx + h)]  [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $
+]] putUsages
+
+/ecart.01Order {
+  /arg1 set
+  [/in-ecart.01Order /vv /tt /dvv /wv1 /wv2 
+  ] pushVariables
+  [
+     /vv arg1 def
+     vv isString { [ vv to_records pop] /vv set }
+     { } ifelse
+     vv { toString} map /vv set
+
+     vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set
+     dvv { 1 } map /wv1 set
+     /arg1 [wv1] def
+  ] pop 
+  popVariables
+  arg1
+} def
+/ecart.homogenize01Ideal {
+ /arg1 set
+ [/in.ecart.homogenize01Ideal /ll /vv /wv /ans] pushVariables
+ [
+   /ll arg1 0 get def
+   /vv arg1 1 get def
+   vv isArray { vv from_records /vv set } {  } ifelse
+   vv ecart.01Order /wv set
+   [vv ring_of_differential_operators 0] define_ring
+   ll ,,, /ll set ll dehomogenize /ll set
+   [ll vv wv] gb 0 get /ll set
+
+   ecart.begin
+   [vv ring_of_differential_operators
+    vv ecart.stdOrder weight_vector 0
+    [(weightedHomogenization) 1]] define_ring
+   ll ,,, {ecart.homogenize01 ecart.dehomogenizeH} map /ans set
+   ecart.end
+   /arg1 ans def
+ ] pop
+ popVariables
+ arg1
+} def
+[(ecart.homogenize01Ideal)
+[([ii vv] ecartd.homogenize01Ideal)
+ (ii : ideal, vv : variables)
+ $The ideal ii is homogenized in h[0,1](D).$
+ $Example 1: [ [((1-x) Dx + 1)] (x)] ecart.homogenize01Ideal $
+]] putUsages
+
 
 
 ( ) message-quiet