Considered as a series reversion ( Cf. Mathworld, A&S ) of implicit equation $$E = \frac{1}{2}\Psi^2 + \sum_{n=3}^{\infty} f_n(\phi,\theta,\ldots)\;\Psi^n,$$ function A276738 determines the radius $\Psi$ of a hypersurface that limits in small $E$ to the shape of a perfect hypersphere, a circle, a sphere, etc...
Examples in 2,3 dimensions lend themselves well to depiction. Let's see the Henon Heiles Potential, and an octahedral Energy Surface.
Basic Functions
RExp[n_] := Expand[b Plus[R[0], Total[b^# R[#] & /@ Range[n]]]]
RCalc[n_] :=
With[{basis = Subtract[Tally[Join[Range[n + 2], #]][[All, 2]],
Table[1, {n + 2}]] & /@ IntegerPartitions[n + 2][[3 ;; -1]]},
Total@ReplaceAll[Times[-2, Multinomial @@ #, v[Total[#]],
Times @@ Power[RSet[# - 1] & /@ Range[n + 2], #]] & /@ basis,
{Q^2 -> 1, v[2] -> 1/4}]]
AbsoluteTiming[RSet[0] = 1; Set[RSet[#], Expand@RCalc[#]] & /@ Range[20];][[1]]
Surface[Nexp_, rep_] := RExp[Nexp] /. R -> RSet /.
v[n_] :> Function[{a},
Total[v[#, a - #] Q^# P^(a - #) & /@ Range[0, a]]][n] /.
rep /. {P -> Sin[\[Phi]], Q -> Cos[\[Phi]]};
HyperSurface[Nexp_, rep_] := RExp[Nexp] /. R -> RSet /. v[n_] :> Function[{a},
Total[Flatten@ Table[v[a - i - j, i, j] X^(a - i - j) Y^i Z^j, {i, 0, a}, {j, 0, a - i}]]][n] /.
rep /. {X -> Sin[\[Theta]] Cos[\[Phi]],
Y -> Sin[\[Theta]] Sin[\[Phi]], Z -> Cos[\[Theta]]};
Print Pictures
ViewV = {1, 2, 2};
TrigWords =
Flatten[Expand[ Surface[20, {v[2, 1] -> 3 \[Epsilon], v[0, 3] -> -\[Epsilon],
v[_, _] -> 0}]] /. Plus -> List /. Times -> List];
TrigLines20 =
With[{surf = Surface[20, {v[2, 1] -> 1/2, v[0, 3] -> -1/3/2, v[_, _] -> 0}]},
(surf /. b -> (#/10)) & /@ Range[5]];
g1 = Show[
Graphics[{Lighter@Gray, Text[#, RandomReal[{-1/2, 1}, 2]] & /@ TrigWords},
PlotRange -> {{-1/2, 1}, {-1/2, 1}}], Graphics[{Thick,
{Dashed, Line[Part[RotationMatrix[{{0, 0, 1}, ViewV}].#,
1 ;; 2] & /@ {{0, 0, -1/4}, {0, 0, 5/4}}]},
Thickness[.005], MapThread[
Line[Function[{a}, N[Part[RotationMatrix[{{0, 0, 1},
ViewV}].{#1 Cos[\[Phi]], #1 Sin[\[Phi]], #2/
10} /. {\[Phi] -> a}, 1 ;; 2]]] /@ (Range[0, 200]/
200 2 Pi)] &,
{TrigLines20, Range[5]}]}], ImageSize -> 800];
OctSurf6 = HyperSurface[
20, {v[4, 0, 0] -> \[Epsilon] 2/5, v[0, 4, 0] -> \[Epsilon] 2/5,
v[0, 0, 4] -> \[Epsilon] 2/5,
v[2, 2, 0] -> \[Epsilon] 6/5, v[2, 0, 2] -> \[Epsilon] 6/5,
v[0, 2, 2] -> \[Epsilon] 6/5,
v[_, _, _] -> 0} /. {\[Epsilon] -> -1/2}] /. b -> 6/10;
OctSurf3 = HyperSurface[
20, {v[4, 0, 0] -> \[Epsilon] 2/5, v[0, 4, 0] -> \[Epsilon] 2/5,
v[0, 0, 4] -> \[Epsilon] 2/5,
v[2, 2, 0] -> \[Epsilon] 6/5, v[2, 0, 2] -> \[Epsilon] 6/5,
v[0, 2, 2] -> \[Epsilon] 6/5,
v[_, _, _] -> 0} /. {\[Epsilon] -> -1/2}] /. b -> 3/10;
OctWords = Flatten[Expand[
HyperSurface[ 10, {v[4, 0, 0] -> \[Epsilon] 2, v[0, 4, 0] -> \[Epsilon] 2,
v[0, 0, 4] -> \[Epsilon] 2 ,
v[2, 2, 0] -> \[Epsilon] 6 , v[2, 0, 2] -> \[Epsilon] 6 ,
v[0, 2, 2] -> \[Epsilon] 6 , v[_, _, _] -> 0}]] /.
Plus -> List /. Times -> List];
g2 = Show[ Graphics[{Lighter@Gray,
Text[#, RandomReal[{-2, 2}, 2]] & /@ OctWords},
PlotRange -> 2 {{-1, 1}, {-1, 1}}],
Graphics[{ Thick, {Dashed,
Line[Part[RotationMatrix[{{0, 0, 1}, ViewV}].#, 1 ;; 2] & /@ {{0, 0, 2}, {0, 0, -2}}]},
Thickness[.005],
Line /@ Outer[N[Part[
RotationMatrix[{{0, 0, 1},
ViewV}].{Sin[\[Theta]] Cos[\[Phi]],
Sin[\[Theta]] Sin[\[Phi]],
Cos[\[Theta]]} OctSurf3 /. {\[Theta] -> #1, \[Phi] -> #2}, 1 ;; 2]] &,
Range[1, 9] Pi/10, Range[0, 100] 2 Pi/100, 1],
Line /@ Outer[N[Part[
RotationMatrix[{{0, 0, 1},
ViewV}].{Sin[\[Theta]] Cos[\[Phi]],
Sin[\[Theta]] Sin[\[Phi]],
Cos[\[Theta]]} OctSurf6 /. {\[Theta] -> #1, \[Phi] -> #2}, 1 ;; 2]] &,
Range[1, 9] Pi/10, Range[0, 200] 2 Pi/200, 1]
}], ImageSize -> 800];
Henon Heiles
Octahedral
What's more curious than these graphics? The new conjecture: that A276738 can be defined in terms of A028338.
