Transportation of Spheres
Transportation of Spheres
Given two points, find their neighborhoods
b2=BuckyballGraph[2];
In[]:=
NeighborhoodGraph[b2,1,1,VertexLabelsAutomatic]
In[]:=
Out[]=
NeighborhoodGraph[b2,1,3]//VertexList
In[]:=
{1,2,3,4,5,6,7,11,8,12,9,13,10,14,17,18,15,21,22}
Out[]=
NeighborhoodGraph[b2,2,3]//VertexList
In[]:=
{2,1,3,4,5,6,7,11,8,12,9,13,10,14,19,20,16,23,24}
Out[]=
db2=GraphDistanceMatrix[b2];
In[]:=
db2[[#[[1]],#[[2]]]]&/@Tuples[{NeighborhoodGraph[b2,1,3]//VertexList,NeighborhoodGraph[b2,2,3]//VertexList}]
In[]:=
Out[]=
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
In[]:=
3.22715
Out[]=
Table[N[BallTransport[b2,1,2,r]],{r,8}]
In[]:=
{1.625,2.54,3.22715,4.09781,4.83678,5.60611,6.31198,6.95609}
Out[]=
tg=IndexGraph[TorusGraph[{5,5}]];
In[]:=
NeighborhoodGraph[tg,1,1,VertexLabelsAutomatic]
In[]:=
Out[]=
Table[N[BallTransport[tg,1,9,r]],{r,8}]
In[]:=
{1.68,2.17751,2.36735,2.4,2.4,2.4,2.4,2.4}
Out[]=
tg=IndexGraph[TorusGraph[{20,20}]];
In[]:=
NeighborhoodGraph[tg,1,1,VertexLabelsAutomatic]
In[]:=
Out[]=
Table[N[BallTransport[tg,1,3,r]],{r,8}]
In[]:=
{1.72,2.53846,3.416,4.31707,5.22897,6.13412,6.99233,7.76081}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
bg=BuckyballGraph[8];
In[]:=
NeighborhoodGraph[bg,1,1,VertexLabelsAutomatic]
In[]:=
Out[]=
Table[N[BallTransport[bg,1,2,r]],{r,8}]
In[]:=
{1.625,2.54,3.23823,4.19667,5.13327,5.99658,6.88651,7.77637}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
FindShortestPath[bg,1,500]
In[]:=
{1,4,8,18,26,44,52,74,94,120,136,176,202,236,262,300,322,368,410,460,500}
Out[]=
N[BallTransport[bg,1,#,3]]&/@FindShortestPath[bg,1,500]
In[]:=
{3.19114,3.51247,3.82825,4.52078,5.03601,6.04432,6.57341,7.71191,8.32133,9.48476,10.1939,11.3906,11.8698,13.,13.4238,14.6898,15.2909,16.5956,17.1911,18.4294,19.0249}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
Differences[%240]
In[]:=
{0.32133,0.315789,0.692521,0.515235,1.00831,0.529086,1.1385,0.609418,1.16343,0.709141,1.19668,0.479224,1.13019,0.423823,1.26593,0.601108,1.30471,0.595568,1.23823,0.595568}
Out[]=
ListLinePlot[%240/Range[Length[%240]]]
In[]:=
Out[]=
ListLinePlot[#/Range[Length[#]]&@(N[BallTransport[bg,1,#,2]]&/@FindShortestPath[bg,1,500])]
In[]:=
Out[]=
ListLinePlot[#/Range[Length[#]]&@(N[BallTransport[bg,1,#,4]]&/@FindShortestPath[bg,1,500])]
In[]:=
Out[]=
#/Range[Length[#]]&@(N[BallTransport[bg,1,#,4]]&/@FindShortestPath[bg,1,500])
In[]:=
{4.09573,2.17638,1.5248,1.2859,1.10635,1.06729,0.971756,0.973725,0.931206,0.938918,0.914861,0.935571,0.899063,0.909544,0.892265,0.907973,0.893799,0.911897,0.893915,0.910146,0.889203}
Out[]=
#/Range[Length[#]]&@(N[BallTransport[bg,1,#,5]]&/@FindShortestPath[bg,1,500])
In[]:=
{4.99527,2.60019,1.80687,1.48937,1.26106,1.16493,1.06252,1.03834,0.985293,0.986715,0.946855,0.961326,0.92115,0.938023,0.910775,0.926808,0.907067,0.925383,0.905905,0.919778,0.904154}
Out[]=
tg=IndexGraph[TorusGraph[{40,40}]];
In[]:=
FindShortestPath[tg,1,300]
In[]:=
{1,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30,32,34,36,38,40,100,140,180,220,260,300}
Out[]=
N[BallTransport[tg,1,#,3]]&/@FindShortestPath[tg,1,300]
In[]:=
{3.2256,3.416,3.6064,4.136,4.912,5.8288,6.8064,7.8032,8.8032,9.8032,10.8032,11.8032,12.8032,13.8032,14.8032,15.8032,16.8,17.7776,18.6944,19.4704,20.,20.5296,21.3056,22.2224,23.2,24.1968,25.1968}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
Differences[%248]
In[]:=
{0.1904,0.1904,0.5296,0.776,0.9168,0.9776,0.9968,1.,1.,1.,1.,1.,1.,1.,1.,0.9968,0.9776,0.9168,0.776,0.5296,0.5296,0.776,0.9168,0.9776,0.9968,1.}
Out[]=
ListLinePlot[%248/Range[Length[%248]]]
In[]:=
Out[]=
#/Range[Length[#]]&@(N[BallTransport[tg,1,#,3]]&/@FindShortestPath[tg,1,300])
In[]:=
{3.2256,1.708,1.20213,1.034,0.9824,0.971467,0.972343,0.9754,0.978133,0.98032,0.982109,0.9836,0.984862,0.985943,0.98688,0.9877,0.988235,0.987644,0.983916,0.97352,0.952381,0.933164,0.92633,0.925933,0.928,0.930646,0.933215}
Out[]=
#/Range[Length[#]]&@(N[BallTransport[tg,1,#,4]]&/@FindShortestPath[tg,1,300])
In[]:=
{4.16895,2.15854,1.4884,1.22234,1.10815,1.05939,1.03901,1.03026,1.02598,1.02326,1.02115,1.01938,1.01789,1.01661,1.01543,1.01394,1.0113,1.00605,0.996024,0.978792,0.952381,0.928371,0.916328,0.912131,0.912314,0.914497,0.917355}
Out[]=
ListLinePlot[{%258,%261}]
In[]:=
Out[]=
ListLinePlot[{#/Range[Length[#]]&@(N[BallTransport[tg,1,#,4]]&/@FindShortestPath[tg,1,300]),#/Range[Length[#]]&@(N[BallTransport[bg,1,#,4]]&/@FindShortestPath[bg,1,500])}]
In[]:=
Out[]=
ListLinePlot[{#/Range[Length[#]]&@(N[BallTransport[tg,1,#,5]]&/@FindShortestPath[tg,1,300]),#/Range[Length[#]]&@(N[BallTransport[bg,1,#,5]]&/@FindShortestPath[bg,1,500])}]
In[]:=
Out[]=
b7=BuckyballGraph[7];
In[]:=
GraphDiameter[b7]
In[]:=
47
Out[]=
GraphDistance[b7,1,1000]
In[]:=
32
Out[]=
ListLinePlot[{#/Range[Length[#]]&@(N[BallTransport[tg,1,#,5]]&/@FindShortestPath[tg,1,300]),#/Range[Length[#]]&@(N[BallTransport[bg,1,#,5]]&/@FindShortestPath[bg,1,500]),#/Range[Length[#]]&@(N[BallTransport[b7,1,#,5]]&/@FindShortestPath[b7,1,1000])}]
In[]:=
Out[]=
AntipodalPoints[g_]:=GraphPeriphery[g,"Method"{"PseudoDiameter","Aggressive"False}]
In[]:=
AntipodalPoints[IndexGraph[TorusGraph[{50,50}]]]
In[]:=
{1,1276}
Out[]=
Graph[BuckyballGraph[1],VertexLabelsAutomatic]
In[]:=
Out[]=
hg=IndexGraph[HyperbolicTilingGraph[]]
In[]:=
Out[]=
AntipodalPoints[hg]
In[]:=
{1,845}
Out[]=
CurvatureEstimateList[g_,r_]:=(#/Range[Length[#]]&@(N[BallTransport[g,1,#,r]]&/@(FindShortestPath[g,#[[1]],#[[2]]]&[AntipodalPoints[g]])))
In[]:=
CurvatureEstimateList[IndexGraph[TorusGraph[{50,50}]]]
In[]:=
{5.1083,2.61475,1.78357,1.42576,1.2516,1.16273,1.11637,1.09141,1.07707,1.06797,1.06144,1.05628,1.05195,1.04824,1.04502,1.04221,1.03973,1.03749,1.03532,1.03285,1.0295,1.02437,1.01628,1.00386,0.985907,0.961538,0.930415,0.909769,0.897534,0.891561,0.889841,0.89068,0.892852,0.895593,0.898468,0.901274,0.903942,0.90647,0.908868,0.911146,0.913313,0.915365,0.917245,0.918808,0.919777,0.91971,0.917976,0.913817,0.906493,0.89541,0.880229}
Out[]=
ParallelMapMonitored[CurvatureEstimateList[#,5]&,{IndexGraph[TorusGraph[{50,50}]],IndexGraph[TorusGraph[{25,25}]],BuckyballGraph[6],BuckyballGraph[7],BuckyballGraph[8],IndexGraph[HyperbolicTilingGraph[]]}]
In[]:=
Out[]=
ListLinePlot[MapIndexed[Legended,%320]]
In[]:=
Out[]=
ListLinePlot[MapIndexed[Legended,ParallelMapMonitored[CurvatureEstimateList[#,4]&,{IndexGraph[TorusGraph[{50,50}]],IndexGraph[TorusGraph[{25,25}]],BuckyballGraph[6],BuckyballGraph[7],BuckyballGraph[8],IndexGraph[HyperbolicTilingGraph[]]}]]]
In[]:=
Out[]=
legs={"T50","T25","B6","B7","B8","B9","H"};
In[]:=
ListLinePlot[MapIndexed[Legended[#,legs[[First[#2]]]]&,ParallelMapMonitored[CurvatureEstimateList[#,4]&,{IndexGraph[TorusGraph[{50,50}]],IndexGraph[TorusGraph[{25,25}]],BuckyballGraph[6],BuckyballGraph[7],BuckyballGraph[8],BuckyballGraph[9],IndexGraph[HyperbolicTilingGraph[]]}]]]
In[]:=
Out[]=
ListLinePlot[MapIndexed[Legended[#,legs[[First[#2]]]]&,ParallelMapMonitored[CurvatureEstimateList[#,7]&,{IndexGraph[TorusGraph[{50,50}]],IndexGraph[TorusGraph[{25,25}]],BuckyballGraph[6],BuckyballGraph[7],BuckyballGraph[8],BuckyballGraph[9],IndexGraph[HyperbolicTilingGraph[]]}]]]
In[]:=
Out[]=
AntipodalPoints[BuckyballGraph[7]]
In[]:=
{1,1280}
Out[]=
FindShortestPath[BuckyballGraph[7],1,1280]
In[]:=
{1,3,5,2,8,19,35,53,75,95,129,157,189,229,261,307,343,393,435,481,533,581,649,701,749,801,847,889,939,974,1021,1053,1091,1125,1153,1187,1207,1229,1247,1263,1274,1280}
Out[]=
HighlightGraph[BuckyballGraph[7],%328,EdgeStyle->Directive[Red,AbsoluteThickness[7]]]
In[]:=
Out[]=
HighlightGraph[BuckyballGraph[7],Style[#,PointSize[Large]]&/@%328]
In[]:=
Out[]=
GraphPlot3D[%]
In[]:=
Out[]=
Geodesic Bundle
Geodesic Bundle
b7=BuckyballGraph[7];
In[]:=
GeodesicBundle[g_Graph,{v1_,v2_},r_]:=Module[{spf=FindShortestPath[g,All,All],n1=NeighborhoodGraph[g,v1,r],n2=NeighborhoodGraph[g,v2,r]},HighlightGraph[g,Style[#,Thick,Red]&/@Flatten[Outer[PathGraph[spf[#1,#2]]&,VertexList[n1],VertexList[n2]]]]]
In[]:=
GeodesicBundle[g_Graph,{v1_,v2_},0]:=Module[{spf=FindShortestPath[g,All,All],n1=Graph[{v1},{}],n2=Graph[{v2},{}]},HighlightGraph[g,Style[#,Thick,Red]&/@Flatten[Outer[PathGraph[spf[#1,#2]]&,VertexList[n1],VertexList[n2]]]]]
In[]:=
NeighborhoodGraph[b7,1,3,VertexLabelsAutomatic]
In[]:=
Out[]=
GraphAntipodes[b7]
In[]:=
{1,1280}
Out[]=
NeighborhoodGraph[b7,1280,3,VertexLabelsAutomatic]
In[]:=
Out[]=
Outer[GraphDistance[b7,#1,#2]&,VertexList@NeighborhoodGraph[b7,1,3,VertexLabelsAutomatic],VertexList@NeighborhoodGraph[b7,1280,3,VertexLabelsAutomatic]]
In[]:=
Out[]=
mm2=Outer[GraphDistance[b7,#1,#2]&,VertexList@NeighborhoodGraph[b7,1,2,VertexLabelsAutomatic],VertexList@NeighborhoodGraph[b7,1280,2,VertexLabelsAutomatic]]
In[]:=
Out[]=
Outer[GraphDistance[b7,#1,#2]&,VertexList@NeighborhoodGraph[b7,1,1,VertexLabelsAutomatic],VertexList@NeighborhoodGraph[b7,1280,1,VertexLabelsAutomatic]]
In[]:=
{{41,40,40,40},{40,39,39,41},{40,39,41,39},{40,41,39,39}}
Out[]=
MinSumPermutation[%]
In[]:=
{4,2,2,3}
Out[]=
Want to find a permutation that minimizes some norm... (e.g. sum of distances)
Sum[mm[[i,perm[[i]]]],i]
If we could maintain direction, we’d get sectional curvature.....
MinGeodesicBundle[g_Graph,{v1_,v2_},r_]:=Module[{spf=FindShortestPath[g,All,All],n1=VertexList[NeighborhoodGraph[g,v1,r]],n2=VertexList[NeighborhoodGraph[g,v2,r]],perm},perm=MinSumPermutation[Echo@Outer[GraphDistance[g,#1,#2]&,n1,n2]];HighlightGraph[g,Style[#,Thick,Red]&/@Flatten[PathGraph[spf[#1,#2]]&@@@Transpose[{n1,n2[[perm]]}]]]]
In[]:=
MinGeodesicBundle[b7,{1,1280},2]
In[]:=
Out[]=
MinGeodesicBundle[b7,{1,1000},2]
In[]:=
Out[]=
MinGeodesicBundle[b7,{1,1000},3]
In[]:=
{{32,29,29,30,30,31,31,31,32,32,33,33,33,33,34,34,35,35,35},{33,30,30,31,31,32,32,32,33,33,34,34,34,34,35,35,36,36,36},{31,28,28,29,29,30,30,30,31,31,32,32,32,32,33,33,34,34,34},{31,28,28,29,29,30,30,30,31,31,32,32,32,32,33,33,34,34,34},{32,29,29,30,30,31,31,31,32,32,32,33,33,33,34,34,34,35,35},{33,30,30,31,31,32,32,32,33,33,33,34,34,34,35,35,35,36,36},{31,28,28,29,29,30,30,30,31,31,31,32,32,32,33,33,33,34,34},{34,31,31,32,32,33,33,33,34,34,35,35,35,35,36,36,37,37,37},{30,27,27,28,28,29,29,29,30,30,31,31,31,31,32,32,33,33,33},{34,31,31,32,32,33,33,33,34,34,34,35,35,35,36,36,36,37,37},{30,27,27,28,28,29,29,29,30,30,30,31,31,31,32,32,32,33,33},{32,29,29,30,30,31,31,31,32,32,33,33,33,33,34,34,35,35,35},{30,27,27,28,28,29,29,29,30,30,31,31,31,31,32,32,33,33,33},{35,32,32,33,33,34,34,34,35,35,36,36,36,36,37,37,38,38,38},{33,30,30,31,31,32,32,32,33,33,34,34,34,34,35,35,36,36,36},{29,26,26,27,27,28,28,28,29,29,30,30,30,30,31,31,32,32,32},{29,26,26,27,27,28,28,28,29,29,30,30,30,30,31,31,32,32,32},{31,28,28,29,29,30,30,30,31,31,32,32,32,32,33,33,34,34,34},{29,26,26,27,27,28,28,28,29,29,30,30,30,30,31,31,32,32,32}}
»
Out[]=
b9=BuckyballGraph[9];
In[]:=
GraphAntipodes[b8]
In[]:=
{1,2000}
Out[]=
MinGeodesicBundle[b9,{1,1000},3]
In[]:=
{{29,26,26,27,28,26,27,28,29,28,30,28,29,30,31,31,30,32},{30,27,27,28,29,27,28,29,30,29,31,29,30,31,32,32,31,33},{28,25,25,26,27,25,26,27,28,27,29,27,28,29,30,30,29,31},{28,25,25,26,27,25,26,27,28,27,29,27,28,29,30,30,29,31},{30,27,27,28,28,27,28,29,29,29,30,29,30,31,31,32,31,33},{31,28,28,29,29,28,29,30,30,30,31,30,31,32,32,33,32,34},{29,26,26,27,27,26,27,28,28,28,29,28,29,30,30,31,30,32},{31,28,28,29,30,28,29,30,31,30,32,30,31,32,33,33,32,34},{27,24,24,25,26,24,25,26,27,26,28,26,27,28,29,29,28,30},{32,29,29,30,30,29,30,31,31,31,32,31,32,33,33,34,33,35},{28,25,25,26,26,25,26,27,27,27,28,27,28,29,29,30,29,31},{29,26,26,27,28,26,27,28,29,28,30,28,29,30,31,31,30,32},{27,24,24,25,26,24,25,26,27,26,28,26,27,28,29,29,28,30},{32,29,29,30,31,29,30,31,32,31,33,31,32,33,34,34,33,35},{30,27,27,28,29,27,28,29,30,29,31,29,30,31,32,32,31,33},{26,23,23,24,25,23,24,25,26,25,27,25,26,27,28,28,27,29},{26,23,23,24,25,23,24,25,26,25,27,25,26,27,28,28,27,29},{28,25,25,26,27,25,26,27,28,27,29,27,28,29,30,30,29,31},{26,23,23,24,25,23,24,25,26,25,27,25,26,27,28,28,27,29}}
»
