Defn Let $\mathcal{G}=(\mathcal{V},\mathcal{E})$ and $\mathcal{G}' = (\mathcal{V}', \mathcal{E}')$ be two labeled graphs with alphabet $\mathcal{A}$. The labeled graph product $\mathcal{G} * \mathcal{G}'$ is defined as follows:
- The vertex set of $\mathcal{G} * \mathcal{G}'$ is the Cartesian product $\mathcal{V} \times \mathcal{V}'$.
- Given $(g, g')$ and $(h, h') \in \mathcal{V} \times \mathcal{V}'$ and $a \in \mathcal{A}$, there is a labeled edge $(g,g') \overset{a}{\longrightarrow} (h,h')$ if and only if there is an edge $g \overset{a}{\longrightarrow} h$ in $\mathcal{G}$ and an edge $g' \overset{a}{\longrightarrow} h'$ in $\mathcal{G}'$.
Given a labeled graph $\mathcal{G}$, I am trying to efficiently implement the labeled graph product $\mathcal{G}*\mathcal{G}$. If it helps, the graphs I'm concerned with will always have the following properties:
- $\mathcal{G}$ will be right-resolving (aka a Shannon graph), that is, all edges leaving a given vertex bear distinct labels.
- For each label $a \in \mathcal{A}$ and each vertex $v \in \mathcal{V}$, there is an edge leaving $v$ with label $a$, i.e., $v \overset{a}{\longrightarrow} \dots$.
For example, consider the graph
graph= {{1 -> 3, "a"}, {1 -> 5, "b"}, {2 -> 1, "a"}, {3 -> 2, "a"}, {3 -> 4, "b"}, {4 -> 1, "a"}, {5 -> 6, "a"}, {5 -> 4, "b"}, {6 -> 1,"a"}, {0 -> 0, "a"}, {0 -> 0, "b"}, {2 -> 0, "b"}, {4 -> 0, "b"}, {6 -> 0, "b"}}
I have approached this problem by first defining a function that, given a vertex and a label, returns the target of the corresponding edge:
leavingEdgeTarget[vertex_, edgeLabel_, graph_] := Select[Select[graph, #[[1, 1]] == vertex &], #[[2]] == edgeLabel &][[ 1, 1, 2]]
and then using the following function:
labelProduct[graph_] := With[
{vertexList = VertexList@Graph@graph[[All, 1]],
alphabet = Union@graph[[All, 2]]},
Flatten[#, 2] &@
ParallelTable[{{v1,v2} ->
{leavingEdgeTarget[v1, label,graph],
leavingEdgeTarget[v2, label, graph]},
label},
{v1, vertexList},
{v2, vertexList},
{label, alphabet}
]
]
So for example, labelProduct[graph] returns the following graph with 49 vertices and 98 edges:
{{{1,1}->{3,3},"a"}, {{1,1}->{5,5}, "b"}, {{1,3}->{3,2},"a"},...,{{0,0}->{0,0},"b"}}
Q: How can I speed this up?
For small graphs, this runs reasonably fast (and seems to get a very nice speedup from the use of ParallelTable). However, it starts to take quite a while for larger graphs (100+ vertices). Consider the graph
SeedRandom[0];
n = 100;
randomGraph =
Flatten[#, 1]&@
Table[{i -> RandomInteger[{1, n}], label},
{i, 1, n},
{label, Range[3]}
];
On my machine (32GB memory, 8 logical cores @3.7GHz) I get the following values for labelProduct[randomGraph];//AbsoluteTiming different values of n:
n AbsoluteTiming
10 0.022
20 0.072
50 0.600
100 4.418
150 14.524
200 34.193
250 66.879
500 529.8=8m49.8s
I can achieve a small timing benefit by only generating the edges $(i,j)\overset{a}{\longrightarrow}(i', j')$ with $i \leq j$ and then find the remaining edges in the label product by noting that there is also an edge $(j,i)\overset{a}{\longrightarrow}(j',i')$, but this only has a speedup by a factor of roughly $1/2$.
