3
$\begingroup$

I'm trying to generate tree-level graphs (no cycles or loops) with 3-point vertices only starting from a single vertex graph. I'm defining

f[a_, b_, c_] := 
     {a -> Subscript[v, a], b -> Subscript[v, a], c <-> Subscript[v, a]}

then Graph[f[1, 2, 3], VertexLabels -> "Name"] generates

enter image description here

but when I try

Graph[Join @@ {f[1, 2, a], f[3, 4, a]}, VertexLabels -> "Name"]

I get

enter image description here

with the vertex a being what I call redundant, and similarly by joining more graphs. The Join part contains

a <-> Subscript[v, 1], a <-> Subscript[v, 3]

so I'd need to replace this with Subscript[v, 1] <-> Subscript[v, 3].

I want to know how to do this for any number of joined graphs, e.g.

Join @@ {f[1, 2, a], f[3, a, b], f[4, b, c], f[5, 6, c]}

and so on.

Update

As suggested in the comments, VertexContract[] is meant to do the job, but it does not work for me (Mathematica 10) when using subscripts; I'm using this notation because it promise to be helpful when trying to generalize. I found a workaround that also does the trick with SimpleGraph and VertexReplace, e.g. for the second case in my original question:

SimpleGraph[VertexReplace[Join @@ {f[1, 2, a], f[3, 4, a]}, 
 a -> Subscript[v, 1]], VertexLabels -> "Name"]

but then I'd need a way to go through the edges with redundant vertices to know what vertex replacements should be done!

$\endgroup$
  • $\begingroup$ Have you seen VertexContract[]? $\endgroup$ – J. M. is away Aug 3 '16 at 3:27
  • $\begingroup$ @J.M. Thanks, that does the trick, although it seems to be in conflict with the subscript notation for the vertices $\endgroup$ – Cal Gibson Aug 3 '16 at 9:30
  • $\begingroup$ @Kuba By tree-level I meant with no cycles or loops, I'll specify in the question. $\endgroup$ – Cal Gibson Aug 3 '16 at 9:31
  • $\begingroup$ @CalGibson Ah, sorry, missed that. $\endgroup$ – Kuba Aug 3 '16 at 9:31
2
$\begingroup$
f[a_, b_, c_] := {
  DirectedEdge[a, Subscript[v, a]],
  DirectedEdge[b, Subscript[v, a]],
  UndirectedEdge[c, Subscript[v, a]]}

edges = Join[f[1, 2, a], f[3, a, b], f[4, b, c], f[5, 6, c]];

graph = Graph[edges,
  VertexLabels -> "Name",
  ImageSize -> Medium]

Starting graph

Vertex pairs to connect (brute force):

connect = Cases[
  Subsets[VertexList[graph], {2}], {u_, v_} /;
   Module[{
     p = FindShortestPath[graph, u, v],
     r = FindShortestPath[graph, v, u]},
    Or[
     Length[p] == 3 && VertexDegree[graph, p[[2]]] == 2,
     Length[r] == 3 && VertexDegree[graph, r[[2]]] == 2]]];

(* {{Subscript[v, 1], Subscript[v, 3]}, 
    {Subscript[v, 3], Subscript[v, 4]},
    {Subscript[v, 4], Subscript[v, 5]}} *)

Vertices to remove:

remove = FindShortestPath[graph, ##][[2]] & @@@ connect;

(* {a, b, c} *)

EdgeAdd[graph, UndirectedEdge @@@ connect]~VertexDelete~remove

enter image description here

Update: speed-up

Finding connecting pairs doesn't scale well. Better check only particular pairs, those with graph distance two, instead of all. So you can replace that Subset expression with list.

dm = GraphDistanceMatrix[graph];

list = Map[
   VertexList[graph][[#]] &,
   Position[UpperTriangularize@dm, 2]];
$\endgroup$
  • $\begingroup$ I tried with f[1, 2, a], f[3, a, b], f[b, c, e], f[6, c, d], f[4, 5, d], f[7, e, g], f[8, 9, g] but it misses one vertex; the reason seems to be that it connects to the other two through both directed edges. $\endgroup$ – Cal Gibson Aug 4 '16 at 8:56
  • $\begingroup$ @CalGibson Why do you say the procedure misses it? It seems that c is not redundant here. $\endgroup$ – BoLe Aug 4 '16 at 11:28
  • $\begingroup$ The edges contain c -> Subscript[v, 6], c -> Subscript[v, b], so I'd need this to be replaced with Subscript[v, 6] <-> Subscript[v, b], which it does not seem to do (Directed or Undirected is ultimately irrelevant, I just need at least one internal edge -I think- to be Undirected so that the graph looks like a Feynman diagram) $\endgroup$ – Cal Gibson Aug 4 '16 at 11:41
  • $\begingroup$ @CalGibson Can edges produced by f be all of UndirectedEdge? This would of course help remove c. $\endgroup$ – BoLe Aug 4 '16 at 12:18
  • $\begingroup$ No, I need the vertices with numbers to be connected through directed edges $\endgroup$ – Cal Gibson Aug 4 '16 at 13:55

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.