Transform sphere into a cube

Question

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.

score 21 · Accepted Answer · answered Jun 07 '18 at 15:06

21

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

answered Jun 07 '18 at 15:06

Niki Estner

36,101
3
92
152

Can you explain how you got the formula? – Nico A Jun 07 '18 at 15:08
4

@TreFox It's a fairly well-known formula in higher math. – Michael E2 Jun 07 '18 at 15:24

score 17 · Answer 2 · answered Jun 07 '18 at 15:31

17

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

answered Jun 07 '18 at 15:31

Kuba

136,707
13
279
740

Can you provide a short explanation of how you put this code together? – Nico A Jun 07 '18 at 15:41
2

@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 07 '18 at 16:35

chyanog · Answer 3 · 2022-04-22T17:01:46.547

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

Previous answer:

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

@BlackMild Thanks for your appreciation. – chyanog May 04 '22 at 11:40 — chyanog, May 04 '22 at 11:40

Transform sphere into a cube

3 Answers3

Linked