13
$\begingroup$

I want to create the following animation with Mathematica.

Enter image description here

What is the simplest way to do so?

My first effort:

GenerateLines[a_, b_, r_, n_] :=
  Table[r {Cos[\[Theta]], Sin[\[Theta]], 0}, {\[Theta], a, b, (b - a)/
    n}];
basePts = GenerateLines[\[Pi]/6, 2 \[Pi] - \[Pi]/6, 3, 200];
peakPt = {{0, 0, 3}};
baseLine = Line@basePts;
slantedLines = Line /@ Tuples[{basePts, peakPt}];
Graphics3D[{baseLine, slantedLines}]

Enter image description here

$\endgroup$
2
  • $\begingroup$ The wireframe can be removed with a textured surface as shown in this site. $\endgroup$ May 17 '21 at 13:51
  • $\begingroup$ What have you tried? $\endgroup$
    – JimB
    May 17 '21 at 14:17
7
$\begingroup$

enter image description here

ClearAll[cone, radius]

radius[h_] = r /. First@
    Solve[{Pi r Sqrt[r^2 + h^2] (1 + h )/2 == Pi /2, h > 0}, r, Reals];
radius[0] = 1;

cone[h_] := ParametricPlot3D[{Cos[θ] (1 - z) radius[h], Sin[θ] (1 - z) radius[h], h z},
   {θ, 0, Pi + h Pi}, {z, 0, 1}, 
   PlotStyle -> None, 
   MeshFunctions -> {#4&},
   Boxed -> False, 
   PlotRange -> 1.5 {{-1, 1}, {-1, 1}, {0, 1}}, 
   BoundaryStyle -> GrayLevel[.2], 
   PerformanceGoal -> "Quality", 
   Axes -> False];

axes = Graphics3D[{Red, Arrowheads[Medium], 
    MapThread[{Arrow[{{0, 0, 0}, 1.4 #2}], Text[#, 1.5 #2]} &, 
     {{"X", "Y", "Z"}, IdentityMatrix[3]}]}];

Manipulate[Show[cone @ h, axes], {{h, 0, "height"}, 0, 1}]

enter image

Animation above produced using:

frames = Table[Show[cone @ h, axes], {h, 0, 1, .01}];

Export["animatecone.gif", frames, AnimationRepetitions -> ∞, DisplayAllSteps -> True]
$\endgroup$
2
  • 1
    $\begingroup$ @KimJongUn, please see the updated version. $\endgroup$
    – kglr
    May 18 '21 at 10:56
  • $\begingroup$ Thank you very much! $\endgroup$ May 18 '21 at 11:30
12
$\begingroup$

enter image description here

ClearAll[draw];

draw[deg_, segmentsNumber_Integer, z_] :=
 With[{singleSegment = 
    Polygon@{{0, 0, z}, {1, 0, 0}, {Cos[deg Degree], Sin[deg Degree], 0}}},

  NestList[
   GeometricTransformation[#, 
     RotationTransform[deg Degree, {0, 0, 1}]] &, singleSegment, 
   segmentsNumber]]

Manipulate[
 Graphics3D[{Red, Arrow[{{0, 0, 0}, {1.5, 0, 0}}], 
   Arrow[{{0, 0, 0}, {0, 1.5, 0}}], Arrow[{{0, 0, 0}, {0, 0, 1.5}}], 
   Text["x", {1.6, 0, 0}], Text["y", {0, 1.6, 0}], 
   Text["z", {0, 0, 1.6}], Transparent, draw[10 + i*8, 19, i]}, 
  Boxed -> False, PlotRange -> {{-2, 2}, {-2, 2}, {-2, 2}}], {i, 0, 1}]

Update

For removing axes moves, use PlotRange in Graphics3D:

PlotRange -> {{-2, 2}, {-2, 2}, {-2, 2}}
$\endgroup$
3
  • $\begingroup$ Excellent! Let me wait for a couple of hours or maybe days. $\endgroup$ May 17 '21 at 17:06
  • $\begingroup$ @KimJongUn I used Snagit to capture which also have a built-in gif converter. $\endgroup$
    – Ben Izd
    May 17 '21 at 17:34
  • $\begingroup$ Thank you very much! $\endgroup$ May 17 '21 at 17:35
8
$\begingroup$
 Animate[
 r = Sqrt[1 - h^2];
 phi = Sqrt[2] Pi /r;
 pts = Table[r {Cos[p], Sin[p], 0}, {p, 0, phi, phi/10}];
 ptsc = Table[r {Cos[p], Sin[p], 0}, {p, 0, phi, phi/100}];
 Graphics3D[{Line[ptsc], Line[{#, {0, 0, h}}] & /@ pts, Red, 
   Arrow[{{0, 0, 0}, {1, 0, 0}}], Arrow[{{0, 0, 0}, {0, 1, 0}}], 
   Arrow[{{0, 0, 0}, {0, 0, 1}}], Text["X", {1.1, 0, 0}], 
   Text["Y", {0, 1.1, 0}], Text["Z", {0, 0, 1.1}]}, Boxed -> False, 
  PlotRange -> {{-1, 1}, {-1, 1}, {0, 1}}]
 , {h, 0, 1/Sqrt[2]}, TrackedSymbols -> h]

![enter image description here

$\endgroup$
0
5
$\begingroup$

Just a start:

Manipulate[
 Graphics3D[Cone[{{0, 0, h}, {0, 0, 1}}]],
 {h, 0, 0.9}
 ]

enter image description here enter image description here

And a bit more...

Manipulate[
 Graphics3D[{
   {Opacity[0.5], Cone[{{0, 0, h}, {0, 0, 1}}]},
   Line[{{1.25, 0, 0}, {0, 0, 0}}],
   Line[{{0, 1.25, 0}, {0, 0, 0}}],
   Line[{{0, 0, 1.25}, {0, 0, 0}}]
   },
  Boxed -> False],
 {h, 0, 0.9}
 ]

enter image description here

$\endgroup$
1
  • $\begingroup$ From a sector to a cone rather than from a circle to a cone. :-) $\endgroup$ May 17 '21 at 16:02
5
$\begingroup$

At first we shrinking the boundary of sector to circle, keeping the arc length. That is l*α==R*θ

α = 0.8*2 π;
l = 4;
Manipulate[
 ParametricPlot3D[R*{Cos[s], Sin[s], 0} /.R->(l*α)/θ, {s, 0, θ}, PlotRange -> 4, 
  PerformanceGoal -> "Quality"], {θ, α, 2 π}]

enter image description here

Then we draw line from the shrinking curve to the vertex of the cone {0,0,Sqrt[l^2 - R^2]} so we keep the length of generatrix say l.

α = 0.8*2 π;
l = 4;
Manipulate[
 ParametricPlot3D[(1 - t)*(R*{Cos[s], Sin[s], 0}) + 
    t*{0, 0, Sqrt[l^2 - R^2]} /. R -> (l*α)/θ, {s, 
   0, θ}, {t, 0, 1}, PlotRange -> 4, 
  PerformanceGoal -> "Quality", MeshFunctions -> {#4 &}, Mesh -> 20, 
  Boxed -> False], {θ, α, 2 π, .2}]

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.