2
$\begingroup$

I wanted to visualize the cumulative powerset construction process and came up with two functions:

PowerGraph[l_] := Module[
   {count = 1, treelist, vmaplist, t, label, ncolor},
   treelist =
    Reap[
     Fold[#1~Join~(#1 /. (x_ \[DirectedEdge] y_) :> (y \[DirectedEdge] (Sow[{count, #2}]; count++))) &,
     {0 \[DirectedEdge] {}},
     l
   ] // Rest
 ];
 vmaplist = treelist[[2, 1]];
 t = TreeGraph[treelist[[1]], VertexLabels -> "Name"];
 Fold[SetProperty[{#1, #2[[1]]},
  {
   label = #2[[2]];
   ncolor = Position[l, label][[1, 1]]/Length[l];
   VertexStyle -> Hue[ncolor],
   VertexLabels -> Placed[
     {
      Style[label, Hue[ncolor, 1, 0.6]],          
      Rest@FindShortestPath[t, {}, #2[[1]]] /. x_ :> vmaplist[[x, 2]]}, {Below, Tooltip}]
     }
  ] &, t, vmaplist]  
]; 

TreeAnimate[g_Graph] := Module[{
  tempg = SetProperty[g,
  {
    VertexShape -> Graphics[Circle[{0, 0}, 0]],
    EdgeStyle -> Opacity[0],
    VertexLabels ->Table[VertexList[g][[i]] -> "", {i,Length[VertexList[g]]}],
   ImageSize -> Large
  }],
len = Length[VertexList[g]],
el, vl
},
ListAnimate[
  FoldList[
   SetProperty[#1,
   {
    el = EdgeList[g];
    vl = VertexList[g];
    If[#2 > 1, EdgeStyle -> (el[[#2 - 1]] -> {Opacity[1], PropertyValue[{g, el[[#2 - 1]]}, EdgeStyle]}), ## &[]],
      VertexShape -> (vl[[#2]] -> (PropertyValue[{g, vl[[#2]]},   VertexShape] /. $Failed -> Automatic)),
  pv = PropertyValue[{g, vl[[#2]]}, VertexLabels] /. $Failed -> "";
      VertexLabels -> (vl[[#2]] -> pv)
    }
   ] &, tempg, Range[len]], AnimationRepetitions -> 1, SaveDefinitions -> True]
];

TreeAnimate[PowerGraph[{a,b,c,d,e}]]

PowerSet

Maybe someone has use for it, the animation follows declaration order and should work for arbitrary graphs. The individual sets are shown as Tooltips. The remaining gripe is the layout ungainly 'dithering' as the only way I found to hide vertices was declaring them as zero-sized circles. Anyone got a better idea?

$\endgroup$
2
$\begingroup$

You can try HighlightGraph with "DehighlightHide" highlight style. One thing I modify in PowerGraph is changing vertex {} to string vertex "{}".

PowerGraph[l_] := Module[
   {count = 1, treelist, vmaplist, t, label, ncolor},
   treelist =
    Reap[
     Fold[#1~Join~(#1 /. (x_ \[DirectedEdge] y_) :> (y \[DirectedEdge] (Sow[{count, #2}]; count++))) &,
     {0 \[DirectedEdge] "{}"},
     l
   ] // Rest
 ];
 vmaplist = treelist[[2, 1]];
 t = TreeGraph[treelist[[1]], VertexLabels -> "Name"];
 Fold[SetProperty[{#1, #2[[1]]},
  {
   label = #2[[2]];
   ncolor = Position[l, label][[1, 1]]/Length[l];
   VertexStyle -> Hue[ncolor],
   VertexLabels -> Placed[
     {
      Style[label, Hue[ncolor, 1, 0.6]],          
      Rest@FindShortestPath[t, "{}", #2[[1]]] /. x_ :> vmaplist[[x, 2]]}, {Below, Tooltip}]
     }
  ] &, t, vmaplist]  
]; 

g = PowerGraph[{a,b,c,d,e}];
vlist = VertexList[g]; elist = EdgeList[g]; Animate[
 HighlightGraph[g, Join[vlist[[;; i]], elist[[;; i - 1]]], 
  GraphHighlightStyle -> "DehighlightHide"], {i, 1, 
  Length[VertexList[g]], 1}, AnimationRepetitions -> 1, 
 SaveDefinitions -> True]
$\endgroup$
  • $\begingroup$ Much simpler and cleaner. The shaking seems to be a Mathematica issue. $\endgroup$ – LogicBreaker Jun 7 '15 at 15:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.