Orthogonality
Orthogonality
Code
Code
In[]:=
AllGeodesics[g_]:=Module[{m=GraphDistanceMatrix[g],v=VertexList[g]},Map[v[[#]]&,Position[m,Max[m]],{2}]]
In[]:=
GraphLineDistance[g_,start_,line_]:=Min[GraphDistance[g,start,#]&/@line]
In[]:=
FindShortestPathThoughVertex[graph_,v1_,c_,v2_]:=With[{paths=FindShortestPath[graph,##]&@@@{{v1,c},{c,v2},{v1,v2}}},If[Length[paths〚1〛]+Length[paths〚2〛]-1Length[paths〚3〛],Join[paths〚1〛,Rest[paths〚2〛]],Missing["Nonexistent"]]]
In[]:=
GeodesicDistance[g_,c_,pts1_,pts2_]:=With[{path1=FindShortestPathThoughVertex[g,pts1〚1〛,c,pts1〚2〛]},Total[GraphLineDistance[g,#,path1]&/@pts2]]
In[]:=
GeodesicDistanceMatrix[g_,c_,r_]:=With[{neighborhood=NeighborhoodGraph[g,c,r]},With[{geodesics=AllGeodesics[neighborhood]},With[{matrix=Outer[GeodesicDistance[neighborhood,c,##]&,geodesics,geodesics,1]},{geodesics,MapThread[Min,{matrix,Transpose[matrix]},2]}]]]
In[]:=
OrthogonalBases[g_,c_,r_,δ_:0]:=With[{distanceMatrix=GeodesicDistanceMatrix[g,c,r]},With[{geodesicsOrthogonalityGraph=Graph[UndirectedEdge@@@Position[distanceMatrix〚2〛,_Integer?(2r-#≤δ&)]]},If[EmptyGraphQ[geodesicsOrthogonalityGraph],List/@distanceMatrix〚1〛,With[{largestCliqueSize=Length[FindClique[geodesicsOrthogonalityGraph]〚1〛]},Union[Sort/@Map[Sort,Map[distanceMatrix〚1,#〛&,FindClique[geodesicsOrthogonalityGraph,{largestCliqueSize},All],{2}],{2}]]]]]]
In[]:=
LocalDimension[g_,c_,r_,δ_:0]:=With[{distanceMatrix=GeodesicDistanceMatrix[g,c,r]},With[{geodesicsOrthogonalityGraph=Graph[UndirectedEdge@@@Position[distanceMatrix〚2〛,_Integer?(2r-#≤δ&)]]},If[EmptyGraphQ[geodesicsOrthogonalityGraph],1,Length[FindClique[geodesicsOrthogonalityGraph]〚1〛]]]]
In[]:=
GeodesicPlot[g_,c_,pts_,opts:OptionsPattern[]]:=HighlightGraph[g,Style[PathGraph@FindShortestPathThoughVertex[g,#1,c,#2]&@@@pts,Directive[Red,Thick]],opts]
In[]:=
OrthogonalBasesPlot[g_,c_,r_,δ_:0,opts:OptionsPattern[]]:=With[{bases=OrthogonalBases[g,c,r,δ]},GeodesicPlot[NeighborhoodGraph[g,c,r],c,#,opts]&/@bases]
In[]:=
LocalDimension[GridGraph[{10,10}],46,4]
Out[]=
2
In[]:=
Row@OrthogonalBasesPlot[GridGraph[{10,10}],46,4]
Out[]=
Allow distance 7 between geodesics
In[]:=
Row@OrthogonalBasesPlot[GridGraph[{10,10}],46,4,1]
»
96
Out[]=
In[]:=
LocalDimension[GridGraph[{10,10,10}],445,3]
Out[]=
3
In[]:=
Row[Graph3D[#,ImageSize65,BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}}]&/@OrthogonalBasesPlot[GridGraph[{10,10,10}],445,3]]
Out[]=
In[]:=
LocalDimension[BuckyballGraph[7,"Embedded"],357,4]
Out[]=
1
In[]:=
Row[Graph3D[#,ImageSize70,BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}}]&/@OrthogonalBasesPlot[BuckyballGraph[7,"Embedded"],357,4]]
Out[]=
In[]:=
LocalDimension[BuckyballGraph[7,"Embedded"],357,4,1]
Out[]=
3
In[]:=
Row[Graph3D[#,ImageSize70,BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}}]&/@OrthogonalBasesPlot[BuckyballGraph[7,"Embedded"],357,4,1]]
Out[]=
In[]:=
LocalDimension
,184,4
Out[]=
1