Transform sphere into a cube
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]}]
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]
]
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