===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/gfan.sm1,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -p -r1.8 -r1.9
--- OpenXM/src/kan96xx/Doc/gfan.sm1	2004/10/13 23:36:52	1.8
+++ OpenXM/src/kan96xx/Doc/gfan.sm1	2005/06/30 08:39:39	1.9
@@ -1,7 +1,8 @@
-%  $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.7 2004/09/30 07:45:04 takayama Exp $
+%  $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.8 2004/10/13 23:36:52 takayama Exp $
 % cp cone.sm1 $OpenXM_HOME/src/kan96xx/Doc/gfan.sm1
-% $Id: gfan.sm1,v 1.8 2004/10/13 23:36:52 takayama Exp $
+% $Id: gfan.sm1,v 1.9 2005/06/30 08:39:39 takayama Exp $
 % iso-2022-jp
+%%Ref:  @s/2004/08/21-note.pdf
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %% Two examples are given below to get a global Grobner fan and 
@@ -12,7 +13,7 @@
 %% How to input data?  An example.   (cf. test13.sm1)
 %%  Modify the following or copy the /cone.sample { ... } def 
 %%  to your own file, 
-%%  edit it, and execute if by  " cone.sample ; "
+%%  edit it, and execute it by  " cone.sample ; "
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 /cone.sample {
   cone.load.cohom
@@ -96,7 +97,7 @@ getGrobnerFan
 printGrobnerFan 
 
 %%%% If you want to save the data to the file sm1out.txt, then uncomment.
-% /cone.wightGblist 1 def saveGrobnerFan /ff set ff output 
+% /cone.withGblist 1 def saveGrobnerFan /ff set ff output 
 
 %%%% Step 2. Dehomogenize the Grobner Cones 
 %%%%  by the equivalence relation in a local ring (uncomment).
@@ -213,7 +214,7 @@ getGrobnerFan
 printGrobnerFan 
 
 %%%% If you want to save the data to the file sm1out.txt, then uncomment.
-% /cone.wightGblist 1 def saveGrobnerFan /ff set ff output 
+% /cone.withGblist 1 def saveGrobnerFan /ff set ff output 
 
 %%%% Step 2. Dehomogenize the Grobner Cones 
 %%%%  by the equivalence relation in a local ring (uncomment).
@@ -290,8 +291,10 @@ dhcone.printGrobnerFan 
      /dh.autoHomogenize 0 def
      [(AutoReduce) 1] system_variable
      [ff { toString } map cone.vv 
-      [ww cone.vv generateD1_1]] dh.gb 0 get /arg1 set
+      [ww cone.vv generateD1_1]] ff getAttributeList setAttributeList
+     dh.gb 0 get /arg1 set
   ] pop
+  popVariables
   arg1 
 } def
 
@@ -2027,7 +2030,8 @@ def
     [(AutoReduce) 1] system_variable
     [cone.vv ring_of_differential_operators
      [ww] weight_vector 0] define_ring
-    [ff {toString .} map] groebner 0 get /gg set
+    [ff {toString .} map] ff getAttributeList setAttributeList 
+    groebner 0 get /gg set
     /cone.gb_Dh.g gg def
     /arg1 gg def
   ] pop
@@ -2323,22 +2327,25 @@ def   
 } def
 
 %<
-% usages: getNextFlip [cone, k]
+% usages: getNextFlip [cone, k, cid]
 % cone.fan を検索して まだ flip してない cone と facet の組を戻す.
 % もうないときには null を戻す.
