[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.2 and 1.4

version 1.2, 2004/09/09 08:50:12 version 1.4, 2004/09/15 07:41:59
Line 1 
Line 1 
 %  $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.1 2004/09/05 10:19:29 takayama Exp $  %  $OpenXM: OpenXM/src/kan96xx/Doc/gfan.sm1,v 1.3 2004/09/14 08:30:47 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.  <<<<<<<<<<<<<<  %%%%<<<<  $B=i4|%G!<%?$N@_DjNc(B  data/test13 $B$h$j(B.  <<<<<<<<<<<<<<
 /cone.sample.test13 {  /cone.sample.test13 {
  /cone.loaded boundp { }   /cone.loaded boundp { }
Line 164  cone.comment message
Line 168  cone.comment message
     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 177  cone.comment message
Line 181  cone.comment message
         % 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 515  cone.comment message
Line 520  cone.comment message
  $It translates null to (0)..$   $It translates null to (0)..$
 ]] putUsages  ]] putUsages
   
   %<
   % Usages: newVector.with-1
   % (-1).. $B$GKd$a$?%Y%/%H%k$r:n$k(B.
   %>
   /newVector.with-1 {
     newVector { pop (-1).. } map
   } def
   
   
 % [2 0] lcm $B$O(B 0 $B$r$b$I$9$,$$$$$+(B? --> OK.  % [2 0] lcm $B$O(B 0 $B$r$b$I$9$,$$$$$+(B? --> OK.
   
 %<  %<
Line 807  def
Line 821  def
     { nnormalize_vec } map /ineq set      { nnormalize_vec } map /ineq set
     [[ ] ] ineq join shell rest removeFirstFromPolymake /ineq set      [[ ] ] ineq join shell rest removeFirstFromPolymake /ineq set
   
   % nextcid, nextfid $B$r2C$($k(B.  nextcid $B$O(B nextConeId $B$NN,(B. $B$H$J$j$N(B cone $BHV9f(B.
   %                           nextfid $B$O(B nextFacetId $B$NN,(B. $B$H$J$j$N(B cone $B$N(B facet
   %                            $BHV9f(B.
     [(cone) [ ]      [(cone) [ ]
      [       [
       [(facets) [ ] facets]  arrayToTree        [(facets) [ ] facets]  arrayToTree
       [(flipped) [ ] facets length newVector null_to_zero] arrayToTree        [(flipped) [ ] facets length newVector null_to_zero] arrayToTree
       [(facetsv) [ ] facets vertices newCone_facetsv] arrayToTree        [(facetsv) [ ] facets vertices newCone_facetsv] arrayToTree
         [(nextcid) [ ] facets length newVector.with-1 ] arrayToTree
         [(nextfid) [ ] facets length newVector.with-1 ] arrayToTree
       [(vertices) [ ] vertices]  arrayToTree        [(vertices) [ ] vertices]  arrayToTree
       [(inequalities) [ ] ineq] arrayToTree        [(inequalities) [ ] ineq] arrayToTree
      ]       ]
Line 1475  def
Line 1494  def
   popVariables    popVariables
 } def  } def
   
   %<
   % Usages: cone i [cid fid] markNext
   % cone $B$N(B i $BHVL\$N(B facet $B$N$H$J$j$N(B cone id (cid) $B$H(B face id (fid) $B$r@_Dj$9$k(B.
   %   cone $B$N(B nextcid[i] = cid; nextfid[i] = fid $B$H$J$k(B.
   % cone $B<+BN$,JQ99$5$l$k(B.
   % cone $B$O(B class-tree.
   %>
   /markNext {
     /arg3 set /arg2 set /arg1 set
     [/cone /facet_i /vv /nextid] pushVariables
     [
       /cone arg1 def /facet_i arg2 def /nextid arg3 def
       facet_i to_int32 /facet_i set
       cone (nextcid) getNode 2 get /vv set
       vv facet_i , nextid 0 get to_univNum , put
   
       cone (nextfid) getNode 2 get /vv set
       vv facet_i , nextid 1 get to_univNum , put
     ] pop
     popVariables
   } def
   
   
   
 %<  %<
 % Usages: cone getNextFacet i  % Usages: cone getNextFacet i
 % flipped $B$N(B mark $B$N$J$$(B facet $B$N(B index facet_i $B$rLa$9(B.  % flipped $B$N(B mark $B$N$J$$(B facet $B$N(B index facet_i $B$rLa$9(B.
Line 1914  def   
Line 1955  def   
 %>  %>
 /markBorder {  /markBorder {
   /arg1 set    /arg1 set
   [/cone /facets_t /flipped_t /kk] pushVariables    [/cone /facets_t /flipped_t /kk /nextcid_t /nextfid_t] pushVariables
   [    [
     /cone arg1 def      /cone arg1 def
     cone (facets) getNode 2 get /facets_t set      cone (facets) getNode 2 get /facets_t set
     cone (flipped) getNode 2 get /flipped_t set      cone (flipped) getNode 2 get /flipped_t set
       cone (nextcid) getNode 2 get /nextcid_t set
       cone (nextfid) getNode 2 get /nextfid_t set
     0 1 flipped_t length 1 sub {      0 1 flipped_t length 1 sub {
       /kk set        /kk set
       flipped_t kk get (0).. eq {        flipped_t kk get (0).. eq {
          cone kk isOnWeightBorder {           cone kk isOnWeightBorder {
 % Border $B$N>e$K$"$k$N$G(B flip $B:Q$N%^!<%/$r$D$1$k(B.  % Border $B$N>e$K$"$k$N$G(B flip $B:Q$N%^!<%/$r$D$1$k(B.
            flipped_t kk (2).. put             flipped_t kk (2).. put
   % $B$H$J$j$N(B cone $B$N(B id (nextcid, nextfid) $B$O(B -2 $B$H$9$k(B.
              nextcid_t kk (-2).. put
              nextfid_t kk (-2).. put
          } {  } ifelse           } {  } ifelse
       } {  } ifelse        } {  } ifelse
     } for      } for
Line 1981  def   
Line 2027  def   
          ncone ii markFlipped           ncone ii markFlipped
          cone.fan kk get /tcone set           cone.fan kk get /tcone set
          tcone jj markFlipped           tcone jj markFlipped
   % nextcid, nextfid $B$r@_Dj$9$k(B.
            ncone ii [kk jj] markNext
            tcone jj [cone.fan.n ii] markNext
       } {  } ifelse        } {  } ifelse
     } for      } for
 % 3. ncone $B$r2C$($k(B.  % 3. ncone $B$r2C$($k(B.
Line 2323  def   
Line 2372  def   
       (cone.incidence)        (cone.incidence)
   
     ] { inputForm.value  nl } map /rr set      ] { inputForm.value  nl } map /rr set
     rr cat /arg1 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    ] pop
   popVariables    popVariables
   arg1    arg1
Line 2412  def   
Line 2464  def   
   popVariables    popVariables
   arg1    arg1
 } def  } 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
   % It computes gb.
   %>
   /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.0  [bool, ...]
   % $B%F%9%HJ}K!(B.  (data/test8.sm1) run  (data/test8-data.sm1) run 0 1 isSameCone_h.0
   % gb $B$r:FEY7W;;$9$k(B stand alone $BHG(B.  gr(Local ring) $B$GHf3S(B.
   %>
   /isSameCone_h.0 {
     /arg2 set /arg1 set
     [/i /j /ans /ii /iiw /jj /jjw] pushVariables
     [
       /i arg1 def /j arg2 def
       i to_int32 /i set , j to_int32 /j set
       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
   
   %<
   % Usages: [ii vv i_vw_vector] getGbInGrRing_h [ii_gr  i_gr]
   % Get Grobner Basis of ii in the graded ring.
   % The graded ring is obtained automatically from vv and i_vw_vector.
   % ii_gr is the Grobner basis. i_gr is the output of getGrRing.
   % cf. isSameInGrRing_h,   ecart.isSameIdeal_h with [(noRecomputation) 1]
   %>
   /getGbInGrRing_h {
     /arg1 set
     [/ii /i_vw_vector /vlist  /rng /vv /vvGlobal /wv /iigg
      /i_gr  /rrule /ans] pushVariables
     [
       /ii arg1 0 get def
       /vlist arg1 1 get def
       /i_vw_vector arg1 2 get def
       [vlist i_vw_vector] getGrRing /i_gr set
   
   % 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
       /vvGlobal i_gr 1 get def
       /vv i_gr 0 get def
   
       ii { toString . rrule replace toString } map /ii set
   
       [vv vvGlobal] ecart.stdBlockOrder /wv set
         vvGlobal length 0 eq {
         /rng [vv wv ] def
       }{
         /rng [vv wv [(partialEcartGlobalVarX) vvGlobal]] def
       } ifelse
       /save-cone.autoHomogenize ecart.autoHomogenize def
       /ecart.autoHomogenize 0 def
       [ii] rng join  ecartd.gb  /iigg set
       save-cone.autoHomogenize /ecart.autoHomogenize set
       /ans [iigg 0 get i_gr] def
       /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   
   /test1.getGbInGrRing_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
     [ii cone.vv iiw] getGbInGrRing_h /ff1 set
   
     cone.gblist 1 get (initial) getNode 2 get /jj set
     cone.gblist 1 get (weight) getNode [2 0 2] get    /jjw set
     [jj cone.vv jjw] getGbInGrRing_h /ff2 set
   
     (ff1 and ff2) message
   
   } def
   
   
   %<
   % setGrGblist
   %  cone.grGblist $B$r@_Dj$9$k(B.
   %>
   /setGrGblist {
     [/ii /ww /gg] pushVariables
     [
       cone.gblist {
         /gg set
         gg (initial) getNode 2 get /ii set
         gg (weight) getNode [2 0 2] get /ww set
         [ii cone.vv ww] getGbInGrRing_h
       } map /cone.grGblist set
     ] pop
     popVariables
   } def
   
   %<
   % Usages: i j isSameCone_h.2  [bool, ...]
   % gb $B$r:FEY7W;;$7$J$$(B.
   %>
   /isSameCone_h.2 {
     /arg2 set /arg1 set
     [/i /j /ans /ii /iiw /jj /jjw] pushVariables
     [
       /i arg1 def /j arg2 def
        i to_int32 /i set , j to_int32 /j set
       (cone.grGblist) boundp { } { setGrGblist } ifelse
       cone.debug { (Comparing ) messagen [i j]  message } { } ifelse
   
       cone.grGblist i get /ii set
       cone.grGblist j get /jj set
   
       ii 1 get ,  jj 1 get isSameGrRing {  }
       { /ans [0 [ii 1 get jj 1 get]] def exit} ifelse
   
       [ii 0 get , jj 0 get cone.vv [[(noRecomputation) 1]] ]
       ecartd.isSameIdeal_h /ans set
       [ans [ii 1 get] ii 1 get , ecartd.isSameIdeal_h.failed]  /ans set
   
       ans /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   %<
   %  test1.isSameCone_h.2 $B$O(B cone.grGblist $B$K(B initial $B$N(B gb $B$r(B graded ring
   %  $B$G$^$:7W;;$7(B, $B$=$l$+$i(B ideal $B$NHf3S$r$*$3$J$&(B. isSameCone_h.1 $B$KHf$Y$F(B
   %  gb $B$N:FEY$N7W;;$,$J$$$N$G7P:QE*(B.
   %>
   /test1.isSameCone_h.2 {
     /cone.loaded boundp { }
     {
       [(parse) (cohom.sm1) pushfile] extension
       [(parse) (dhecart.sm1) pushfile] extension
       /cone.loaded 1 def
     } ifelse
     %[(parse) (cone.sm1) pushfile] extension
     [(parse) (data/test8-data.sm1) pushfile] extension
     setGrGblist
     (cone.grGblist is set.) message
     0 1 isSameCone_h.2 pmat
   } def
   
   %<
   % dhcone $B$O(B  DeHomogenized Cone $B$NN,(B.  H->1 $B$H$7$F(B cone $B$r(B merge $B$7$F$$$/4X?t(B
   % $B$dBg0hJQ?t$K;H$&(B.
   % cone.gblist, cone.fan $B$,@5$7$/@_Dj$5$l$F$$$k$3$H(B.
   % (setGrGblist $B$r<B9T:Q$G$"$k$3$H(B. $B<+F0<B9T$5$l$k$,(B... )
   %
   %>
   
   /isSameCone_h {  isSameCone_h.2 } def
   
   %<
   % Usages: genDhcone.init
   %   dhcone.checked (dehomogenized $B:Q$N(B cone$BHV9f(B),  dhcone.unchecked $B$N=i4|2=(B.
   %>
   /genDhcone.init {
     /dhcone.checked [ ] def
     /dhcone.unchecked [
        0 1 cone.fan length 1 sub {
           to_univNum
        } for
     ] def
   } def
   
   %<
   % Usages: k genDhcone dhcone
   % cone.fan[k] $B$r=PH/E@$H$7$F(B cone $B$r(B dehomogenize $B$9$k(B (merge $B$9$k(B).
   %
   % $B%F%9%H(B1.  (data/test14.sm1) run (data/test14-data.sm1) run
   %          genDhcone.init
   %          0 genDhcone /ff set
   %>
   
   /genDhcone {
     /arg1 set
     [/k /facets /merged /nextcid /nextfid /coneid
         /newfacets /newmerged /newnextcid /newnextfid /newconeid /vv
      /i /j /p /q /rr /cones /differentC
     ] pushVariables
     [
       /k arg1 def
       /facets [ ] def /merged [ ] def /nextcid [ ] def
       /nextfid [ ] def /coneid [ ] def
       /cones [ ] def
       /differentC [ ] def
   
       k to_univNum /k set
   
       {
   % Step1. cone.fan[k] $B$r(B $B2C$($k(B.  new... $B$X=i4|%G!<%?$r=q$-9~$`(B.
        cone.debug {(Step 1. Adding ) messagen k messagen (-th cone.) message} { } ifelse
         cones [k to_univNum] join /cones set
         cone.fan k get , (facets) getNode 2 get /vv set
         /newfacets [ ] vv join def
   
         cone.fan k get , (nextcid) getNode 2 get /vv set
         /newnextcid [ ] vv join def
   
         cone.fan k get , (nextfid) getNode 2 get /vv set
         /newnextfid [ ] vv join def
   
   % newmerged $B$O$^$:(B 0 $B$G$&$a$k(B.  0 : $B$^$@D4$Y$F$J$$(B.
   % 1 : merged $B$G>C$($?(B. 2 : boundary. 3 : $B$H$J$j$O0[$J$k(B.
   % [ ] join $B$r$d$C$F(B $B%Y%/%H%k$N(B clone $B$r:n$k(B.
         cone.fan k get , (flipped) getNode 2 get /vv set
         /newmerged [ ] vv join def
         0 1 , newmerged length 1 sub {
            /i set
            newmerged i get , (2).. eq { }
            { newmerged i (0).. put } ifelse
         } for
   % newconeid $B$O(B k $B$G$&$a$k(B.
         /newconeid newfacets length newVector { pop k to_univNum } map def
   
   % merged $B$H(B newmerged $B$r(B cone $B$NNY@\4X78$N$_$G99?7$9$k(B.
   % $BF1$8(B init $B$r;}$D$3$H$O$o$+$C$F$$$k$N$G(B  facet vector $B$N$_$N(B check $B$G==J,(B.
   % merged $B$N(B i $BHVL\(B $B$H(B newmerged $B$N(B j $BHVL\$GHf3S(B.
         0 1 , merged length 1 sub {
           /i set
           0 1 , newmerged length 1 sub {
             /j set
             merged i get , (0).. eq ,
             newmerged j get , (0).. eq , and
             nextcid i get , k to_univNum eq , and
             {
                facets i get , newfacets j get , add isZero {
   % merged[i], newmerged[j] $B$K(B 1 $B$rF~$l$F>C$9(B.
   % $B>e$NH=Dj$O(B nextfid, newnextfid $B$rMQ$$$F$b$h$$$N$G$O(B?
                  merged i (1).. put
                  newmerged j (1).. put
                } {  } ifelse
             } { } ifelse
           } for
         } for
   
   % Step2. $B7k9g$7$F$+$i(B, $B$^$@D4$Y$F$J$$(B facet $B$rC5$9(B.
         cone.debug { (Step 2. Joining *** and new***) message } { } ifelse
         /facets facets newfacets join def
         /merged merged newmerged join def
         /nextcid nextcid newnextcid join def
         /nextfid nextfid newnextfid join
         /coneid  coneid newconeid join def
   
         cone.debug{ (   Checking facets.) message } { } ifelse
         /k null def
         0 1 , merged length 1 sub {
           /i set
           % i message
           merged i get (0).. eq {
   % i $BHVL\$r$^$@D4$Y$F$$$J$$(B.
             coneid i get ,  /p set
             nextcid i get , /q set
             cone.debug { [p q] message } {  } ifelse
             q (0).. ge {
   % cone.fan [p] $B$H(B cone.fan [q] $B$N(B initial $B$rHf3S$9$k(B.
   % $BF1$8$J$i(B k $B$r@_Dj(B. exit for. $B0c$($P(B merged[i] = 3 ($B0c$&(B) $B$rBeF~(B.
   % differentC $B$O$9$G$K(B $B8=:_$N(B dhcone $B$H0c$&$H(B check $B$5$l$?(B cone $BHV9f(B.
   % dhcone.checked $B$O(B dhcone $B$,$9$G$K@8@.$5$l$F$$$k(B cone $BHV9f$N%j%9%H(B.
   % $B$3$l$K$O$$$C$F$$$F$b0c$&(B.
               q differentC memberQ , q dhcone.checked memberQ , or
               { /rr [0 ] def }
               { p q isSameCone_h /rr set } ifelse
   
               rr 0 get 1 eq {
                 cone.debug { (Found next cone. ) message } { } ifelse
                 /k q to_univNum def exit
               } {
                 cone.debug { ( It is a different cone. ) message } { } ifelse
                 differentC [ q ]  join /differentC set
                 merged i (3).. put
               } ifelse
             } {  } ifelse
           } {  } ifelse
         } for
   
         k tag 0 eq { exit } {  } ifelse
      } loop
   
      [(-1)..] cones join shell rest /cones set
   %     dhcone.checked, dhcone.unchecked $B$r99?7(B.
      dhcone.checked cones join /dhcone.checked set
      dhcone.unchecked cones setMinus /dhcone.unchecked set
   
      [(dhcone) [ ]
        [
          [(cones) [ ] cones] arrayToTree
          [(facets) [ ] facets] arrayToTree
          [(merged) [ ] merged] arrayToTree
          [(nextcid) [ ] merged] arrayToTree
          [(nextfid) [ ] merged] arrayToTree
          [(coneid) [ ] merged] arrayToTree
        ]
      ] arrayToTree /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   
   %<
   % Usages: dhCones_h
   % cone.fan $B$O(B doubly homogenized (local) $B$G@8@.$5$l$?(B Grobner fan.
   % cone.fan $B$r(B dehomogenize (H->1) $B$7$F(B init $B$rHf$Y$F(B dhcone.fan $B$r@8@.$9$k(B.
   %
   % $B%F%9%H(B1.  (data/test14.sm1) run (data/test14-data.sm1) run
   %          dhCones_h
   %          test22
   %>
   /dhCones_h {
     (cone.grGblist) boundp { } {setGrGblist} ifelse
     genDhcone.init
     /dhcone.fan [ ] def
     {
        (-----------------------------------------) message
        (#dhcone.unchecked = ) messagen dhcone.unchecked length message
        dhcone.unchecked length 0 eq { exit } { } ifelse
        dhcone.fan
        [ dhcone.unchecked 0 get , genDhcone ] join /dhcone.fan set
        (#dhcone.fan = ) messagen dhcone.fan length message
     } loop
     dhcone.fan
   } def
   
   % Todo: print, save functions.  Representative of weight & init.
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.4
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>