5 added 52 characters in body
source | link

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yieldUpdate As kindly suggested by halmir below, the nice pictureresulting graph can be displayed just as in your example. It is therefore hard to verify if using the answer is correct by looking at it. Some vertices seem to have more then 3 edges (for instance 1). You can check however withoption VertexDegreeGraphLayout -> "TutteEmbedding" that all vertices have indeed 3 edges.

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 2 <-> 3, 2 <-> 4, 3 <-> 4}, 
   VertexLabels -> "Name", GraphLayout -> "TutteEmbedding"];
replaceTripods[g]

enter image description hereenter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yield the nice picture as in your example. It is therefore hard to verify if the answer is correct by looking at it. Some vertices seem to have more then 3 edges (for instance 1). You can check however with VertexDegree that all vertices have indeed 3 edges.

enter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

Update As kindly suggested by halmir below, the resulting graph can be displayed just as in your example using the option GraphLayout -> "TutteEmbedding".

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 2 <-> 3, 2 <-> 4, 3 <-> 4}, 
   VertexLabels -> "Name", GraphLayout -> "TutteEmbedding"];
replaceTripods[g]

enter image description here

4 deleted 5 characters in body
source | link

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yield the nice picture as in your example. It is therefore hard to verify if the answer is correct by looking at it. Some vertices seem to have more then 3 edges (for instance 1). You can check however with VertexDegree that all vertices have indeed 3 edges.

enter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yield the nice picture as in your example. It is therefore hard to verify if the answer is correct by looking at it.

enter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yield the nice picture as in your example. It is therefore hard to verify if the answer is correct by looking at it. Some vertices seem to have more then 3 edges (for instance 1). You can check however with VertexDegree that all vertices have indeed 3 edges.

enter image description here

3 deleted 5 characters in body
source | link

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This yields adoes not soyield the nice a picture as in your example. It is therefore hard to verify if the answer is correct by looking at it.

enter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This yields a not so nice a picture as in your example. It is hard to verify if the answer is correct.

enter image description here

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

This does not yield the nice picture as in your example. It is therefore hard to verify if the answer is correct by looking at it.

enter image description here

2 added 194 characters in body
source | link
1
source | link