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 »
WOLFRAM NOTEBOOK
Failed attempt at parallel lines
Failed attempt at parallel lines
In[]:=
GeodesicsBundle[sphere,{.3,.7},3]
»
{1,660,180,1140,60,780,300,1260,30,690,210,1170,90,810,330,1290,10,644,164,1124,44,764,284,1244,14,674,194,1154,74,794,314,1274,8,1288,328,808,88,1168,208,688,28,1258,298,778,58,1138,178,658,2}
»
{330,1288}
Out[]=
$Aborted
In[]:=
neighborhoods=VertexList[NeighborhoodGraph[sphere,#,3]]&/@{330,1288}
Out[]=
{{330,10,90,181,320,524,542,644,661,800,810,1003,1004,1022,1141,1170,1273,1280,1290,1484,1502,1503,1724,1725,1742,1743,2098,2099,2206,2207,2208,2216,2217,2260,2261,2262},{1288,8,88,165,172,314,321,328,515,635,645,652,801,808,995,1115,1125,1274,1281,1475,1595,2035,2036,2037,2107,2108,2109,2179,2180,2181,2234,2539,2540,2541}}
In[]:=
distanceMatrix=Outer[GraphDistance[sphere,#1,#2]&,neighborhoods〚1〛,neighborhoods〚2〛];
In[]:=
farthestPoints=Position[distanceMatrix,Max[distanceMatrix]]〚1〛
Out[]=
{16,3}
In[]:=
longestPath=FindShortestPath[sphere,neighborhoods〚1,farthestPoints〚1〛〛,neighborhoods〚2,farthestPoints〚2〛〛]
Out[]=
{1170,90,810,330,1290,10,644,164,1124,44,764,284,1244,14,674,194,1154,74,794,314,1274,8,1288,328,808,88}
In[]:=
orthogonalVertices=With[{minDistances=Min/@Outer[GraphDistance[sphere,#1,#2]&,#,longestPath]},#〚Position[minDistances,Max[minDistances]]〚All,1〛〛]&/@neighborhoods
Out[]=
{{800,1004,1141,1502,1725,1742,2098},{801,995,1125,1595,2107,2109}}
In[]:=
parallelLines=With[{distanceMatrix=Abs[Outer[GraphDistance[sphere,#1,#2]&,orthogonalVertices〚1〛,orthogonalVertices〚2〛]-GraphDistance[sphere,330,1288]]},{orthogonalVertices〚1,#〚1〛〛,orthogonalVertices〚2,#〚2〛〛}&/@Position[distanceMatrix,Min[distanceMatrix]]]
Out[]=
{{1725,1595},{1742,995},{1742,1595},{2098,2109}}
In[]:=
With[{subsets=Subsets[parallelLines,{2}]},With[{crossDistances=Abs[GraphDistance[sphere,#〚1,1〛,#〚2,2〛]-GraphDistance[sphere,#〚1,2〛,#〚2,1〛]]&/@subsets},subsets〚Position[crossDistances,Min[crossDistances]]〚1,1〛〛]]
Out[]=
{{1725,1595},{1742,1595}}
In[]:=
GraphDistance[sphere,330,1288]
Out[]=
19
In[]:=
GeodesicsAll[sphere,{{330,1288}}]
Out[]=
Only using geodesics from the bundle
Only using geodesics from the bundle
In[]:=
GeodesicsBundle[sphere,{.3,.7},3]
»
{1,660,180,1140,60,780,300,1260,30,690,210,1170,90,810,330,1290,10,644,164,1124,44,764,284,1244,14,674,194,1154,74,794,314,1274,8,1288,328,808,88,1168,208,688,28,1258,298,778,58,1138,178,658,2}
»
{330,1288}
Out[]=
In[]:=
neighborhoods=VertexList[NeighborhoodGraph[sphere,#,3]]&/@{330,1288}
Out[]=
{{330,10,90,181,320,524,542,644,661,800,810,1003,1004,1022,1141,1170,1273,1280,1290,1484,1502,1503,1724,1725,1742,1743,2098,2099,2206,2207,2208,2216,2217,2260,2261,2262},{1288,8,88,165,172,314,321,328,515,635,645,652,801,808,995,1115,1125,1274,1281,1475,1595,2035,2036,2037,2107,2108,2109,2179,2180,2181,2234,2539,2540,2541}}
In[]:=
distanceMatrix=Outer[GraphDistance[sphere,#1,#2]&,neighborhoods〚1〛,neighborhoods〚2〛];
In[]:=
matchingEndpoints=If[Dimensions[distanceMatrix]〚1〛≥Dimensions[distanceMatrix]〚2〛,Transpose[{neighborhoods〚1,MinSumPermutation[Transpose@distanceMatrix]〛,neighborhoods〚2〛}],Transpose[{neighborhoods〚1〛,neighborhoods〚2,MinSumPermutation[distanceMatrix]〛}]]
Out[]=
In[]:=
With[{subsets=Subsets[matchingEndpoints,{2}]},With[{inBundleDistances=GraphDistance[sphere,#〚1,1〛,#〚2,1〛]+GraphDistance[sphere,#〚1,2〛,#〚2,2〛]&/@subsets},subsets〚Position[inBundleDistances,Max[inBundleDistances]]〚All,1〛〛]]
Out[]=
{{{1502,801},{800,1595}},{{1141,995},{800,1595}},{{800,1595},{1742,2107}}}
In[]:=
GeodesicsAll[sphere,{{800,1595},{1742,2107}}]
Out[]=
Manual
Manual
In[]:=
HighlightGraph[NeighborhoodGraph[sphere,644,7,VertexLabelsAutomatic],FindShortestPath[sphere,644,1288]]
Out[]=