12
$\begingroup$

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.

$\endgroup$
16
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ Can you explain how you got the formula? $\endgroup$ – TreFox Jun 7 '18 at 15:08
  • 4
    $\begingroup$ @TreFox It's a fairly well-known formula in higher math. $\endgroup$ – Michael E2 Jun 7 '18 at 15:24
13
$\begingroup$
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]
 ]

enter image description here

$\endgroup$
  • $\begingroup$ Can you provide a short explanation of how you put this code together? $\endgroup$ – TreFox Jun 7 '18 at 15:41
  • 2
    $\begingroup$ @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. $\endgroup$ – Kuba Jun 7 '18 at 16:35
10
$\begingroup$

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

enter image description here

inspiration source

$\endgroup$
2
$\begingroup$

Rectangle to circle:

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.