# 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? – Nico A Jun 7 '18 at 15:08
• @TreFox It's a fairly well-known formula in higher math. – Michael E2 Jun 7 '18 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? – Nico A Jun 7 '18 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 '18 at 16:35

One possibility is to transform : 1) the Sphere to a cow 2) then the cow to a cube

cow = ExampleData[{"Geometry3D", "Cow"}];
Join[
Table[cow /. GraphicsComplex[array1_, rest___] :>
GraphicsComplex[(# (Norm[#]^-coeff)) & /@ array1,rest],{coeff,1,0,-.2}],
Table[cow /. GraphicsComplex[array1_, rest___] :>
GraphicsComplex[Map[(# (Norm[#]^-coeff)) & ,array1,{2}], rest],{coeff,0,1,.2}]
] //Multicolumn[#,Appearance-> "Horizontal"]& inspiration source

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}] 