gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]
GeodesicBundle[g_Graph,{v1_,v2_},r_]:=Module[{spf=FindShortestPath[g,All,All],n1=NeighborhoodGraph[g,v1,r],n2=NeighborhoodGraph[g,v2,r]},HighlightGraph[g,Style[#,Thick,Red]&/@Flatten[Outer[PathGraph[spf[#1,#2]]&,VertexList[n1],VertexList[n2]]]]]
In[]:=
GeodesicBundle[g_Graph,{v1_,v2_},0]:=Module[{spf=FindShortestPath[g,All,All],n1=Graph[{v1},{}],n2=Graph[{v2},{}]},HighlightGraph[g,Style[#,Thick,Red]&/@Flatten[Outer[PathGraph[spf[#1,#2]]&,VertexList[n1],VertexList[n2]]]]]
In[]:=
Geodesics[g_Graph,vpairs:{{_,_}..}]:=HighlightGraph[g,Style[PathGraph[FindShortestPath[g,#[[1]],#[[2]]]],Thickness[.02],Red]&/@vpairs]
In[]:=
GeodesicsAll[g_Graph,vpairs:{{_,_}..}]:=HighlightGraph[g,ParallelMapMonitored[(Style[PathGraph[#],Thick,Red]&/@FindPath[g,#[[1]],#[[2]],{GraphDistance[g,#[[1]],#[[2]]]},All])&,vpairs]]
In[]:=
RandomGeodesic[gx_,n_Integer:1]:=With[{g=IndexGraph[gx,EdgeStyleLightGray,VertexStyleLightGray]},With[{spf=FindShortestPath[g,All,All],vl=VertexList[g]},HighlightGraph[g,Table[Style[PathGraph[spf[RandomChoice[vl],RandomChoice[vl]]],Thick,RandomColor[]],n]]]]
sph=IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[]]]
In[]:=
Out[]=
VertexList[sph]
In[]:=
GeodesicBundle[sph,{1,600},1]
In[]:=
Out[]=
GeodesicBundle[sph,{1,600},0]
In[]:=
Out[]=
Geodesics[sph,{{1,600}}]
In[]:=
Out[]=
GeodesicsAll[sph,{{1,600}}]
In[]:=
Out[]=
GeodesicsAll[sph,{{1,600},{86,182}}]
In[]:=
$Aborted
Out[]=
NeighborhoodGraph[sph,1,VertexLabelsAutomatic]
In[]:=
Out[]=
NeighborhoodGraph[sph,600,VertexLabelsAutomatic]
In[]:=
Out[]=
Graph[{},{4}]
In[]:=
Graph[{},{4}]
Out[]=
HighlightGraph[sph,{1,600}]
In[]:=
Out[]=
HighlightGraph[sph,NeighborhoodGraph[sph,1,2]]
In[]:=
Out[]=
HighlightGraph[sph,NeighborhoodGraph[sph,1,0]]
In[]:=
Out[]=
bb8=BuckyballGraph[8,"Embedded"]
In[]:=
Out[]=
GeodesicBundle[bb8,{1,600},1]
In[]:=
Out[]=
GeodesicBundle[bb8,{1,600},2]
In[]:=
Out[]=
GeodesicBundle[bb8,{1,1000},2]
In[]:=
Out[]=
GeodesicBundle[bb8,{1,1000},3]
In[]:=
Out[]=

WM geodesic

gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]
In[]:=
Out[]=
Geodesics[gtest,{{79,207}}]
In[]:=
Out[]=
Geodesics[gtest,{{143,258}}]
In[]:=
Out[]=
Graph[%,VertexLabelsAutomatic]
In[]:=
Out[]=
GeodesicsAll[gtest,{{79,207}}]
In[]:=
Out[]=
GeodesicsAll[GridGraph[{20,20}],{{114,327}}]
In[]:=
$Aborted
Out[]=

Examples

Geodesics[bb8,{{1,1000}}]
In[]:=
Out[]=
Geodesics[bb8,{{1,1000},{22,1044}}]
In[]:=
Out[]=
NeighborhoodGraph[bb8,1,3,VertexLabelsAutomatic]
In[]:=
Out[]=
NeighborhoodGraph[bb8,1000,3,VertexLabelsAutomatic]
In[]:=
Out[]=
GridGraph[{20,20}]
In[]:=
Out[]=
VertexList[%]
In[]:=
Out[]=
Geodesics[GridGraph[{20,20}],{{114,327}}]
In[]:=
Out[]=
rgraph=IndexGraph[MeshConnectivityGraph[DiscretizeRegion[Rectangle[],MaxCellMeasure.002],VertexSize->Tiny]]
In[]:=
Out[]=
Geodesics[rgraph,{{187,218}}]
In[]:=
Out[]=
Geodesics[rgraph,{{187,90}}]
In[]:=
Out[]=
Geodesics[rgraph,{{50,300}}]
In[]:=
Out[]=
Graph[rgraph,VertexLabelsAutomatic]
In[]:=
Out[]=