Transportation of Spheres
Transportation of Spheres
Given two points, find their neighborhoods
In[]:=
b2=BuckyballGraph[2];
In[]:=
NeighborhoodGraph[b2,1,1,VertexLabelsAutomatic]
Out[]=
In[]:=
NeighborhoodGraph[b2,1,3]//VertexList
Out[]=
{1,2,3,4,5,6,7,11,8,12,9,13,10,14,17,18,15,21,22}
In[]:=
NeighborhoodGraph[b2,2,3]//VertexList
Out[]=
{2,1,3,4,5,6,7,11,8,12,9,13,10,14,19,20,16,23,24}
In[]:=
db2=GraphDistanceMatrix[b2];
In[]:=
db2[[#[[1]],#[[2]]]]&/@Tuples[{NeighborhoodGraph[b2,1,3]//VertexList,NeighborhoodGraph[b2,2,3]//VertexList}]
Out[]=
In[]:=
BallTransport[g_,v1_,v2_,r_]:=Mean[Module[{m=GraphDistanceMatrix[g]},m[[#[[1]],#[[2]]]]&/@Tuples[{NeighborhoodGraph[g,v1,r]//VertexList,NeighborhoodGraph[g,v2,r]//VertexList}]]]
In[]:=
BallTransport[b2,1,2,3]//N
Out[]=
3.22715
In[]:=
Table[N[BallTransport[b2,1,2,r]],{r,8}]
Out[]=
{1.625,2.54,3.22715,4.09781,4.83678,5.60611,6.31198,6.95609}
In[]:=
tg=IndexGraph[TorusGraph[{5,5}]];
In[]:=
NeighborhoodGraph[tg,1,1,VertexLabelsAutomatic]
Out[]=
In[]:=
Table[N[BallTransport[tg,1,9,r]],{r,8}]
Out[]=
{1.68,2.17751,2.36735,2.4,2.4,2.4,2.4,2.4}
In[]:=
tg=IndexGraph[TorusGraph[{20,20}]];
In[]:=
NeighborhoodGraph[tg,1,1,VertexLabelsAutomatic]
Out[]=
In[]:=
Table[N[BallTransport[tg,1,3,r]],{r,8}]
Out[]=
{1.72,2.53846,3.416,4.31707,5.22897,6.13412,6.99233,7.76081}
In[]:=
ListLinePlot[%]
Out[]=
In[]:=
bg=BuckyballGraph[8];
In[]:=
NeighborhoodGraph[bg,1,1,VertexLabelsAutomatic]
Out[]=
In[]:=
Table[N[BallTransport[bg,1,2,r]],{r,8}]
Out[]=
{1.625,2.54,3.23823,4.19667,5.13327,5.99658,6.88651,7.77637}
In[]:=
ListLinePlot[%]
Out[]=
Geodesic Bundle
Geodesic Bundle
Want to find a permutation that minimizes some norm... (e.g. sum of distances)
If we could maintain direction, we’d get sectional curvature.....