Code
Code
Optimization
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
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
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
Sphere
Discrete
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
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
Plane
Single geodesic
Bundle of radius 1
Bundle of radius 3
Continuous
Continuous
Hyperboloid
Hyperboloid
Single geodesic
Bundle of radius 1
Bundle of radius 3
Continuous
Continuous
https://demonstrations.wolfram.com/HyperboloidGeodesics/