Bundle of geodesics

Optimization

mm=
;
In[]:=
MinSumPermutation[mm_?MatrixQ]:=Module[{n,m,objective,constraints,vars,res,p},​​{n,m}=Dimensions[mm];objective=Total[Inactive[Times][p,mm],2];constraints={Table[Sum[Indexed[p,{i,j}],{j,m}]1,{i,n}],Table[Sum[Indexed[p,{i,j}],{i,n}]≤1,{j,m}],0p1};vars={Element[p,Matrices[{n,m},Integers]]};res=LinearOptimization[objective,constraints,vars];Flatten[SparseArray[p/.res]["NonzeroPositions"][[All,2]]]]
In[]:=
With[{perm=Echo[MinSumPermutation[mm]]},Sum[mm[[i,perm[[i]]]],{i,Length[mm]}]]
In[]:=
{6,12,5,9,2,3,13,10,16,4,7,1,19,8,17,14,18,15,11}
»
701
Out[]=

GeodesicsBundle

GeodesicsBundle[graph_,endpoints:{_Integer,_Integer},neighborhoodSize_:3,plottingFunction_:GeodesicsAll]:=Module[{neighborhoods,distanceMatrix,matchingEndpoints},​​neighborhoods=VertexList[NeighborhoodGraph[graph,#,neighborhoodSize]]&/@endpoints;​​distanceMatrix=Outer[GraphDistance[graph,#1,#2]&,neighborhoods〚1〛,neighborhoods〚2〛];​​matchingEndpoints=If[Dimensions[distanceMatrix]〚1〛≥Dimensions[distanceMatrix]〚2〛,​​Transpose[{neighborhoods〚1,MinSumPermutation[Transpose@distanceMatrix]〛,neighborhoods〚2〛}],Transpose[{neighborhoods〚1〛,neighborhoods〚2,MinSumPermutation[distanceMatrix]〛}]];​​plottingFunction[graph,matchingEndpoints]​​]
In[]:=
GeodesicsBundle[graph_,endpointFractions:{_Real,_Real},neighborhoodSize_:3]:=Module[{path,endpoints},​​path=FindShortestPath[graph,Sequence@@GraphAntipodes[graph]];​​endpoints=path〚Round[endpointFractionsLength[path]]〛;​​GeodesicsBundle[graph,endpoints,neighborhoodSize]​​]
In[]:=
GeodesicsBundle[graph_,neighborhoodSize_:3]:=GeodesicsBundle[graph,{0.2,0.8},neighborhoodSize]
In[]:=

GeodesicsAll

ShortestPathsVertices[graph_,v1_,v2_]:=VertexList[graph]〚Position[MapThread[Plus,{GraphDistance[graph,v1],GraphDistance[graph,v2]}],GraphDistance[graph,v1,v2]]〚All,1〛〛
In[]:=
GeodesicsAll[g_Graph,vpairs:{{_,_}..}]:=HighlightGraph[g,Style[Subgraph[g,Catenate[ShortestPathsVertices[g,##]&@@@vpairs]],Thickness[.02],Red]]
In[]:=

Buckyball

Row[Show[GeodesicsBundle[BuckyballGraph[7,"Embedded"],#],ImageSize300]&/@Range[3,6]]
In[]:=
Out[]=
With[{ball20=BuckyballGraph[20,"Embedded"]},Row[Show[GeodesicsBundle[ball20,#],ImageSize300]&/@Range[3,6]]]
In[]:=
$Aborted
Out[]=

Hexagonal graph

HexagonalGrid[width_?EvenQ, height_?EvenQ] := SimpleGraph @ GraphCatenate @ ​​ CatenateThread /@ TableIfEvenQ[i + Ceiling[i / width]],​​ Int[i]  ​​ If[i - width ≥ 1, Int[i - width], Ext[i]],​​ If[i + width ≤ width height, Int[i + width], Ext[Mod[i - 1, width] + 1 + width]],​​ IfMod[i, width]  0, Ext
Quotient[i, width] + 4 width + height
2
, Int[i + 1]​​ ,​​ Int[i]  ​​ If[i - width ≥ 1, Int[i - width], Ext[i]],​​ IfMod[i, width]  1, Ext
Quotient[i, width] + 4 width + 1
2
, Int[i - 1],​​ If[i + width ≤ width height, Int[i + width], Ext[Mod[i - 1, width] + 1 + width]]​​ , {i, 1, width height}​​  /. Missing[]  Ext[RandomInteger[{0,
64
2
-1}]],​​ Table​​ Ifi ≤ width, Ext[i]  Int[i],​​ Ifi ≤ 2 width, Ext[i]  Int[width (height - 2) + i],​​ Ifi ≤ 2 width +
height
2
, Ext[i]  Int[(i - 2 width) 2 width - width + 1],​​ Ext[i]  Inti - 2 width -
height
2
2 width​​  ​​ ​​ ,​​ {i, 1, 2 width + height}​​, DirectedEdges  False
In[]:=
GeodesicsBundle[IndexGraph[HexagonalGrid[36,36]],{713,730},3]
In[]:=
Out[]=
Similar effect seems to be happening to the spheres.

Discretized sphere

GeodesicsBundle[IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[]]],1]
In[]:=
Out[]=
GeodesicsBundle[IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[],MaxCellMeasure0.0001]],1]
In[]:=
Out[]=

SpherePoints

GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[SpherePoints[1000],4]],1]]
In[]:=
Out[]=
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[SpherePoints[10000],4]],1]]
In[]:=
Out[]=

Random points

GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],1000],4]],2]]
In[]:=
Out[]=
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],10000],4]],{0.3,0.7}]]
In[]:=
Out[]=
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],10000],4]],{0.3,0.7},5]]
In[]:=
Out[]=
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],10000],10]],{0.3,0.7},3]]
In[]:=
Out[]=
Maybe measure how they diverge statistically?
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],10000],4]],{0.1,0.9},3]]
In[]:=
Out[]=
GraphPlot3D[GeodesicsBundle[IndexGraph[NearestNeighborGraph[RandomPoint[Sphere[],10000],4]],{0.1,0.9},3]]
In[]:=
Out[]=

Partial conclusion

We are getting discretization effects: either due to (non-isotropic) grid, or due to randomness.
We need to get away from these effects by making the graphs large: the graph itself should be large (
~
6
10
vertices), the geodesics should be long (~1000 vertices), the bundle radius should be large (
~100
). In that case, we should be able to get results that start to approximate continuous case, however, we won’t be able to see the grid at that scale.

Mesh Ellipsoid

Ellipsoid diverge one direction vs. the other direction

Cylinder growth going one or another way around the ellipsoid

Network for deSitter or anti-deSitter space