RandomGeodesic[gx_,n_Integer:1]:=With[{g=IndexGraph[gx,EdgeStyleLightGray,VertexStyleLightGray]},With[{spf=FindShortestPath[g,All,All],vl=VertexList[g]},HighlightGraph[g,Table[Style[PathGraph[spf[RandomChoice[vl],RandomChoice[vl]]],Thick,RandomColor[]],n]]]]
In[]:=
plot=Plot3D[Exp[-(x^2+y^2)],{x,-4,4},{y,-4,4},PlotRangeAll,BoxRatios{1,1,1/4}]
In[]:=
Out[]=
gplot=GraphicsMetricGraph[plot];
In[]:=
GraphPlot3D[RandomGeodesic[gplot,10]]
In[]:=
Out[]=
? Measure curvature at various points....
GraphCenter[gplot]
In[]:=
{{0,109},{0,111},{0,1749},{0,2101},{0,3616}}
Out[]=
HighlightGraph[gplot,%375,VertexSize100,VertexStyleRed]
In[]:=
Out[]=
GraphPlot3D[%]
In[]:=
Out[]=
HypergraphDimensionEstimateList[List@@@EdgeList[IndexGraph[gplot]]]
In[]:=
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
hgx=List@@@EdgeList[IndexGraph[gplot]];
In[]:=
Take[hgx,3]
In[]:=
{{1,2},{1,3},{1,6030}}
Out[]=
HypergraphNeighborhoodVolumes[hgx,{200}]
In[]:=
200{1,6,17,36,65,99,143,192,252,316,389,473,567,667,773,884,1012,1141,1277,1435,1594,1770,1961,2148,2323,2489,2662,2830,3000,3184,3377,3576,3776,3972,4186,4397,4590,4762,4921,5066,5202,5324,5438,5549,5640,5705,5766,5824,5876,5922,5963,5991,6018,6038,6052,6067,6083,6086}
Out[]=
LogDifferences[First[Values[HypergraphNeighborhoodVolumes[hgx,{200}]]]]//N
In[]:=
{2.58496,2.56854,2.60811,2.64793,2.30764,2.38549,2.2066,2.30877,2.14799,2.18064,2.24702,2.26459,2.19181,2.13774,2.07904,2.23056,2.09902,2.08275,2.2742,2.15375,2.25135,2.30531,2.14012,1.91863,1.75982,1.7805,1.68279,1.66239,1.75585,1.79475,1.80345,1.76852,1.69512,1.81029,1.74566,1.56785,1.37946,1.26442,1.14701,1.07286,0.961995,0.900382,0.878939,0.723821,0.52136,0.494537,0.475396,0.431099,0.385986,0.348412,0.241251,0.236066,0.1775,0.126217,0.137384,0.148803,0.02835}
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
VertexCount[hgx]
In[]:=
6086
Out[]=
spts=HypergraphNeighborhoodGraph[hgx,{2000},2]
In[]:=
Out[]=
MeanAround/@Transpose[Values[HypergraphNeighborhoodVolumes[hgx,Union[Flatten[spts]],Automatic]]]
In[]:=
Out[]=
ListLinePlot[LogDifferences[%]]
In[]:=
Out[]=
ListLinePlot[LogDifferences[MeanAround/@Transpose[Values[HypergraphNeighborhoodVolumes[hgx,Union[Flatten[HypergraphNeighborhoodGraph[hgx,{2000},4]]],Automatic]]]]]
In[]:=
Out[]=
ListLinePlot[LogDifferences[MeanAround/@Transpose[Values[HypergraphNeighborhoodVolumes[hgx,Union[Flatten[HypergraphNeighborhoodGraph[hgx,{1000},4]]],Automatic]]]]]
In[]:=
Out[]=
ListLinePlot[LogDifferences[MeanAround/@Transpose[Values[HypergraphNeighborhoodVolumes[hgx,Union[Flatten[HypergraphNeighborhoodGraph[hgx,{4000},4]]],Automatic]]]]]
In[]:=
Out[]=

