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.