Ellipsoid Mesh

Ellipsoid

makeEllipsoidCode[a_,b_,c_,resolution_]:=StringTemplate[​​"cd(\"`6`\")\n"<>​​"fd=@(p) p(:, 1).^2 / `1`^2 + p(:, 2).^2 / `2`^2 + p(:, 3).^2 / `3`^2 - 1;\n"<>​​"[p, t] = distmeshsurface(fd, @huniform, `4`, [-1.1 * `1`, -1.1 * `2`, -1.1 * `3`; 1.1 * `1`, 1.1 * `2`, 1.1 * `3`]);\n"<>​​"writematrix(p, \"`5`/points.txt\");\n"<>​​"writematrix(t, \"`5`/triangles.txt\");"][a,b,c,resolution,$TemporaryDirectory,FileNameJoin[{$Dropbox,"Physics/CodeDevelopment/ExternalCode/distmesh"}]]
In[]:=
makeEllipsoidCode[1,3,3,0.15]
In[]:=
cd("/Users/maxitg/Dropbox (Wolfram)/Physics/CodeDevelopment/ExternalCode/distmesh")fd=@(p) p(:, 1).^2 / 1^2 + p(:, 2).^2 / 3^2 + p(:, 3).^2 / 3^2 - 1;[p, t] = distmeshsurface(fd, @huniform, 0.15, [-1.1 * 1, -1.1 * 3, -1.1 * 3; 1.1 * 1, 1.1 * 3, 1.1 * 3]);writematrix(p, "/private/var/folders/pz/q1ty3f9x1yq5f2ppwrkhgz4r0000gn/T/points.txt");writematrix(t, "/private/var/folders/pz/q1ty3f9x1yq5f2ppwrkhgz4r0000gn/T/triangles.txt");
Out[]=
getEllipsoid[]:=With[{points=Import[FileNameJoin[{$TemporaryDirectory,"points.txt"}],"CSV"],triangles=Import[FileNameJoin[{$TemporaryDirectory,"triangles.txt"}],"CSV"]},With[{simpleGraph=SimpleGraph[UndirectedEdge@@@Catenate[Partition[#,2,1,-1]&/@triangles]]},Graph3D[simpleGraph,VertexCoordinatespoints〚VertexList[simpleGraph]〛]]]
In[]:=
ellipsoid133=getEllipsoid[];
In[]:=
sphere=
Graph[
]
;
In[]:=
ellipsoid123=
Graph[
]
;
In[]:=
ellipsoid113=
Graph[
]
;
In[]:=
ellipsoid133=
Graph[
]
;
In[]:=

Ricci Scalar

ricciScalar[graph_]:=With{volumes=GraphNeighborhoodVolumes[graph]},
6(2+2)
2
Range[Length[#]-1]
1-
Rest[#]
π
2
Range[Length[#]-1]
&/@(Take[#,Min[Length/@volumes]]&)/@volumes
In[]:=
ricciScalarPlot[graph_,opts___]:=ListPlot[MeanAround/@Transpose[Values[ricciScalar[graph]]],opts]
In[]:=
ricciScalarEllipsoid=N[ricciScalar[ellipsoid133]];
In[]:=
Take[ReverseSort[Max/@ricciScalarEllipsoid],10]
In[]:=
35550.0187665,150.0133542,35590.0121898,34530.0110267,27810.010459,38500.00989376,31850.00944099,1570.0090753,39520.00903277,38540.00903277
Out[]=
ListPlot[ricciScalarEllipsoid[3555],JoinedTrue,PlotRange{All,{-0.01,All}}]
In[]:=
Out[]=
Take[Sort[ricciScalarEllipsoid〚All,10〛],10]
In[]:=
2634-0.0396034,2179-0.0388395,2375-0.0388395,2753-0.0388395,2286-0.0373116,2598-0.0373116,1300-0.0365476,1946-0.0365476,1970-0.0365476,1972-0.0365476
Out[]=
VertexCount[ellipsoid133]
In[]:=
4150
Out[]=
Normal[Sort[ricciScalarEllipsoid〚All,10〛]]〚4150/2〛
In[]:=
3049-0.0166851
Out[]=
The position on the ellipsoid with the largest curvature
HighlightGraph[ellipsoid133,NeighborhoodGraph[ellipsoid133,3555,1],GraphHighlightStyle"Thick"]
In[]:=
Out[]=
The smallest curvature
HighlightGraph[ellipsoid133,NeighborhoodGraph[ellipsoid133,2634,1],GraphHighlightStyle"Thick"]
In[]:=
Out[]=
In the middle
HighlightGraph[ellipsoid133,NeighborhoodGraph[ellipsoid133,3049,1],GraphHighlightStyle"Thick"]
In[]:=
Out[]=
Options[GraphFunctionPlot]=Join[{PlotRangeAutomatic},Options[GraphPlot]];​​GraphFunctionPlot[graph_Graph,vertexValue_Association,func_:GraphPlot,o:OptionsPattern[]]:=With{plotRange=Replace[OptionValue[PlotRange],AutomaticMinMax[vertexValue]]},WithvertexValues=
#-plotRange〚1〛
plotRange〚2〛-plotRange〚1〛
&/@vertexValue,func[graph,VertexStyleNormal[ColorData["RedBlueTones"]/@vertexValues],EdgeStyleColorData["RedBlueTones"]/@(Mean[vertexValues/@List@@#]&)/@EdgeList[graph],FilterRules[FilterRules[{o},Options[GraphPlot]],Except[PlotRange]]]
In[]:=
MinMax[ricciScalarEllipsoid〚All,10〛]
In[]:=
{-0.0396034,0.0169284}
Out[]=
GraphFunctionPlot[ellipsoid133,ricciScalarEllipsoid〚All,10〛,GraphPlot3D,PlotRange->{-0.03960340402384174`,0.016928431762399488`}]
In[]:=
Out[]=

Orthogonal Directions

Row[Graph3D[#,ImageSize65,BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}}]&/@OrthogonalBasesPlot[ellipsoid133,3555,5]]
In[]:=
Out[]=
direction1={3760,3113};direction2={3326,3557};
In[]:=
HighlightGraph[ellipsoid133,{Subgraph[ellipsoid133,FindShortestPath[ellipsoid133,##]&@@direction1],Subgraph[ellipsoid133,FindShortestPath[ellipsoid133,##]&@@direction2]}]
In[]:=
Out[]=

Geodesic Bundles in orthogonal directions

GeodesicsBundle[ellipsoid133,direction1]
In[]:=
Out[]=
GeodesicsBundle[ellipsoid133,direction2]
In[]:=
Out[]=

Cylinder growth

tubeVolume[graph_,v1_,v2_,r_]:=VertexCount@NeighborhoodGraph[graph,FindShortestPath[graph,v1,v2],r]
In[]:=
tube1Growth=Table[tubeVolume[ellipsoid133,3760,3113,r],{r,0,5}];
In[]:=
tube2Growth=Table[tubeVolume[ellipsoid133,3326,3557,r],{r,0,5}];
In[]:=
ListPlot[{tube1Growth,tube2Growth},PlotLegends{1,2}]
In[]:=
Out[]=

Longer tubes

bases=OrthogonalBases[ellipsoid133,3555,10];
In[]:=
Length[bases]
In[]:=
8
Out[]=
LocalDimension[ellipsoid133,3555,10]
In[]:=
2
Out[]=
Row[Graph3D[#,ImageSize65,BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}}]&/@OrthogonalBasesPlot[ellipsoid133,3555,10]]
In[]:=
Out[]=
bases〚-2〛
In[]:=
{{2661,3752},{2888,3635}}
Out[]=
tube1Growth=Table[tubeVolume[ellipsoid133,2661,3752,r],{r,0,10}];
In[]:=
tube2Growth=Table[tubeVolume[ellipsoid133,2888,3635,r],{r,0,10}];
In[]:=
ListPlot[{tube1Growth,tube2Growth},PlotLegends{1,2}]
In[]:=
Out[]=

Ball growth

DimensionEstimateList[g_Graph,v_]:=ResourceFunction["LogDifferences"][N[First[Values[GraphNeighborhoodVolumes[g,{v}]]]]]
In[]:=
VolumeList[g_Graph,v_]:=N[First[Values[GraphNeighborhoodVolumes[g,{v}]]]]
In[]:=
DimensionEstimateList[ellipsoid133,3555]
In[]:=
{2.58496,2.41902,2.40942,2.26113,2.25829,2.18275,2.13768,2.10834,2.12784,2.10146,2.11504,2.09254,2.07544,2.11401,2.06902,2.01141,1.94465,1.91203,1.94498,1.89693,1.87536,1.84006,1.82725,1.84936,1.80554,1.78304,1.79358,1.75954,1.75805,1.68757,1.706,1.64302,1.62517,1.60912,1.60732,1.56853,1.52047,1.48802,1.48188,1.42878,1.3788,1.3081,1.26398,1.22178,1.05406,0.971797,0.809749,0.54347,0.263099}
Out[]=
Show[ListLinePlot[Table[DimensionEstimateList[ellipsoid133,v],{v,{3555,2634}}],FrameTrue],Plot[2,{r,0,50},PlotStyleDotted]]
In[]:=
Out[]=
HighlightGraph[Graph[ellipsoid133,EdgeStyleLightGray,VertexStyleLightGray],{Style[NeighborhoodGraph[ellipsoid133,3555,4],ColorData[97,1]],Style[NeighborhoodGraph[ellipsoid133,2634,4],ColorData[97,2]]}]
In[]:=
Out[]=
FindShortestPath[ellipsoid133,3555,2634]
In[]:=
{3555,3453,3454,3457,3458,3451,3341,3337,3336,3216,3214,3100,2988,3097,2984,2871,2754,2753,2634}
Out[]=
HighlightGraph[Graph[ellipsoid133],{Style[NeighborhoodGraph[ellipsoid133,3555,10],Directive[Red,Thick]],Style[NeighborhoodGraph[ellipsoid133,2634,10],Directive[Red,Thick]]}]
In[]:=
Out[]=
GraphPlot3D[HighlightGraph[Graph[ellipsoid113],{Style[NeighborhoodGraph[ellipsoid113,385,#],Directive[Red,Thick]],Style[NeighborhoodGraph[ellipsoid113,3041,#],Directive[Red,Thick]]}],ViewPoint{-1.4999984076361856`,2.900242374364533`,0.8880309381036673`},ViewVertical{-0.36545920420294903`,0.6610581921482263`,0.6553179660722467`},BaseStyle{Graphics3DBoxOptions{Method{"ShrinkWrap"True}}},ImageSize{130,Automatic}]&/@{7,12,17}
Out[]=
HighlightGraph[Graph[ellipsoid113],{Style[NeighborhoodGraph[ellipsoid113,385,15],Directive[Red,Thick]],Style[NeighborhoodGraph[ellipsoid113,3041,15],Directive[Red,Thick]]}]
In[]:=
Out[]=
With[{u=VolumeList[ellipsoid113,#]&/@{3555,2634}},ListLinePlot[Transpose[{Range[Length[#]]-1,#}]&/@u,MeshAll,FrameTrue,PlotRange{0,Max[u]+1}]]
In[]:=
Out[]=