+% cid は cone が cone.fan の 何番目であるかの index.  cone.gblist の検索等に
+% 用いる.
 %>
 /getNextFlip {
-  [/tcone /ans /ii ] pushVariables
+  [/tcone /ans /ii /cid] pushVariables
   [ 
-    /ans null def
+    /ans null def /cid -1 def
     0 1 cone.fan length 1 sub {
       /ii set
       cone.fan  ii get /tcone set
+      /cid ii def
       tcone getNextFacet /ans set
       ans tag 0 eq { } { exit } ifelse
     } for
     ans tag 0 eq { /arg1 null def }
-    { /arg1 [tcone ans] def } ifelse
+    { /arg1 [tcone ans cid] def } ifelse
   ] pop 
   popVariables
   arg1 
@@ -2348,6 +2355,7 @@ def   
 %   flip の時の epsilon
 /cone.epsilon (1).. (10).. div def
 /cone.epsilon.limit (1).. (100).. div def
+% cone.epsilon.limit を負にすれば停止しない.
 
 %<
 %  Usages: result_getNextFlip getNextCone ncone
@@ -3412,3 +3420,209 @@ def   
 %  
 
 % Todo: save functions. 
+
+%<
+% Collart, Kalkbrener, Mall のアルゴリズムによる gb の flip.
+% See also Sturmfels' book, p.22, 23.
+% Usages: [reducedGb, vlist, oldWeight, facetWeight, newWeight] ckmFlip rGb
+%  If it fails, then it returns null, else it returns the reducedGb for the
+%  newWeight.
+%  gb の check をやるので, それに失敗したら null を戻す.
+%  weight はすべて vw 形式で. vw 形式 = variable weight の繰り返しの形式
+%  reducedGb は文字列のリストではなく多項式の形式のこと.
+%>
+/ckmFlip {
+  /arg1 set
+  [/arg_ckmFlip /gOld /vlist /oldWeight /facetWeight /newWeight
+   /gNew  
+   /ww /ww1 /ww2  % 本の中の w1, w, w2  (古い, facet, 新しい)
+   /ch1 /ch2      % 本の中の {\cal H}_1, {\cal H}_2
+   /grData  /rTable 
+   /rTable2 % rTable の反対の変換.
+   /facetWeight_gr /vlist_gr  % graded ring 用.
+   /oldWeight_gr 
+   /ccf  % reduction した係数.
+   /rwork /ccf2 /gNew
+  ] pushVariables
+  [
+    arg1 /arg_ckmFlip set
+    arg_ckmFlip 0 get /gOld set
+    arg_ckmFlip 1 get /vlist set
+    arg_ckmFlip 2 get /oldWeight set
+    arg_ckmFlip 3 get /facetWeight set
+    arg_ckmFlip 4 get /newWeight set
+
+% facet weight vector ww についての initial を取り出す. ch1 へいれる.
+    gOld getRing ring_def
+    facetWeight weightv /ww set
+    gOld { ww init } map /ch1 set  % facetWeight による initial の取り出し.
+
+
+%  例: [(x,y) [(x) -1 (Dx) 1 (y) -1 (Dy) 2]] getGrRing 
+%      [$x,y,y',$ , [    $x$ , $y$ ]  , [    [    $Dy$ , $y'$ ]  ]  ] 
+%       変数リスト                            置換表
+%  ch1 を gr_ww の元に変換.
+    [vlist facetWeight] getGrRing /grData set
+    [grData 0 get ring_of_differential_operators 0]  define_ring /rwork set
+    grData 2 get { { . } map } map /rTable set
+    rTable { reverse } map /rTable2 set
+    grData 0 get /vlist_gr set
+    ch1 { toString . rTable replace toString } map /ch1 set
+
+    oldWeight { dup isString { . rTable replace toString }
+                               { } ifelse } map /oldWeight_gr set
+
+% facetWeight も 新しい環 gr_ww  の weight に変換.
+% 例. [(x) -1 (Dx) 1 (y) -1 (Dy) 2] ==> [(x) -1 (Dx) 1 (y) -1 (y') 2]
+    facetWeight { dup isString { . rTable replace toString }
+                               { } ifelse } map /facetWeight_gr set
+% Dx x = x Dx + h H  or Dx x = x Dx + h^2 で計算.  
+% どちらをとるかは cone.gb_gr で区別するしかなし
+    %% [ch1 vlist_gr oldWeight_gr] /ttt set 
+    %% ttt cone.gb_gr /ch1 set %再度の計算は不要.
+    [[(1)] vlist_gr oldWeight_gr] cone.gb_gr getRing ring_def % Set Ring.
+    ch1 {toString .} map  /ch1 set
+%% ここまででとりあえずテストをしよう.
+%%    ch1 /arg1 set
+% newWeight も 新しい環 gr_ww  の weight に変換.
+% 例. [(x) -1 (Dx) 1 (y) -1 (Dy) 2] ==> [(x) -1 (Dx) 1 (y) -1 (y') 2]
+    newWeight { dup isString { . rTable replace toString }
+                               { } ifelse } map /newWeight_gr set
+    [ch1 { toString } map vlist_gr newWeight_gr] cone.gb_gr /ch2 set
+
+% Dx x = x Dx + h H  or Dx x = x Dx + h^2 で計算.  
+% どちらをとるかは cone.reduction_gr で区別するしかなし
+    ch1 getRing ring_def ;
+    ch2 {toString .} map {ch1 cone.reduction} map /ccf set
+    %ccf pmat 
+    % とりあえずテスト.
+    % [ch1 ch2] /arg1 set
+    %% ccf[i][0] は 0 でないと矛盾.  check まだしてない.
+
+    %% ccf[i][2] (syzygy) を gr から もとの ring へ戻し, 
+    %% 新しい reduced gbasis を ccf[i][2] * gOld で作る.
+    rwork ring_def
+    ccf { 2 get {toString  . rTable2 replace toString} map } map /ccf2 set
+    %% ccf2 は gr でない ring の元.
+    gOld getRing ring_def
+    cone.beginH  % Hh か h^2 か.
+    ccf2 { {.} map gOld mul } map /gNew set
+    gNew { toString } map /gNew set
+    cone.endH
+    % gNew /arg1 set
+    %gNew が newWeight での GB か check. Yes なら reduced basis へ.
+    %No なら null を戻す. 
+    gNew [(gbCheck) 1] setAttributeList newWeight 
+       cone.gb (gb) getAttribute 
+    1 eq {
+     gNew [(reduceOnly) 1] setAttributeList newWeight cone.gb /arg1 set
+    }{ /arg1 null def } ifelse
+  ] pop
+  popVariables
+  arg1 
+} def
+
+%<
+% Usages: f gbasis cone.reduction_DhH
+%>
+/cone.reduction_DhH {
+  /arg2 set /arg1 set
+  [/ff /ggbasis /eenv /ans] pushVariables
+  [  
+    /ff arg1 def /ggbasis arg2 def
+    cone.beginH
+    ff ggbasis reduction /ans set
+    cone.endH
+    /arg1 ans def
+  ] pop
+  popVariables
+  arg1
+} def
+
+/cone.begin_DhH {
+  [(Homogenize) (AutoReduce) (KanGBmessage)] pushEnv /cone.eenv set
+  [(Homogenize) 3] system_variable
+} def
+
+/cone.end_DhH {
+  cone.eenv popEnv
+} def
+
+/test1.ckmFlip {
+ % cf. cone.sample2
+   cone.load.cohom
+ /cone.comment [
+   (BS for y and y-(x-1)^2, t1, t2 space, in doubly homogenized Weyl algebra.) nl
+   (The Grobner cones are dehomogenized to get local Grobner fan.) nl
+ ] cat def
+ /cone.vlist [(t1) (t2) (x) (y) (Dt1) (Dt2) (Dx) (Dy) (h) (H)] def
+ /cone.vv (t1,t2,x,y) def
+ /cone.type 1 def
+ /cone.parametrizeWeightSpace {
+   4 2 parametrizeSmallFan
+ } def
+ /cone.local 1 def	
+ /cone.w_start  null def   
+ /cone.h0 1 def
+ /cone.input 
+   [
+     (t1-y) (t2 - (y-(x-1)^2))  
+     ((-2 x + 2)*Dt2+Dx)
+     (Dt1+Dt2+Dy)
+   ]
+ def
+ % homogenize
+   [cone.vv ring_of_differential_operators
+    [[(t1) -1 (t2) -1 (Dt1) 1 (Dt2) 1]] ecart.weight_vector 
+   0] define_ring
+   dh.begin
+   cone.input { . homogenize toString } map /cone.input set
+   dh.end
+
+ /cone.gb {
+   cone.gb_DhH
+ } def
+
+ /cone.reduction {
+   cone.reduction_DhH
+ } def
+
+ /cone.beginH {
+   cone.begin_DhH
+ } def
+ /cone.endH {
+   cone.end_DhH
+ } def
+% テストを開始する.
+ /cone.gb_gr {
+  /arg1 set
+  [/ff /ww /vv] pushVariables
+  [
+     /ff arg1 0 get def
+     /vv arg1 1 get def
+     /ww arg1 2 get def
+     /dh.gb.verbose 1 def
+     /dh.autoHomogenize 0 def
+     [(AutoReduce) 1] system_variable
+     [ff { toString } map vv
+      [ww vv generateD1_1]] dh.gb 0 get /arg1 set
+  ] pop
+  popVariables
+  arg1 
+ } def
+
+% getStartingCone /cone.ncone set
+% cone.ncone updateFan 
+% cone.gblist 0 get message
+% cone.ncone /cone.ccone set
+% getNextFlip /cone.nextflip set
+% cone.nextflip message
+ 
+ /wOld  [(t1) , -29 , (t2) , -38 , (Dt1) , 29 , (Dt2) , 38 ]  def
+ /wFacet [(t1) , -1 , (t2) , -1 , (Dt1) , 1 , (Dt2) , 1 ]  def
+ /wNew  [(t1) , -39 , (t2) , -38 , (Dt1) , 39 , (Dt2) , 38 ]  def
+ cone.input wOld cone.gb /ff set
+ [ff (t1,t2,x,y) wOld wFacet wNew] ckmFlip /ff2 set
+ (See ff and ff2) message  
+
+} def