[BACK]Return to gfan.sm1 CVS log [TXT][DIR] Up to [local] / OpenXM / src / kan96xx / Doc

Diff for /OpenXM/src/kan96xx/Doc/gfan.sm1 between version 1.1 and 1.3

version 1.1, 2004/09/05 10:19:29 version 1.3, 2004/09/14 08:30:47
Line 1 
Line 1 
 % $OpenXM$  %  $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.2 2004/09/09 08:50:12 takayama Exp $
 % cp cone.sm1 $OpenXM_HOME/src/kan96xx/Doc/gfan.sm1  % cp cone.sm1 $OpenXM_HOME/src/kan96xx/Doc/gfan.sm1
 % $Id$  % $Id$
 % iso-2022-jp  % iso-2022-jp
Line 10 
Line 10 
  [(parse) (ox.sm1) pushfile] extension   [(parse) (ox.sm1) pushfile] extension
 } ifelse  } ifelse
   
   %
   % cone.fan, cone.gblist $B$K(B fan $B$N%G!<%?$,$O$$$k(B.
   %
   
   %%%%<<<<  $B=i4|%G!<%?$N@_DjNc(B  data/test13 $B$h$j(B.  <<<<<<<<<<<<<<
   /cone.sample.test13 {
    /cone.loaded boundp { }
    {
     [(parse) (cohom.sm1) pushfile] extension
     [(parse) (cone.sm1) pushfile] extension
     /cone.loaded 1 def
    } ifelse
   /cone.comment [
     (Toric ideal for 1-simplex x 2-simplex, in k[x]) nl
   ] cat def
   %------------------Globals----------------------------------------
 % Global: cone.type  % Global: cone.type
 % $B$I$N(B exponents $B$r<h$j=P$9$N$+;XDj$9$k(B.  % $B$I$N(B exponents $B$r<h$j=P$9$N$+;XDj$9$k(B.
 % cf. exponents, gbext  h $B$d(B H $B$b8+$k$+(B?  % cf. exponents, gbext  h $B$d(B H $B$b8+$k$+(B?
Line 20 
Line 36 
   
 % Global: cone.local  % Global: cone.local
 % cone.local: Local $B$+(B?  1 $B$J$i(B local  % cone.local: Local $B$+(B?  1 $B$J$i(B local
   /cone.local 0 def
   
   
   % Global: cone.h0
   % cone.h0:  1 $B$J$i(B h $B$N(B weight 0 $B$G$N(B Grobner fan $B$r7W;;$9$k(B.
   /cone.h0 1 def
   
   % ---------------  $BF~NO%G!<%?MQBg0hJQ?t$N@_Dj(B --------------------------
   %
   % cone.input : $BF~NOB?9`<07O(B
   /cone.input
     [
       (x11 x22 - x12 x21) (x12 x23 - x13 x22)
       (x11 x23 - x13 x21)
     ]
   def
   
   % cone.vlist : $BA4JQ?t$N%j%9%H(B
   /cone.vlist [(x11) (x12) (x13) (x21) (x22) (x23)
                (Dx11) (Dx12) (Dx13) (Dx21) (Dx22) (Dx23) (h)] def
   
   % cone.vv : define_ring $B7A<0$NJQ?t%j%9%H(B.
   /cone.vv (x11,x12,x13,x21,x22,x23) def
   
   % cone.parametrizeWeightSpace : weight $B6u4V$r(B parametrize $B$9$k4X?t(B.
   %   $BBg0hJQ?t(B cone.W , cone.Wpos $B$b$-$^$k(B.
   /cone.parametrizeWeightSpace {
     6 6 parametrizeSmallFan
   } def
   
   % cone.w_start : weight$B6u4V$K$*$1$k(B weight $B$N=i4|CM(B.
   % $B$3$NCM$G(B max dim cone $B$,F@$i$l$J$$$H(B random weight $B$K$h$k(B $B%5!<%A$,;O$^$k(B.
   % random $B$K$d$k$H$-$O(B null $B$K$7$F$*$/(B.
   /cone.w_start
     [9 8 5 4 5 6]
   def
   
   % cone.gb : gb $B$r7W;;$9$k4X?t(B.
   /cone.gb {
     cone.gb_Dh
   } def
   
   
   
   ( ) message
   cone.comment message
   (cone.input = ) messagen cone.input message
   (Type in getGrobnerFan) message
   (Do clearGlobals if necessary) message
   (printGrobnerFan ; saveGrobnerFan /ff set ff output ) message
   
   } def
   %%%%%%>>>>>  $B=i4|%G!<%?$N@_DjNc$*$o$j(B >>>>>>>>>>>>>>>>>>>>>>
   
   % Global: cone.type
   % $B$I$N(B exponents $B$r<h$j=P$9$N$+;XDj$9$k(B.
   % cf. exponents, gbext  h $B$d(B H $B$b8+$k$+(B?
   % 0 : x,y,Dx,Dy
   % 1 : x,y,Dx,Dy,h,H
   % 2 : x,y,Dx,Dy,h
   /cone.type 2 def
   
   % Global: cone.local
   % cone.local: Local $B$+(B?  1 $B$J$i(B local
 /cone.local 1 def  /cone.local 1 def
   
 % Global: cone.h0  % Global: cone.h0
Line 88 
Line 168 
     ww to_int32 /ww set % univNum $B$,$"$l$P(B int32 $B$KD>$7$F$*$/(B.      ww to_int32 /ww set % univNum $B$,$"$l$P(B int32 $B$KD>$7$F$*$/(B.
     /ww2 ww weightv def  % v-w $B7A<0$r(B $B?t;z$N%Y%/%H%k$K(B. (init $BMQ(B)      /ww2 ww weightv def  % v-w $B7A<0$r(B $B?t;z$N%Y%/%H%k$K(B. (init $BMQ(B)
   
     /eqs [ ] def % $BITEy<07O$N78?t(B      /eqs null def % $BITEy<07O$N78?t(B
     /gsize g length def      /gsize g length def
     0 1 gsize 1 sub {      0 1 gsize 1 sub {
       /i set        /i set
Line 101 
Line 181 
         % in_ww(f) > f_j $B$H$J$k9`$N=hM}(B.          % in_ww(f) > f_j $B$H$J$k9`$N=hM}(B.
         iterms 1 exps length 1 sub {          iterms 1 exps length 1 sub {
            /j set             /j set
            eqs [expsTop exps j get  sub] join /eqs set             expsTop exps j get sub    eqs cons /eqs set
            % exps[0]-exps[j] $B$r(B eqs $B$X3JG<$7$F$$$/(B.             % exps[0]-exps[j] $B$r(B eqs $B$X3JG<$7$F$$$/(B.
         } for          } for
         % in_ww(f) = f_j $B$H$J$k9`$N=hM}(B.          % in_ww(f) = f_j $B$H$J$k9`$N=hM}(B.
         [(exponents) f ww2 init cone.type] gbext /exps set % exps $B$O(B in(f)          [(exponents) f ww2 init cone.type] gbext /exps set % exps $B$O(B in(f)
         1 1 iterms 1 sub {          1 1 iterms 1 sub {
           /j set            /j set
           eqs [exps j get expsTop sub] join /eqs set            exps j get expsTop sub   eqs cons /eqs set
           eqs [expsTop exps j get sub] join /eqs set            expsTop exps j get sub   eqs cons /eqs set
           % exps[j]-exps[0], exps[0]-exps[j] $B$r3JG<(B.            % exps[j]-exps[0], exps[0]-exps[j] $B$r3JG<(B.
           % $B7k2LE*$K(B (exps[j]-exps[0]).w = 0 $B$H$J$k(B.            % $B7k2LE*$K(B (exps[j]-exps[0]).w = 0 $B$H$J$k(B.
         }  for          }  for
       } { } ifelse        } { } ifelse
     } for      } for
       eqs listToArray reverse /eqs set
     /arg1 eqs def      /arg1 eqs def
   ] pop    ] pop
   popVariables    popVariables
Line 720  def
Line 801  def
     polydata (FACETS) getNode 2 get 0 get to_univNum      polydata (FACETS) getNode 2 get 0 get to_univNum
     { nnormalize_vec} map /facets set      { nnormalize_vec} map /facets set
     [[ ] ] facets join shell rest removeFirstFromPolymake /facets set      [[ ] ] facets join shell rest removeFirstFromPolymake /facets set
       facets length 0 eq
       {(Internal  error. Facet data is not obtained. See OpenXM_tmp.) error} { } ifelse
 % vertices $B$O(B cone $B$N>e$K$"$k$N$G@0?tG\(B OK. $B@55,$+$9$k(B.  % vertices $B$O(B cone $B$N>e$K$"$k$N$G@0?tG\(B OK. $B@55,$+$9$k(B.
     polydata (VERTICES) getNode 2 get 0 get to_univNum      polydata (VERTICES) getNode 2 get 0 get to_univNum
     { nnormalize_vec} map /vertices set      { nnormalize_vec} map /vertices set
Line 787  def
Line 870  def
 } def  } def
   
 %<  %<
   % Usages: [gb weight] newConeGB
   %  gb $B$H(B weight $B$r(B tree $B7A<0$K$7$F3JG<$9$k(B.
   %>
   /newConeGB {
     /arg1 set
     [/gbdata  /gg /ww /rr] pushVariables
     [
       /gbdata arg1 def
   % gb
       gbdata 0 get /gg set
   % weight
       gbdata 1 get /ww set
   %
       [(coneGB) [ ]
        [
         [(grobnerBasis) [ ] gg]  arrayToTree
         [(weight) [ ] [ww]] arrayToTree
         [(initial) [ ] gg { ww 2 get weightv init } map ] arrayToTree
        ]
       ] arrayToTree /rr set
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   
   %<
 % Usages: cone_random  % Usages: cone_random
 %>  %>
 /cone_random.start  (2)..  def  /cone_random.start  (2)..  def
Line 1196  def
Line 1306  def
 %<  %<
 % Usages:  pruneZeroVector  % Usages:  pruneZeroVector
 %    genPo, getConeInfo $BEy$NA0$K;H$&(B.  0 $B%Y%/%H%k$O0UL#$N$J$$@)Ls$J$N$G=|$/(B.  %    genPo, getConeInfo $BEy$NA0$K;H$&(B.  0 $B%Y%/%H%k$O0UL#$N$J$$@)Ls$J$N$G=|$/(B.
   %    $BF1$8@)Ls>r7o$b$N$>$/(B. polymake FACET $B$,@5$7$/F0$+$J$$>l9g$,$"$k$N$G(B.
   %    cf. pear/OpenXM_tmp/x3y2.poly, x^3+y^2, x^2+y^3 data/test15.sm1
 %>  %>
 /pruneZeroVector {  /pruneZeroVector {
   /arg1 set    /arg1 set
Line 1203  def
Line 1315  def
   [    [
     /mm arg1 def      /mm arg1 def
     mm to_univNum /mm set      mm to_univNum /mm set
       [ [ ] ] mm join shell rest uniq /mm set
     [      [
       0 1 mm length 1 sub {        0 1 mm length 1 sub {
          /ii set           /ii set
Line 1711  def   
Line 1824  def   
      wv_start pmat       wv_start pmat
 %[3] reduced GB $B$N7W;;(B.  %[3] reduced GB $B$N7W;;(B.
      cone.input wv_start cone.gb /reduced_G set       cone.input wv_start cone.gb /reduced_G set
      (Reduced GB : ) message       (Reduced GB is obtained: ) message
      reduced_G pmat       %reduced_G pmat
        /cone.cgb reduced_G def
        [cone.w_start w_start wv_start] /cone.cgb_weight set
   
 %[4] $B<M1F$7$F$+$i(B polytope $B$N%G!<%?$r7W;;(B.  %[4] $B<M1F$7$F$+$i(B polytope $B$N%G!<%?$r7W;;(B.
      wv_start reduced_G coneEq /cone.g_ineq set       wv_start reduced_G coneEq /cone.g_ineq set
Line 1731  def   
Line 1846  def   
      cone.cinit 0 get 0 get to_int32 cone.m eq { exit }       cone.cinit 0 get 0 get to_int32 cone.m eq { exit }
      {       {
        (Failed to get the max dim cone. Updating the weight ...) messagen         (Failed to get the max dim cone. Updating the weight ...) messagen
        /w_start  cone.m cone_random_vec cone.W mul def         cone.m cone_random_vec /cone.w_start set
          /w_start  cone.w_start cone.W mul def
 % cone.cinit $B$r:FEY7W;;$9$k$?$a$K(B clear $B$9$k(B.  % cone.cinit $B$r:FEY7W;;$9$k$?$a$K(B clear $B$9$k(B.
        /cone.cinit null def         /cone.cinit null def
      } ifelse       } ifelse
Line 1833  def   
Line 1949  def   
 /cone.fan [  ] def  /cone.fan [  ] def
 % global: cone.incidence  % global: cone.incidence
 /cone.incidence [ ] def  /cone.incidence [ ] def
   % global: cone.gblist   gb's standing for each cones in cone.fan.
   /cone.gblist [ ] def
   
 /updateFan {  /updateFan {
   /arg1 set    /arg1 set
Line 1840  def   
Line 1958  def   
   [    [
     /ncone arg1 def      /ncone arg1 def
     /cone.fan.n  cone.fan length def      /cone.fan.n  cone.fan length def
   % -1.  cone.cgb ($BD>A0$K7W;;$5$l$?(B gb) $B$H(B cone.cgb_weight ($BD>A0$N7W;;$N(B weight)
   %    $B$r(B cone.gblist $B$X3JG<$9$k(B.
       cone.gblist [ [cone.cgb cone.cgb_weight] newConeGB ] join /cone.gblist set
 % 0. ncone $B$,(B cone.fan $B$K$9$G$K$"$l$P%(%i!<(B  % 0. ncone $B$,(B cone.fan $B$K$9$G$K$"$l$P%(%i!<(B
     0 1 cone.fan.n 1 sub {      0 1 cone.fan.n 1 sub {
       /kk set        /kk set
Line 1922  def   
Line 2043  def   
    (Trying new weight [w,wv] is ) messagen next_weight_w_wv message     (Trying new weight [w,wv] is ) messagen next_weight_w_wv message
   
    cone.input next_weight_w_wv 1 get cone.gb /cone.cgb set     cone.input next_weight_w_wv 1 get cone.gb /cone.cgb set
      [w] next_weight_w_wv join /cone.cgb_weight set
    next_weight_w_wv 1 get cone.cgb coneEq /cone.g_ineq set     next_weight_w_wv 1 get cone.cgb coneEq /cone.g_ineq set
    cone.g_ineq cone.w_ineq join cone.Wt mul cone.Lpt mul     cone.g_ineq cone.w_ineq join cone.Wt mul cone.Lpt mul
    pruneZeroVector /cone.gw_ineq_projectedWtLpt set     pruneZeroVector /cone.gw_ineq_projectedWtLpt set
Line 1975  def   
Line 2097  def   
     cone.nextflip tag 0 eq { exit } { } ifelse      cone.nextflip tag 0 eq { exit } { } ifelse
     cone.nextflip getNextCone /cone.ncone set      cone.nextflip getNextCone /cone.ncone set
   } loop    } loop
   (Construction  is completed. See cone.fan and cone.incidence.) message  
 } def  
   
     (Construction  is completed. See cone.fan, cone.incidence and cone.gblist.)
     message
   } def
   
   %<
   % Usages: vlist generateD1_1
   %  -1,1  weight $B$r@8@.$9$k(B.
   %  vlist $B$O(B (t,x,y) $B$+(B [(t) (x) (y)]
   %
   %>
   /generateD1_1 {
     /arg1 set
     [/vlist /rr /rr /ii /vv] pushVariables
     [
       /vlist arg1 def
       vlist isString {
         [vlist to_records pop] /vlist set
       } {  } ifelse
       [
         0 1 vlist length 1 sub {
           /ii set
           vlist ii get /vv set
           vv -1
           [@@@.Dsymbol vv] cat 1
         } for
       ] /rr set
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   
   /listNodes {
     /arg1 set
     [/in-listNodes /ob /rr /rr /ii] pushVariables
     [
       /ob arg1 def
       /rr [ ] def
       {
         ob isClass {
           ob (array) dc /ob set
         } { exit } ifelse
         rr [ob 0 get] join /rr set
         ob 2 get /ob set
         0 1 ob length 1 sub {
            /ii set
            rr ob ii get listNodes join /rr set
         } for
         exit
       } loop
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   [(listNodes)
   [(ob listNodes)
    (cf. getNode)
    (Example:)
    (  /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
    (  /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
    (  /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
    (  ma listNodes )
   ]] putUsages
   
   %<
   % Usages:  obj printTree
   %>
   /printTree {
     /arg1 set
     [/ob /rr /rr /ii /keys /tt] pushVariables
     [
       /ob arg1 def
       /rr [ ] def
       /keys ob listNodes def
       keys 0 get /tt set
       keys rest /keys set
       keys { ob 2 1 roll getNode } map /rr set
       (begin ) messagen  tt messagen
       ( ---------------------------------------) message
       0 1 rr length 1 sub {
          /ii set
          keys ii get messagen (=) message
          rr ii get 2 get pmat
       } for
       (--------------------------------------- end ) messagen
       tt message
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   
   %<
   % Usages $B$O(B (inputForm) usages $B$r$_$h(B.
   %>
   /inputForm {
     /arg1 set
     [/ob /rr /i ] pushVariables
     [
       /ob  arg1 def
       /rr [ ] def
       {
        ob isArray {
          rr [ ([) ] join /rr set
          0 1 ob length 1 sub {
            /i set
            i ob length 1 sub lt {
              rr [ob i get inputForm $ , $] join /rr set
            } {
              rr [ob i get inputForm] join /rr set
            } ifelse
          } for
          rr [ (]) ] join cat /rr set
          exit
        } { } ifelse
        ob isClass {
          ob etag 263 eq { % tree
            /rr ob inputForm.tree def exit
          } { /rr [( $ this etag is not implemented $ )] cat def exit  } ifelse
        } {  } ifelse
        ob isUniversalNumber {
          [$($ ob toString $)..$] cat /rr set
          exit
        } {  } ifelse
        ob isPolynomial {
          [$($ ob toString $).$] cat /rr set
          exit
        } {  } ifelse
        ob isRational {
          [$ $ ob (numerator) dc inputForm $ $
               ob (denominator) dc inputForm $ div $ ] cat /rr set
          exit
        } {  } ifelse
        ob isString {
          [$($ ob $)$ ] cat /rr set
          exit
        } {  } ifelse
        ob toString /rr set
        exit
       } loop
       rr /arg1 set
     ] pop
     popVariables
     arg1
   } def
   [(inputForm)
    [(obj inputForm str)
   ]] putUsages
   % should be moved to dr.sm1
   
   /inputForm.tree {
     /arg1 set
     [/ob /key /rr /rr /ii] pushVariables
     [
       /ob arg1 def
       /rr [ ] def
       {
         ob (array) dc /ob set
         /rr [ $[$ ob 0 get inputForm $ , $
               ob 1 get inputForm $ , $
             ] def
         rr  [ob 2 get inputForm ] join /rr set
         rr [$ ] $] join /rr set
         rr [ $ [(class) (tree)] dc $ ] join /rr set
         rr cat /rr set
         exit
       } loop
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   
   %<
   % Usages: str inputForm.value str
   %>
   /inputForm.value {
     /arg1 set
     [/key /val /valstr /rr] pushVariables
     [
       arg1 /key set
       key isString { } {(inputForm.value: argument must be a string) error } ifelse
       key boundp {
        [(parse) key] extension pop
        /val set
        val inputForm /valstr set
        [( ) valstr ( /) key ( set )] cat /rr set
       } {
        /valstr [] cat /rr set
       } ifelse
       rr /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   % global: cone.withGblist
   /cone.withGblist 0 def
   %<
   % Usages:  saveGrobnerFan  str
   %  GrobnerFan $B$N%G!<%?$r(B inputForm $B$KJQ99$7$FJ8;zNs$KJQ$($k(B.
   %  $B$3$N%G!<%?$r(B parse $B$9$k$H(B GrobnerFan $B$rF@$k$3$H$,2DG=(B.
   %  BUG: $BB?9`<0$NB0$9$k4D$N%G!<%?$NJ]B8$O$^$@$7$F$J$$(B.
   %>
   /saveGrobnerFan {
     [/rr] pushVariables
     [
       (cone.withGblist=) messagen cone.withGblist message
       [
   % $B%f!<%6$N@_Dj$9$k%Q%i%a!<%?(B. cone.gb, cone.parametrizeWeightSpace $BEy$N4X?t$b$"$j(B.
         (cone.comment)
         (cone.type)  (cone.local) (cone.h0)
         (cone.vlist) (cone.vv)
         (cone.input)
   
   % $B%W%m%0%i%`Cf$GMxMQ$9$k(B, $BBg;v$JBg0hJQ?t(B.  weight vector $B$N<M1F9TNs$,=EMW(B.
         (cone.n) (cone.m) (cone.d)
         (cone.W) (cone.Wpos) (cone.Wt)
         (cone.L) (cone.Lp) (cone.Lpt)
         (cone.weightBorder)
         (cone.w_ineq)
         (cone.w_ineq_projectedWt)
         (cone.epsilon)
   
   % $B7k2L$NMWLs(B.
         (cone.fan)
         cone.withGblist { (cone.gblist) } {  } ifelse
         (cone.incidence)
   
       ] { inputForm.value  nl } map /rr set
       rr cat /rr set
   % ring $B$r(B save $B$7$F$J$$$N$GEv:B$NBP=h(B.
       [ ([) cone.vv inputForm ( ring_of_differential_operators 0 ] define_ring )
         nl nl rr] cat /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   /printGrobnerFan.1 {
     /arg1 set
     [/key /rr] pushVariables
     [
       /key arg1 def
       key boundp {
         [(parse) key] extension pop /rr set
         rr isArray {
           key messagen ( = ) message  rr pmat
         } {
           key messagen ( = ) messagen rr message
         } ifelse
       }{
         key  messagen ( = ) message
       } ifelse
     ] pop
     popVariables
   } def
   
   /printGrobnerFan {
     [/i] pushVariables
     [
     (==========  Grobner Fan ====================) message
      [
         (cone.comment)
         (cone.vlist) (cone.vv)
         (cone.input)
         (cone.type)  (cone.local) (cone.h0)
         (cone.n) (cone.m) (cone.d)
         (cone.W) (cone.Wpos) (cone.Wt)
         (cone.L) (cone.Lp) (cone.Lpt)
         (cone.weightBorder)
         (cone.incidence)
      ] { printGrobnerFan.1 } map
      (   ) message
      0 1 cone.fan length 1 sub {
        /ii set
        ii messagen ( : ) messagen
        cone.fan ii get printTree
      } for
      cone.withGblist {
       0 1 cone.gblist length 1 sub {
         /ii set
         ii messagen ( : ) messagen
         cone.gblist ii get printTree
       } for
     } {  } ifelse
   
   
     (=========================================) message
     (cone.withGblist = ) messagen cone.withGblist message
     (  ) message
     ] pop
     popVariables
   } def
   
   %<
   % Usages:  m uniq
   % Remove duplicated lines.
   %>
   /uniq  {
     /arg1 set
     [/mm /prev /i /rr] pushVariables
     [
       /mm arg1 def
      {
        mm length 0 eq { [ ] /rr set exit } {  } ifelse
        /prev mm 0 get def
        [
          prev
          1 1 mm length 1 sub {
            /i set
            mm i get prev sub isZero { }
            { /prev mm i get def prev } ifelse
          } for
         ] /rr set
         exit
       } loop
       rr /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   %<
   % Usages: [vlist vw_vector] getGrRing [vlist vGlobal sublist]
   %      example:  [(x,y,z) [(x) -1 (Dx) 1 (y) 1 (Dy) 2]] getGrRing
   %                [(x,y,z,y') [(x)] [[(Dy) (y')]]]
   %  h[0,1](D_0) $B@lMQ$N(B getGrRing.
   %     u_i + v_i > 0 $B$J$i(B  Dx_i ==> x_i' ($B2D49$JJQ?t(B). sublist $B$X(B.
   %     u_i < 0 $B$J$i(B x_i $B$O(B vGlobal $B$X(B.
   %  ii [vlist vGlobal sublist] toGrRing /ii set
   %  [ii jj vlist [(partialEcartGlobalVarX) vGlobal]] ecart.isSameIdeal $B$H;H$&(B.
   %>
   /getGrRing {
     /arg1 set
     [/vlist /vw_vector /ans /vGlobal /sublist /newvlist
      /dlist /tt /i /u /v /k
      ] pushVariables
     [
       /vlist arg1 0 get def
       /vw_vector arg1 1 get def
   
       vlist isString { [vlist to_records pop] /vlist set } { } ifelse
       vlist { toString } map /vlist set
   % dlist $B$O(B [(Dx) (Dy) (Dz)] $B$N%j%9%H(B.
       vlist { /tt set [@@@.Dsymbol tt] cat } map /dlist set
   
       /newvlist [ ] def /sublist [ ] def /vGlobal [ ] def
   % $B2D49$J?7$7$$JQ?t$r(B newvlist $B$X(B. $BCV49I=$r(B sublist $B$X(B.
       0 1 vlist length 1 sub {
         /i set
   %  (u,v) $B$O(B (x_i, Dx_i) $B$KBP$9$k(B weight vector
         /u vlist i get , vw_vector getGrRing.find  def
         u -1 gt {
           vw_vector , u 1 add , get /u set
         }  { /u 0 def } ifelse
   
         /v dlist i get , vw_vector getGrRing.find  def
         v -1 gt {
           vw_vector , v 1 add , get /v set
         }  { /v 0 def } ifelse
         u to_int32 /u set , v to_int32 /v set
   
         u v add , 0  gt {
           newvlist [vlist i get]  join /newvlist set
         } {  } ifelse
         u 0 lt {
           vGlobal [vlist i get] join /vGlobal set
         } {  } ifelse
       } for
   
       newvlist { /tt set [ [@@@.Dsymbol tt] cat [tt (')] cat ] } map
       /sublist set
   
       /ans [ vlist , newvlist { /tt set [tt (')] cat } map , join  from_records
              vGlobal sublist] def
       /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   
   %<
   % Usages: a uset getGrRing.find index
   %>
   /getGrRing.find {
      /arg2 set /arg1 set
      [/a /uset /ans /i]  pushVariables
      [
        /a arg1 def /uset arg2 def
        /ans -1 def
        { /ans -1 def
          0 1 , uset length 1 sub {
            /i set
            a tag , uset i get tag eq {
              a , uset i get eq {
                /ans i def  exit
              } { } ifelse
            } { } ifelse
          } for
          exit
        } loop
        /arg1 ans def
      ] pop
      popVariables
      arg1
   } def
   
   %<
   % Usages: g1 g2 isSameGrRing bool
   %  g1, g2 $B$O(B getGrRing $B$NLa$jCM(B.
   %>
   /isSameGrRing {
     /arg2 set /arg1 set
     [/g1 /g2 /ans] pushVariables
     [
       /g1 arg1 def /g2 arg2 def
       {
          /ans 1 def
          g1 0 get , g2 0 get eq { } { /ans 0 def exit } ifelse
          exit
          g1 1 get , g2 1 get eq { } { /ans 0 def exit } ifelse
       } loop
       /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   
   %<
   % Usages:  [[ii i_vw_vector] [jj j_vw_vector] vlist] isSameInGrRing_h
   %>
   /isSameInGrRing_h {
     /arg1 set
     [/ii /i_vw_vector /jj /j_vw_vector /vlist
      /i_gr /j_gr /rrule /ans] pushVariables
     [
       /ii arg1 [0 0] get def
       /i_vw_vector arg1 [0 1] get def
       /jj arg1 [1 0] get def
       /j_vw_vector arg1 [1 1] get def
       /vlist arg1 2 get def
       {
         [vlist i_vw_vector] getGrRing /i_gr set
         [vlist j_vw_vector] getGrRing /j_gr set
         i_gr j_gr isSameGrRing {  } { /ans [0 [i_gr j_gr]] def exit} ifelse
   
   % bug: in case of module
         [i_gr 0 get , ring_of_differential_operators 0] define_ring
   
   % H $B$r(B 1 $B$K(B.
         /rrule [ [@@@.Hsymbol . (1).] ] def
   
         i_gr 2 get length 0 eq {
         } {
           rrule i_gr 2 get  { { . } map } map join /rrule set
         } ifelse
         ii { toString . rrule replace toString } map /ii set
         jj { toString . rrule replace toString } map /jj set
   
         [ii jj i_gr 0 get , i_gr 1 get] ecartd.isSameIdeal_h /ans set
         [ans [i_gr] rrule ecartd.isSameIdeal_h.failed]  /ans set
   
         exit
       } loop
       /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   
   /test1.isSameInGrRing_h {
     [(parse) (data/test8-data.sm1) pushfile] extension
   
     cone.gblist 0 get (initial) getNode 2 get /ii set
     cone.gblist 0 get (weight) getNode [2 0 2] get    /iiw set
   
     cone.gblist 1 get (initial) getNode 2 get /jj set
     cone.gblist 1 get (weight) getNode [2 0 2] get    /jjw set
   
     (Doing   [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ff set) message
     [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ff set
   
     ff pmat
   
   } def
   
   
   %<
   % Usages: i j IsSameCone_h  [bool, ...]
   % $B%F%9%HJ}K!(B.  (data/test8.sm1) run  (data/test8-data.sm1) run 0 1 IsSameCone_h
   %>
   /IsSameCone_h {
     /arg2 set /arg1 set
     [/i /j /ans /ii /iiw /jj /jjw] pushVariables
     [
       /i arg1 def /j arg2 def
       cone.debug { (Comparing ) messagen [i j]  message } { } ifelse
   
       cone.gblist i get (initial) getNode 2 get /ii set
       cone.gblist i get (weight) getNode [2 0 2] get    /iiw set
   
       cone.gblist j get (initial) getNode 2 get /jj set
       cone.gblist j get (weight) getNode [2 0 2] get    /jjw set
   
       [ [ii iiw] [jj jjw] cone.vv ] isSameInGrRing_h /ans set
   
       ans /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.3
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>