===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.20
retrieving revision 1.34
diff -u -p -r1.20 -r1.34
--- OpenXM/src/kan96xx/Doc/ecart.sm1	2004/05/04 08:03:30	1.20
+++ OpenXM/src/kan96xx/Doc/ecart.sm1	2004/09/13 11:24:10	1.34
@@ -1,5 +1,6 @@
-% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.19 2004/04/29 12:04:45 takayama Exp $ 
-%[(parse) (hol.sm1) pushfile] extension
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.33 2004/09/10 13:20:22 takayama Exp $ 
+(hol_loaded) boundp { }
+{ [(parse) (hol.sm1) pushfile] extension } ifelse
 %[(parse) (appell.sm1) pushfile] extension
 
 (ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet
@@ -7,6 +8,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 +19,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
@@ -50,7 +60,7 @@
         exit
       } {  } ifelse
 
-      ans [opt i get opt i 1 add get ]  append /ans set
+      ans [opt i get opt i 1 add get ]  join /ans set
       exit
      } loop
     } for 
@@ -80,8 +90,8 @@
      ll (0). eq {
      } {
        ll getRing /rr set
-       ll [ [ (H) rr ,, (1) rr ,, ] 
-            [ (h) rr ,, (1) rr ,, ]] replace
+       ll [ [ @@@.Hsymbol rr __ (1) rr __ ] 
+            [ (h) rr __ (1) rr __ ]] replace
        /ll set
      } ifelse
    } ifelse
@@ -106,7 +116,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 +198,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 +221,9 @@
 
 /ecart.gb {ecartd.gb}  def
 
+[(ecartd.gb)
+[(See ecart.gb)]] putUsages
+
 [(ecart.gb)
  [(a ecart.gb b)
   (array a; array b;)
@@ -234,6 +247,7 @@
   $  [(degreeShift) ds (noAutoHomogenize) 1 (sugar) 1] -->use the sugar strate $
   (  )
   $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 +850,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 +868,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 +912,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 +920,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 +975,7 @@
 
     ecartd.end
 
+    ans getRing (oxRingStructure) dc /ecartd.gb.oxRingStructure set
     %% 
     env1 restoreOptions  %% degreeShift changes "grade"
 
@@ -1542,6 +1557,7 @@
     /univ vars 0 get reverse
           vars 1 get reverse join
     def
+    w-vectors to_int32 /w-vectors set
     [
     0 1 << w-vectors length 1 sub >> 
     {
@@ -1577,11 +1593,11 @@
        /gbasis2 gbasis 0 get def
      } {
        [ [(1)] ] gbasis rest join ecartd.gb 0 get getRing ring_def
-       /gbasis2 gbasis 0 get ,,, def
+       /gbasis2 gbasis 0 get ___ def
      } ifelse
      ecartd.begin
 
-     flist ,,, /flist set
+     flist ___ /flist set
      flist tag 6 eq {
        flist { gbasis2 reduction } map /ans set
      }{
@@ -1614,7 +1630,16 @@
       (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
    (Dx) ggg ecartd.reduction /gg4 set
    gg4 message
-  [gg2  gg3 gg4]
+
+  (----------- 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 {
@@ -1634,11 +1659,11 @@
        /gbasis2 gbasis 0 get def
      } {
        [ [(1)] ] gbasis rest join ecarth.gb 0 get getRing ring_def
-       /gbasis2 gbasis 0 get ,,, def
+       /gbasis2 gbasis 0 get ___ def
      } ifelse
      ecarth.begin
 
-     flist ,,, /flist set
+     flist ___ /flist set
      flist tag 6 eq {
        flist { gbasis2 reduction } map /ans set
      }{
@@ -1660,6 +1685,7 @@
   (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 )] $
@@ -1667,6 +1693,185 @@
   $ (Dx+Dy) ggg ecartd.reduction :: $
 ]] putUsages
 
+/ecartd.reduction_noh {
+  /arg2 set
+  /arg1 set
+  [/in-ecarth.reduction_noh /gbasis /flist] pushVariables
+  [(Homogenize)] pushEnv
+  [
+     /gbasis arg2  def
+     /flist  arg1  def
+     [(Homogenize) 0] system_variable
+     flist gbasis ecartd.reduction /arg1 set
+  ] pop
+  popEnv
+  popVariables
+  arg1
+} def
 
+[(ecartd.reduction_noh)
+[ (f basis ecartd.reduction_noh 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 and)
+  (it should not contain the variable h.  cf. dehomogenize)
+  $h[0,1](D)-homogenization is NOT used.$
+  (cf. reduction, ecartd.gb, ecartd.reduction )
+  $Example:$
+  $ [[( 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 $
+  $ (Dx+Dy) ggg ecartd.reduction_noh :: $
+]] 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 
 
+/ecart_loaded 1 def
\ No newline at end of file