Transform sphere into a cube

I'm trying to get into animation using Mathematica, and I want to create a simple animation where a sphere in a black space gets "morphed" into a cube. I know how to generate a cube and how to generate a sphere using Graphics3D:

Graphics3D[Sphere[]]
Graphics3D[Cuboid[]]


But I'm not sure how to generate a "movie" of one morphing into another.

Slow, but it works:

Animate[
RegionPlot3D[
With[{u = Sin[t]^2*10 + 2},
Abs[x]^u + Abs[y]^u + Abs[z]^u < 1], {x, -1, 1}, {y, -1,
1}, {z, -1, 1}, PerformanceGoal -> "Quality"], {t, 0, \[Pi]}]


• Can you explain how you got the formula? Jun 7, 2018 at 15:08
• @TreFox It's a fairly well-known formula in higher math. Jun 7, 2018 at 15:24
reg = DiscretizeRegion[Cuboid[{-1, -1, -1}, {1, 1, 1}],
MaxCellMeasure -> .01];
DynamicModule[{pts = MeshCoordinates[reg],
norms = Norm /@ MeshCoordinates[reg]}
, Animate[
Graphics3D@GraphicsComplex[
Dynamic[ pts  /(1 - t + t  norms) ],
{EdgeForm@None, MeshCells[reg, {2}]}
]
, {t, 0, 1}, AnimationRate -> 1,
AnimationDirection -> ForwardBackward]
]


• Can you provide a short explanation of how you put this code together? Jun 7, 2018 at 15:41
• @TreFox cuboid -> cuboid's mesh -> coordinates + polygons. Then, normalized coordinates of this cuboid are on a sphere so I just scale the norm between 1 and original one. I'm encouraging your to take this code apart and experiment, see what's inside.
– Kuba
Jun 7, 2018 at 16:35

Updated

plt=ParametricPlot3D[{Cos[ϕ]*Sin[θ], Sin[θ]*Sin[ϕ], Cos[θ]}, {θ, 0, Pi}, {ϕ, 0, 2*Pi},
PlotPoints -> 200, PlotRange -> 1, ImageSize -> 400,
Axes -> False, ColorFunction -> (Hue[#5, 1, 1, 0.75] &)];

cf = Compile[{{v, _Real, 1}, t}, (1 - t) v + t v/(Sqrt[2] Max[Abs[v]]),
RuntimeAttributes -> {Listable}];

Manipulate[plt /. GraphicsComplex[pts_, rest___] :>
GraphicsComplex[cf[pts, t], rest], {t, 0., 1}]


Rectangle to circle:

Manipulate[
ContourPlot[(1 - t) (Max@Abs@{x, y} - 1) + t (x^2 + y^2 - 1) == 0,
{x, -1.2, 1.2}, {y, -1.2, 1.2}, PlotPoints -> 80], {t, 0, 1}]


Cube to sphere:

frames = ParallelTable[
ContourPlot3D[(1 - t) (Max[Abs@{x, y, z}] - 1) + t (x^2 + y^2 + z^2 - 1) == 0,
{x, -#, #}, {y, -#, #}, {z, -#, #},
PlotPoints -> 10, Mesh -> None, Boxed -> False, Axes -> False] &@1.1,
{t, 0, 1, 1/50.}]; // AbsoluteTiming

Animate[frames[[i]], {i, 1, Length[frames], 1}]


• what a beautiful answer! May 2, 2022 at 3:17
• @BlackMild Thanks for your appreciation. May 4, 2022 at 11:40