Graph Excision

Author

Eric W. Weisstein
May 15, 2009

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/GraphExcision.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/GraphExcision.html.

©2009 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Excisable Levi graph embedded by
Ed Pegg, Jr.
May 25, 2006

Code

ExciseEdge[g_Graph,e_List]:=Module[{h=DeleteEdge[g,e],p},
p=Flatten[Position[Degrees[h],2]];
DeleteVertices[AddEdges[h,Flatten[Position[#,1]]&/@Normal[AdjacencyMatrix[h][[p]]]],p]
]/;CubicQ[g]

Graphs

l={#,RecognizeGraph[ExciseEdge[Graph[#],Edges[Graph[#]][[1]]]]}&/@GraphData[{"Cubic","Connected","Symmetric"}];

l2=SortBy[DeleteCases[l,{_,{}}],GraphData[#[[1]],
"V"]&]

l2={{"UtilityGraph","TetrahedralGraph"},{"CubicalGraph",{"Prism",3}},{"PetersenGraph",{"MoebiusLadder",4}},{"HeawoodGraph",{"Cubic",{12,84}}},{"MoebiusKantorGraph",{"Cubic",{14,503}}},{"DodecahedralGraph",{"CubicPolyhedral",34}}};

Grid[Map[GraphData[#,"Name"]&,l2,{2}],Alignment->Left,Dividers->All]//TraditionalForm

GraphicsGrid[Map[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->65,TextAlignment->Center],BaseStyle->{9,Italic}]&,Transpose[l2],{2}],ImageSize->400,Spacings->{-50,Automatic}]

Code

1 Edge

GraphData["CubicalGraph","LabeledImage"]

EdgeExcise[Graph["CubicalGraph"],{1,3}]//ShowLabeledGraph

EdgeExcise[Graph["CubicalGraph"],{2,6}]//ShowLabeledGraph

Edges

GraphData["CubicalGraph","LabeledImage"]

ShowLabeledGraph[g=DeleteEdges[Graph["CubicalGraph"],{{1,3},{1,5}}]]

Degrees[g]

Figure

ExcisableLeviGraph=Graph[{{{1,2}},{{1,8}},{{1,24}},{{2,3}},{{2,19}},{{3,4}},{{4,5}},{{4,11}},{{5,6}},{{5,22}},{{6,7}},{{7,8}},{{7,14}},{{8,9}},{{9,10}},{{10,11}},{{10,17}},{{11,12}},{{12,13}},{{13,14}},{{13,20}},{{14,15}},{{15,16}},{{16,17}},{{16,23}},{{17,18}},{{18,19}},{{19,20}},{{20,21}},{{21,22}},{{22,23}},{{23,24}},{{18,25}},{{6,25}},{{21,26}},{{9,26}},{{12,27}},{{24,27}},{{15,28}},{{3,28}},{{28,30}},{{25,29}},{{29,30}},{{27,29}},{{26,30}}},{{{0.9659258,0.25881904}},{{0.8660254,0.5}},{{0.70710677,0.70710677}},{{0.5,0.8660254}},{{0.25881904,0.9659258}},{{-0.0110497475,1.0217391}},{{-0.25881904,0.9659258}},{{-0.5,0.8660254}},{{-0.70710677,0.70710677}},{{-0.8660254,0.5}},{{-0.9659258,0.25881904}},{{-1.0,0.0}},{{-0.9659258,-0.25881904}},{{-0.8660254,-0.5}},{{-0.70710677,-0.70710677}},{{-0.5,-0.8660254}},{{-0.25881904,-0.9659258}},{{-0.0110497475,-0.98550725}},{{0.25881904,-0.9659258}},{{0.5,-0.8660254}},{{0.70710677,-0.70710677}},{{0.8660254,-0.5}},{{0.9659258,-0.25881904}},{{0.9944751,-0.0}},{{-0.0110497475,0.48550725}},{{-0.17127073,0.19565213}},{{-0.48618782,-0.0}},{{-0.3551402,-0.33506036}},{{-0.48618782,0.18840575}},{{-0.35911608,0.19565213}}}];

Show[GraphicsArray[Block[{$DisplayFunction=Identity},ShowGraph[#[[1]],PlotLabel->#[[2]],TextStyle->{FontFamily->"Times",FontSlant->"Italic"}]&/@{
{LeviGraph,"Levi graph"},
{ExcisableLeviGraph,"rearranged Levi graph"},
{McGeeGraph,"McGee graph"}
}],ImageSize->500]]

MyIsomorphicQ[ExcisableLeviGraph,LeviGraph]