Flatter case

plot=Plot3D[Exp[-(x^2+y^2)],{x,-4,4},{y,-4,4},PlotRangeAll,BoxRatios{1,1,1/20}]
In[]:=
Out[]=
gplotf=GraphicsMetricGraph[plot];
In[]:=
GraphPlot3D[gplotf,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic]
In[]:=
Out[]=
ListLinePlot[HypergraphDimensionEstimateList[List@@@EdgeList[IndexGraph[gplotf]]]]
In[]:=
Out[]=
hgxf=List@@@EdgeList[IndexGraph[gplotf]];
In[]:=
ListLinePlot[LogDifferences[MeanAround/@Transpose[Values[HypergraphNeighborhoodVolumes[hgxf,Union[Flatten[HypergraphNeighborhoodGraph[hgxf,{1000},4]]],Automatic]]]]]
In[]:=
Out[]=
plot=Plot3D[Exp[-((x+1)^2+y^2)]+Exp[-((x-1)^2+y^2)],{x,-4,4},{y,-4,4},PlotRangeAll,BoxRatios{1,1,1/20}]
In[]:=
Out[]=
GraphicsMetricGraph[plot];
In[]:=
GraphPlot3D[%,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesAutomatic]
In[]:=
Out[]=

Metrics

InverseMetric[g_]:=Simplify[Inverse[g]]
In[]:=
ChristoffelSymbol[g_,xx_]:=Block[{n,ig,res},n=4;ig=InverseMetric[g];​​res=Table[(1/2)*Sum[ig[[i,s]]*(-D[g[[j,k]],xx[[s]]]+D[g[[j,s]],xx[[k]]]+D[g[[s,k]],xx[[j]]]),{s,1,n}],{i,1,n},{j,1,n},{k,1,n}];​​Simplify[res]]
In[]:=
RiemannTensor[g_,xx_]:=Block[{n,Chr,res},n=4;Chr=ChristoffelSymbol[g,xx];​​res=Table[D[Chr[[i,k,m]],xx[[l]]]-D[Chr[[i,k,l]],xx[[m]]]+Sum[Chr[[i,s,l]]*Chr[[s,k,m]],{s,1,n}]-Sum[Chr[[i,s,m]]*Chr[[s,k,l]],{s,1,n}],{i,1,n},{k,1,n},{l,1,n},{m,1,n}];​​Simplify[res]]
In[]:=
RicciTensor[g_,xx_]:=Block[{Rie,res,n},n=4;Rie=RiemannTensor[g,xx];​​res=Table[Sum[Rie[[s,i,s,j]],{s,1,n}],{i,1,n},{j,1,n}];​​Simplify[res]]
In[]:=
RicciScalar[g_,xx_]:=Block[{Ricc,ig,res,n},n=4;Ricc=RicciTensor[g,xx];ig=InverseMetric[g];​​res=Sum[ig[[s,i]]Ricc[[s,i]],{s,1,n},{i,1,n}];​​Simplify[res]]
In[]:=
RicciScalar[{{-E^(2ν[x]),0,0,0},{0,E^(2λ[x]),0,0},{0,0,x^2,0},{0,0,0,x^2Sin[θ]^2}},{t,x,θ,ϕ}]
In[]:=
2
-2λ[x]

-1+
2λ[x]

-2x
′
ν
[x]-
2
x
2
′
ν
[x]
+x
′
λ
[x](2+x
′
ν
[x])-
2
x
′′
ν
[x]
2
x
Out[]=
RicciTensor[{{-E^(2ν[x]),0,0,0},{0,E^(2λ[x]),0,0},{0,0,x^2,0},{0,0,0,x^2Sin[θ]^2}},{t,x,θ,ϕ}]
In[]:=
Out[]=