Detour Matrix

Author

Eric W. Weisstein
April 2, 2016

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

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

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

Checks

?DetourMatrix

FindLongestPaths

Monitor[DeleteCases[{g=#,Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindLongestPaths"]}}&/@GraphData[;;7],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{g=#,Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindLongestPaths"]}}&/@GraphData[;;8],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{g=#,Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindLongestPaths"]}}&/@GraphData[;;9],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{g=#,Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindLongestPaths"]}}&/@GraphData["Connected",;;9],{_,{x_,x_}}],g]//Timing

FindPaths

Monitor[DeleteCases[{#,Flatten/@Normal/@{GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPaths"]}}&/@GraphData[;;6],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{#,Flatten/@Normal/@{GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPaths","FindPathsMethod"->"EdgeJoin"]}}&/@GraphData[;;7],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{#,Flatten/@Normal/@{GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPaths"]}}&/@GraphData["Connected",;;7],{_,{x_,x_}}],g]//Timing

Monitor[DeleteCases[{#,Flatten/@Normal/@{GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPaths"]}}&/@GraphData["Connected",;;8],{_,{x_,x_}}],g]//Timing

FindPathDecremental

DeleteCases[Monitor[{g=#,Normal@GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPathDecremental","Preprocess"->True]}&/@GraphData["Connected",;;10],g],{_,x_,x_}]//Timing

DeleteCases[Monitor[{g=#,Normal@GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPathDecremental","Preprocess"->False]}&/@GraphData["Connected",;;10],g],{_,x_,x_}]//Timing

FindLongestPathLength[GraphData@{"Cone",{10,10}},1,2,Debug->True,Method->"Decremental","Preprocess"->False]

FindLongestPathLength[GraphData@{"Cone",{10,10}},1,2,Debug->True,Method->"Decremental"]

"FindHamiltonianPathMethod"->MyFindHamiltonianPath

MatrixForm[m1=DetourMatrix[GraphData["Q4"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->MyFindHamiltonianPath]]//AbsoluteTiming

(m1=DetourMatrix[GraphData["Q5"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->MyFindHamiltonianPath])//AbsoluteTiming

"FindHamiltonianPathMethod"->FindHamiltonianPath

MatrixForm[m2=DetourMatrix[GraphData["Q4"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->FindHamiltonianPath]]//AbsoluteTiming

(m2=DetourMatrix[GraphData["Q5"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->FindHamiltonianPath])//AbsoluteTiming

"FindHamiltonianPathMethod"->FindPath

MatrixForm[m3=DetourMatrix[GraphData["Q4"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->FindPath]]//AbsoluteTiming

(m3=DetourMatrix[GraphData["Q5"],Method->"FindPathDecremental","FindHamiltonianPathMethod"->FindPath])//AbsoluteTiming

FindPath

Works only on connected for now

GraphData[{4,2},"LabeledImage"]

GraphData[{4,2},"DetourMatrix"]//TraditionalForm

DetourMatrix[GraphData[{4,2}],Method->"FindPath",Debug->True]

DeleteCases[{#,Flatten/@Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPath"]}}&/@GraphData["Connected",;;6],{_,{x_,x_}}]//Timing

DeleteCases[{#,Flatten/@Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPath"]}}&/@GraphData["Connected",;;8],{_,{x_,x_}}]//Timing

DeleteCases[{#,Flatten/@Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"FindPath"]}}&/@GraphData["Connected",;;9],{_,{x_,x_}}]//Timing

SpanningTrees

Monitor[DeleteCases[
{
g=#,
Flatten/@Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"SpanningTrees"]}
}&/@GraphData[;;6],
{_,{x_,x_}}
],g]//Timing

Monitor[DeleteCases[
{
g=#,
Flatten/@Normal/@{GraphData[#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"SpanningTrees"]}
}&/@GraphData[;;7],
{_,{x_,x_}}
],g]//Timing

Examples

K4

CharacteristicPolynomial[DetourMatrix[Graph["K4"]],x]//TraditionalForm

Total[DetourMatrix[Graph["K4"]],2]/2

GraphData["K4","DetourPolynomial"][x]//Expand//TraditionalForm

GraphData["K4","DetourIndex"]

K5

DetourMatrix[Graph["K5"]]//TraditionalForm

GraphData["K5","DetourMatrix"]//TraditionalForm

GraphData["K5","DetourPolynomial"][x]//Expand//TraditionalForm

Square+pendant edge

ShowLabeledGraph[g=AddEdge[AddVertex[Cycle[4],{0,1.5}],{1,5}],ImageSize->200]

DetourMatrix[g]//TraditionalForm

RecognizeGraph[g]

i=FastIsomorphism[g,Graph["BannerGraph"]]

GraphData["BannerGraph","DetourMatrix"][[InversePermutation[i]]]//TraditionalForm

Joined Pentagons

v={0.8090169943749473`,0}+#&/@Vertices[Cycle[5]]//Chop

ShowLabeledGraph[g0=AddEdges[AddVertices[ChangeVertices[Cycle[5],v],{-1,1}#&/@Delete[v,{{2},{3}}]],Partition[{2,6,8,7,3},2,1]]]

RecognizeGraph[g0]

ShowLabeledGraph[g=Graph[List/@(Edges[g0]/.Thread[{8,6,2,1,5,4,3,7}->Range[8]]),List/@Vertices[g0][[{8,6,2,1,5,4,3,7}]]]]

DetourMatrix[g]//TraditionalForm

Total[DetourMatrix[g],2]/2

ToCommonEdges[g0,GetGraph[{8,3815}]]

GetGraphData[{8,3815},"DetourMatrix"]

{6, 107}

p. 289

ShowLabeledGraph[g=AddEdges[AddVertices[Graph["SquareGraph"],{{0,.2},{0,-.2}}],{{2,5},{5,4},{5,6},{6,3}}],ImageSize->200]

RecognizeGraph[g]

GraphData[{6,107},"DetourPolynomial"][x]

Expand[%]

Algorithm

AllPaths

DeleteCases[Monitor[{#,GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"AllPaths"]}&/@GraphData[;;7],g],{_,x_,x_}]//Timing

DeleteCases[Monitor[{#,GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"AllPaths"]}&/@GraphData[;;8],g],{_,x_,x_}]//Timing

Decremental

(with symmetry)

DeleteCases[Monitor[{#,GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"Decremental"]}&/@GraphData[;;7],g],{_,x_,x_}]//Timing

DeleteCases[Monitor[{#,GraphData[g=#,"DetourMatrix"],DetourMatrix[GraphData[#],Method->"Decremental","MaxLength"->GraphData[#,"LongestPathLength"]]}&/@GraphData[;;8],g],{_,x_,x_}]//Timing

Classes

Antiprism

Entity["Graph",{"Antiprism",n}]["DetourMatrix"]

MatrixForm/@Table[GraphData[{"Antiprism",n},"DetourMatrix"],{n,3,6}]

l=Table[{GraphData[{"Antiprism",n},"#"],{0,SparseArray[{i_,i_}->0,{n=GraphData[{"Antiprism",n},"V"],n},n-1]}},{n,3,20}]

Barbell

MatrixForm/@(l1=Table[GraphData[{"Barbell",n},"DetourMatrix"],{n,3,7}])

MatrixForm/@(l2=Table[DetourMatrix[{"Barbell",n}],{n,3,7}])

Equal@@@Table[{GraphData[{"Barbell",n},"DetourMatrix"],DetourMatrix[{"Barbell",n}]},{n,3,17}]

DetourMatrix[{"Barbell",n_}]:=Module[{a=ConstantArray[n-1,2n{1,1}],i,j},
Do[a[[i,i]]=0,{i,2n}];
Do[a[[i,2n]]++;a[[2n,i]]++,{i,n}];
Do[a[[n+i,n]]++;a[[n,n+i]]++,{i,n}];
a[[2n,n]]=a[[n,2n]]=1;
Do[a[[i,j]]=a[[j,i]]=2n-1,{i,n+1,2n-1},{j,n-1}];
a
]

Table[Flatten[DetourMatrix[{"Barbell",n}]-GraphData[{"Barbell",n},"DetourMatrix"]]//Union,{n,4,10}]

GraphData["Barbell"]

l=Table[{{"Barbell",n},{0,DetourMatrix[{"Barbell",n}]}},{n,11,20}]

Complete

TraditionalForm/@Table[GraphData[{"Complete",n},"DetourMatrix"],{n,5}]

TraditionalForm/@Normal/@Table[DetourMatrix[{"Complete",n}],{n,5}]

CompleteBipartite m×n

CompleteBipartite n×n

TraditionalForm/@Table[GraphData[{"CompleteBipartite",{n,n}},"DetourMatrix"],{n,3,7}]

DetourMatrix[{"CompleteBipartite",{n_,n_}}]:=Block[{m1=ConstantArray[2n-2,{n,n}],m2=ConstantArray[2n-1,{n,n}]},ArrayFlatten[{{m1,m2},{m2,m1}}]-(2n-2)IdentityMatrix[2n]]

TraditionalForm/@Normal/@Table[GraphData[{"CompleteBipartite",{n,n}},"DetourMatrix"],{n,8,9}]

TraditionalForm/@Normal/@Table[DetourMatrix[{"CompleteBipartite",{n,n}}],{n,8,9}]

Max/@Abs[Normal/@Table[DetourMatrix[{"CompleteBipartite",{n,n}}]-GraphData[{"CompleteBipartite",{n,n}},"DetourMatrix"],{n,8,9}]]

l=Table[{GraphData[{"CompleteBipartite",{n,n}},"#"],{0,DetourMatrix[{"CompleteBipartite",{n,n}}]}},{n,10,20}]

Table[GraphData[{"CompleteBipartite",{n,n}},"DetourIndex"],{n,2,9}]

Factor[FindSequenceFunction[%,n-1]]

Table[n (2-5 n+4 (n^2)),{n,2,9}]

l=Table[{Total[DetourMatrix[{"CompleteBipartite",{n,n}}],2]/2,n (2-5 n+4 (n^2))},{n,10,20}]

l=Table[{Total[DetourMatrix[{"CompleteBipartite",{n,n}}],2]/2},{n,10,20}]

Crown

MatrixForm/@Table[GraphData[{"Crown",n},"DetourMatrix"],{n,5,7}]

DetourMatrix[{"Crown",n_}]:=Module[{a=ConstantArray[2n-1,2n{1,1}],i,j},
Do[a[[i,j]]=a[[n+i,n+j]]=2n-2,{i,n},{j,n}];
Do[a[[i,i]]=0,{i,2n}];
a
]

MatrixForm@DetourMatrix[{"Crown",6}]

MatrixForm@DetourMatrix[{"Crown",6}]

Table[Flatten[DetourMatrix[{"Crown",n}]-GraphData[{"Crown",n},"DetourMatrix"]]//Union,{n,5,9}]

GraphData["Crown"]

l=Table[{{"Crown",n},{0,DetourMatrix[{"Crown",n}]}},{n,10,20}];

Cycle

TraditionalForm/@(m1=Table[GraphData[{"Cycle",n},"DetourMatrix"],{n,3,8}])

TraditionalForm/@Normal/@Table[DetourMatrix[{"Cycle",n}],{n,3,8}]

DetourMatrix[{"Cycle",n_}]:=SparseArray[{{i_,i_}->0,{i_,j_}:>If[Abs[i-j]<n/2,n-Abs[i-j],Abs[i-j]]},n]

TraditionalForm/@(m2=Normal/@Table[DetourMatrix[{"Cycle",n}],{n,3,8}])

TraditionalForm/@(m1-m2)

Prism

DetourMatrix[{"Prism",n_/;Mod[n,2]==1}]:=SparseArray[{i_,i_}->0,2n,2n-1]

DetourMatrix[{"Prism",n_/;Mod[n,2]==0}]:=Module[{m1=SparseArray[{{i_,i_}->0,{i_,j_}/;Mod[i-j,2]==1->2n-1},{n,n},2n-2],m2=SparseArray[{{i_,j_}/;Mod[i-j,2]==0->2n-1},{n,n},2n-2]},
ArrayFlatten[{{m1,m2},{m2,m1}}]
]

DetourMatrix[{"Prism",6}]//MatrixForm

Equal@@@Table[{GraphData[{"Prism",n},"DetourMatrix"],DetourMatrix[{"Prism",n}]},{n,4,18}]

DetourMatrix[GraphData[{"Prism",6}]]//MatrixForm

DetourMatrix[GraphData[{"Prism",5}]]//MatrixForm

DetourMatrix[GraphData[{"Prism",6}]]//MatrixPlot

DetourMatrix[GraphData[{"Prism",6}]]//MatrixForm

DetourMatrix[{"Prism",6}]//MatrixForm

GraphData[{"Prism",6},"DetourMatrix"]//MatrixForm

Sun

ArrayPlot[#,ColorFunction->(Hue[#/1.2]&)]&/@Table[GraphData[{"Sun",n},"DetourMatrix"],{n,5,7}]

MatrixForm/@Table[GraphData[{"Sun",n},"DetourMatrix"],{n,5,6}]

DetourMatrix[{"Sun",n_}]:=Module[{m=SparseArray[{{1,n}->2n-1,{i_,j_}/;(0<=i-j<=1)->2n-1},{n,n},2(n-1)]},ArrayFlatten[{
{SparseArray[{{i_,i_}->0,{1,n}->2n-2,{n,1}->2n-2,{i_,j_}/;Abs[i-j]==1->2(n-1)},n,2n-3],m},
{Transpose[m],SparseArray[{{i_,i_}->0},n,2n-1]}
}]]

Equal@@{DetourMatrix[{"Sun",5}],GraphData[{"Sun",5},"DetourMatrix"]}

Table[Equal@@{DetourMatrix[{"Sun",n}],GraphData[{"Sun",n},"DetourMatrix"]},{n,5,15}]

DetourMatrix[{"Sun",n_}]:=Module[{a=ConstantArray[2(n-1),2n{1,1}],i,j},
Do[a[[i,j]]++,{i,n+1,2n},{j,n+1,2n}];
Do[a[[i,i]]=0,{i,2n}];
a[[2n,1]]++;a[[1,2n]]++;
Do[a[[i+n,i]]=a[[i+n,i+1]]=a[[i,i+n]]=a[[i+1,i+n]]=2n-1,{i,n}];
Do[a[[i,j]]--;a[[j,i]]--,{i,3,n},{j,Max[i-n+2,1],i-2}];
a
]

MatrixForm@DetourMatrix[{"Sun",5}]

ArrayPlot[DetourMatrix[{"Sun",5}],ColorFunction->(Hue[#/1.2]&),ImageSize->200]

MatrixForm@With[{n=5},DetourMatrix[{"Sun",n}]-GraphData[{"Sun",n},"DetourMatrix"]]

GraphData["Sun"]

Table[Flatten[DetourMatrix[{"Sun",n}]-GraphData[{"Sun",n},"DetourMatrix"]]//Union,{n,5,12}]

l=Table[{{"Sun",n},{0,DetourMatrix[{"Sun",n}]}},{n,13,20}];

Web

Odd

ArrayPlot[#,ColorFunction->(Hue[#/1.2]&)]&/@Table[GraphData[{"Web",n},"DetourMatrix"],{n,3,7,2}]

MatrixForm/@Table[GraphData[{"Web",n},"DetourMatrix"],{n,3,6,2}]

DetourMatrix[{"Web",n_}/;Mod[n,2]==1]:=Module[{
m1=SparseArray[{{i_,i_}->0},2n,2n-1],
m2=ArrayFlatten[{{SparseArray[{},{n,n},2n]},{SparseArray[{{i_,i_}->1},{n,n},2n]}}],
m3=SparseArray[{{i_,i_}->0},n,2n+1]
},
ArrayFlatten[{{m1,m2},{Transpose[m2],m3}}]
]

Equal@@@Table[{GraphData[{"Web",n},"DetourMatrix"],DetourMatrix[{"Web",n}]},{n,3,11,2}]

Even

ArrayPlot[#,ColorFunction->(Hue[#/1.2]&)]&/@Table[GraphData[{"Web",n},"DetourMatrix"],{n,4,7,2}]

MatrixForm/@Table[GraphData[{"Web",n},"DetourMatrix"],{n,4,6,2}]

DetourMatrix[{"Web",n_}/;Mod[n,2]==0]:=Module[{
m1=SparseArray[{{i_,i_}->0,{i_,j_}/;Mod[i+j,2]==1->2n-1},n,2n-2],
m2=SparseArray[{{i_,j_}/;Mod[i+j,2]==0->2n-1},{n,n},2n-2],
m3=SparseArray[{{i_,j_}/;Mod[i+j,2]==0->2n},{n,n},2n-1],
m4=SparseArray[{{i_,i_}->1,{i_,j_}/;Mod[i+j,2]==1->2n},{n,n},2n-1],
m5=SparseArray[{{i_,i_}->0,{i_,j_}/;Mod[i+j,2]==0->2n},{n,n},2n+1]
},
ArrayFlatten[{{m1,m2,m3},{m2,m1,m4},{m3,m4,m5}}]
]

DetourMatrix[{"Web",4}]//MatrixForm

Equal@@@Table[{GraphData[{"Web",n},"DetourMatrix"],DetourMatrix[{"Web",n}]},{n,4,13,2}]

DetourMatrix[{"Web",20}]//DetourIndex