WOLFRAM NOTEBOOK

Code

Optimization

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}],0p1};vars={Element[p,Matrices[{n,m},Integers]]};res=LinearOptimization[objective,constraints,vars];Flatten[SparseArray[p/.res]["NonzeroPositions"][[All,2]]]]

GeodesicsBundle

In[]:=
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[]:=
GraphAntipodes[g_]:=GraphPeriphery[g,"Method"{"PseudoDiameter","Aggressive"False}]
In[]:=
GeodesicsBundle[graph_,endpointFractions:{_Real,_Real},neighborhoodSize_:3]:=Module[{path,endpoints},​​path=FindShortestPath[graph,Sequence@@GraphAntipodes[graph]];​​endpoints=path〚Round[endpointFractionsLength[path]]/.01〛;​​GeodesicsBundle[graph,endpoints,neighborhoodSize]​​]
In[]:=
GeodesicsBundle[graph_,neighborhoodSize_:3]:=GeodesicsBundle[graph,{0.2,0.8},neighborhoodSize]

GeodesicsAll

In[]:=
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]]

Sphere

Discrete

Single geodesic
In[]:=
GeodesicsBundle[IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[]]],{0.3,0.7},0]
Out[]=
Bundle of radius 1
In[]:=
GeodesicsBundle[IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[]]],{0.3,0.7},1]
Out[]=
Bundle of radius 3
In[]:=
GeodesicsBundle[IndexGraph@MeshConnectivityGraph[DiscretizeGraphics[Sphere[]]],{0.3,0.7},3]
Out[]=

Continuous

In[]:=
sphereGeodesic[p1_,p2_]:=Line[Normalize/@Table[p1+t(p2-p1),{t,0,1,0.01}]]
In[]:=
spherePoint[θ_,ϕ_]:={Cos[ϕ]Cos[θ],Sin[ϕ]Cos[θ],Sin[θ]}
In[]:=
Graphics3D[{Sphere[],Thick,sphereGeodesic[spherePoint[0.48π,-π/4],spherePoint[-0.1π,-π/4]],sphereGeodesic[spherePoint[0.48π,-π/4+0.05/Cos[0.48π]],spherePoint[-0.1π,-π/4+0.05/Cos[-0.1π]]],sphereGeodesic[spherePoint[0.48π,-π/4-0.05/Cos[0.48π]],spherePoint[-0.1π,-π/4-0.05/Cos[-0.1π]]]},BoxedFalse]
Out[]=

Plane

Single geodesic
Bundle of radius 1
Bundle of radius 3

Continuous

Hyperboloid

Single geodesic
Bundle of radius 1
Bundle of radius 3

Continuous

Wolfram Cloud

You are using a browser not supported by the Wolfram Cloud

Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.


I understand and wish to continue anyway »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.