How to visualize the structure of this dynamic programming code

Question

I am studying Mr. Wizard's answer to this question which tries to identify elementary circles in a graph. That answer uses dynamic programming technique to simplify the code. The underlying guideline in the code is that, in Mathematica, more specific rules are applied before more general rules. Thus, the three functions with the same name f:

(* case 1 *)
f[x_, b___, x_] := (
   (f[##] = {}) & @@@ NestList[RotateLeft, {x, b}, Length@{x, b} - 1];
   {{x, b}}
);

(* case 2 *)
f[circle__] /; Signature@{circle} === 0 = {};

(* case 3 *)
f[circle___, vertex_] := 
  Join @@ (f[circle, vertex, #] & /@ ReplaceList[vertex, edges]);

will always be checked and evaluated in the order case1 -> case2 -> case3. Where the circle___ is initially an nonexistent expression and I slightly modify the variable names to make the code easier to understand. For example, when we evaluate f[1], firstly the pattern of case1 doesn't apply, so we come to case2 which is also not applicable due to the fact thatSignature@{1} is not 0. Finally we check that case3 is applicable and duo to SetDelayed we need to temporarily leave the evaluation of f[1] and try to compute f[1,2] and f[1,4] instead, and so on. We can use Trace[f[1]] or Trace[f[1], f[__]] to get a sense of the evaluation progress. But the results are nested expressions and not easy to recognize.

It will be helpful for us to understand the code better if we can find a way to visualize the dynamic progress. A first try can be made like this

op = {{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 1}, {3, 6}, {4, 1}, {4, 
    6}, {5, 4}, {5, 2}, {6, 5}, {6, 3}};
vertices = Union @@ op;
edges = Rule @@@ op;

traceRes = Trace[f[1], f[__]];
traceResIndex = traceRes /. MapIndexed[#1 -> #2[[1]] &, 
    DeleteDuplicates@Flatten@traceRes];
pos = First@Position[traceResIndex, #] & /@ Flatten[traceResIndex];
pos = Sort[pos, Length[#1] <= Length[#2] &];
pos = Gather[pos, Length[#1] == Length[#2] &];

length = Length[pos];
i = 1;
linkedVretices = {};
With[{cmuopt = SystemOptions["CompileOptions"]},
  Internal`WithLocalSettings[
   SetSystemOptions[{
     "CompileOptions" -> "ListableFunctionCompileLength" -> Infinity,
     "CompileOptions" -> "MapCompileLength" -> Infinity
     }], (
    While[i + 1 <= length,
      linkedVretices = {
        linkedVretices,
        Map[
         Block[{subList, subLength, link, var},
           subList = pos[[i, #]];
           subLength = Length[subList];
           subList[[-1]] += 1;
           link = Select[pos[[i + 1]], #[[;; subLength]] == subList &];
           Thread[Rule[var, link]] /. var -> pos[[i, #]]
           ] &, Range@Length@pos[[i]]
         ]};
      i += 1;
      ];),
   SetSystemOptions[cmuopt]
   ]];
linkedVretices = Flatten[linkedVretices];
linkedVretices = Apply[traceRes[[##]] &, linkedVretices, {2}]

GraphPlot[linkedVretices, VertexLabeling -> True]

We can clearly understand the progress from the above graph. However, as the input data op gets a bit more complex, for example,

op = {{1, 2}, {1, 9}, {2, 3}, {2, 17}, {3, 4}, {3, 13}, {4, 1}, {4, 
    5}, {5, 4}, {5, 6}, {6, 16}, {6, 7}, {7, 8}, {7, 22}, {8, 5}, {8, 
    10}, {9, 1}, {9, 10}, {10, 8}, {10, 11}, {11, 12}, {11, 21}, {12, 
    9}, {12, 18}, {13, 14}, {13, 3}, {14, 15}, {14, 20}, {15, 
    16}, {15, 23}, {16, 13}, {16, 6}, {17, 2}, {17, 18}, {18, 
    19}, {18, 12}, {19, 24}, {19, 20}, {20, 17}, {20, 14}, {21, 
    11}, {21, 22}, {22, 7}, {22, 23}, {23, 15}, {23, 24}, {24, 
    19}, {24, 21}};

Then the result will be

GraphPlot[linkedVretices, VertexLabeling -> Tooltip]

or if we use CommunityGraphPlot

Now it is too complex for extracting useful information. I wonder if we can find a way to clearly visualize the progress, like only show some "local graph" in-progress? Such technique, although not very important for actually solving problems, can still be valuable for tracking.

Answer 1

You could reconstruct graph with some more information. Here, I add Tooltip wrapper to vertex to show NeighborhoodGraph of that vertex in distance 2:

g = Graph[linkedVretices];

Graph[
   Tooltip[#, 
   HighlightGraph[
   NeighborhoodGraph[g, #, 2, 
   VertexShapeFunction -> (Text[Pane[#2, 80], #1] &), 
   GraphLayout -> {"RadialEmbedding", "RootVertex" -> #}, 
   VertexStyle -> Black], #1]] & /@ VertexList[g], 
   EdgeList[g], 
   GraphStyle -> "LargeNetwork", GraphLayout -> {"RadialEmbedding"}]

Here, I add the rough version that select vertices by rectangle area and generate subgraph. I just create separate static window to show snapshot of selected subgraph, but you could easily make dynamic window that respect sub vertices.

First, some pre-computation:

g = Graph[linkedVretices, GraphLayout -> "RadialEmbedding"];
vcoord = GraphEmbedding[g];
{xrange, yrange} = {Min[#], Max[#]} & /@ Transpose[vcoord];
xwid = Abs[xrange[[2]] - xrange[[1]]];
ywid = Abs[yrange[[2]] - yrange[[1]]];
xrange = xrange + .1 xwid {-1, 1};
yrange = yrange + .1 ywid {-1, 1};
isize = {600, 600};
g = Graph[linkedVretices, VertexCoordinates -> vcoord, 
   PlotRange -> {xrange, yrange}, PerformanceGoal -> "Speed", 
   VertexShapeFunction -> "Point", ImageSize -> isize, 
   VertexStyle -> Black];
crule = Thread[vcoord -> VertexList[g]];

and generate Manipulate:

DynamicModule[{x, y, xmin, xmax, ymin, ymax, ptin, vin, subg},
 Manipulate[
  Overlay[{Dynamic[g], 
    Graphics[{{Opacity[.2], 
       Dynamic[Rectangle[pts[[1]], 
         pts[[2]]], {None, {x, y} = Transpose[pts];
         {xmin, xmax} = Through[{Min, Max}[x]];
         {ymin, ymax} = Through[{Min, Max}[y]];
         ptin = 
          Cases[vcoord, 
           x_ /; (xmin <= x[[1]] <= xmax && ymin <= x[[2]] <= ymax)];
         }]}, {Orange, Point[Dynamic@ptin]}}, 
     PlotRange -> {xrange, yrange}, ImageSize -> isize]}, All, 2],
  {{pts, {{xrange[[1]], yrange[[2]]}, {xrange[[1]] + xwid .2, 
      yrange[[2]] - ywid .2}}}, Locator},
  Button["Zoom", vin = ptin /. crule; 
   subg = Subgraph[g, vin, 
     VertexCoordinates -> vcoord[[VertexIndex[g, #] & /@ vin]], 
     VertexLabels -> Placed["Name", Tooltip]]; 
   CreateDialog[subg, WindowTitle -> "Zoom", 
     WindowFrameElements -> {"CloseBox", "ResizeArea"}, 
     WindowFloating -> True], 
   Method -> "Queued"]]
 ]

you could wrap this as one function.