Wolfram Cloud Page

WOLFRAM NOTEBOOK

Bundle of geodesics

Optimization

In[]:=

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]}]]

{6,12,5,9,2,3,13,10,16,4,7,1,19,8,17,14,18,15,11}

Out[]=

701

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

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]

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]]

Buckyball

In[]:=

Row[Show[GeodesicsBundle[BuckyballGraph[7,"Embedded"],#],ImageSize300]&/@Range[3,6]]

Out[]=

In[]:=

With[{ball20=BuckyballGraph[20,"Embedded"]},Row[Show[GeodesicsBundle[ball20,#],ImageSize300]&/@Range[3,6]]]

Out[]=

$Aborted

Hexagonal graph

In[]:=

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

, 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

, 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,

-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

, Ext[i]  Int[(i - 2 width) 2 width - width + 1], Ext[i]  Inti - 2 width -

height

2 width   , {i, 1, 2 width + height}, DirectedEdges  False

In[]:=

GeodesicsBundle[IndexGraph[HexagonalGrid[36,36]],{713,730},3]

Out[]=

Similar effect seems to be happening to the spheres.

Discretized sphere

SpherePoints

Random points

Maybe measure how they diverge statistically?

Partial conclusion

We are getting discretization effects: either due to (non-isotropic) grid, or due to randomness.

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

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 »