4
$\begingroup$

There is a butterfly curve $$r(\theta)=e^{\sin(\theta)}-2.4\cos(4\theta)+\sin \bigg( \frac{\theta}{12} \bigg)^5$$

PolarPlot[
  E^Sin[θ] - 2.4 Cos[4 θ] +Sin[θ/12]^5, {θ, 0, 24 Pi}, 
  PlotStyle -> {Thickness[0.004], Black}, PlotPoints -> 150]

enter image description here

How to animate it in 3D as a flying butterfly in Mathematica?

(Sorry for my English)

$\endgroup$
  • $\begingroup$ Please define mathematically what you meany by "flying butterfly" !! :) $\endgroup$ – Lotus Nov 20 '15 at 16:26
  • 3
    $\begingroup$ @Lotus Perhaps starting from the DNA sequence $\endgroup$ – Dr. belisarius Nov 20 '15 at 16:27
  • 1
    $\begingroup$ at least please write down that function in mathematica syntax $\endgroup$ – Dr. belisarius Nov 20 '15 at 16:29
  • $\begingroup$ @Lotus Something Like this $\endgroup$ – vito Nov 20 '15 at 16:32
12
$\begingroup$

Here's one where we treat the abdomen differently.

First, look at this as a 2D parametric curve:

r[t_] := E^Sin[t] - 24/10 Cos[4 t] + Sin[t/12]
x[t_] := r[t] Cos[t]
y[t_] := r[t] Sin[t]

We can locate the abdomen by carefully partitioning the roots of x[t].

vals = First[Cases[Plot[Evaluate[x[t, 0]], {t, 0, 20π}], Line[l_] :> l, ∞]];

xroots = t /. FindRoot[x[t], {t, ##}, WorkingPrecision -> 30] & @@@
 Select[Partition[vals, 2, 1], Sign[#[[1, 2]]] != Sign[#[[2, 2]]] &][[All, All, 1]];

We now will define the abdomen through inequalities of our parameter t.

AbdomenQ[r_] := With[{s = Chop@y[r]},
  s < 0 || (s > 1 && s > Chop@y[r - 1/100])
]

abdomenextrema = Select[xroots, AbdomenQ];

abdomen = N[Or @@ (#1 <= t <= #3 & @@@ 
  Cases[Partition[xroots, 3, 1], {_, Alternatives @@ abdomenextrema, _}])];

Now when we define our 3D parametric equation, we need to make sure our point rotates if and only if it's on a wing.

r[t_] := E^Sin[t] - 24/10 Cos[4 t] + Sin[t/12]
(x[t_, a_] := If[#, r[t] Cos[t], r[t] Cos[t] Cos[a]]) &[abdomen]
y[t_, a_] := r[t] Sin[t]
(z[t_, a_] := If[#, 0., Sign[a] Abs[r[t] Cos[t] Sin[a]]])&[abdomen]

We also keep the abdomen black and make the wings colorful.

cf = Function[{x, y, z, t}, 
  If[#,
    Black,
    #2[Sqrt[x^2 + y^2]/6]
  ]
]&[abdomen, ColorData["FruitPunchColors"]];

And now we place this in a nicely formatted Animate.

Animate[ParametricPlot3D[{x[t, a], y[t, a], z[t, a]}, {t, 0, 20π}, 
   PlotRange -> 8 {{-1, 1}, {-1, 1}, {-1, 1}}, 
   PlotPoints -> ControlActive[100, Automatic], 
   ColorFunction -> cf, 
   ColorFunctionScaling -> False, 
   Boxed -> False, 
   Axes -> False
  ], 
  {{a, 0.001}, -Pi/6, Pi/2}, 
  AnimationDirection -> ForwardBackward, 
  AnimationRate -> 1
]

enter image description here

$\endgroup$
7
$\begingroup$
r[t_] := E^Sin[t] - 24/10 Cos[4 t] + Sin[t/12]
x[t_, a_] := r[t] Cos@t Cos@a
y[t_, a_] := r[t] Sin@t
z[t_, a_] := x[t,a] Sign[x[t,a]] Sin@a

Manipulate[
 ParametricPlot3D[{x[t, a], y[t, a], z[t, a]}, {t, 0, 20 Pi}, 
  PlotRange -> 8 {{-1, 1}, {-1, 1}, {-1, 1}},
  ColorFunction -> Function[{x, y, z, u}, Hue@z]], {a, 0, Pi}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Neat! (+1) I think your definition of z should be z[t_, a_] := x[t, a] Sign[x[t, a]] Sin[a]. $\endgroup$ – Chip Hurst Nov 20 '15 at 17:19
  • $\begingroup$ @ChipHurst Yup. thanks. An old lurking snippet surviving :) $\endgroup$ – Dr. belisarius Nov 20 '15 at 17:26
  • 1
    $\begingroup$ Had some fun and made a few changes of my own: Animate[ParametricPlot3D[{x[t, a], y[t, a], z[t, a]}, {t, 0, 20 Pi}, PlotRange -> 8 {{-1, 1}, {-1, 1}, {-1, 1}}, ColorFunction -> Function[{x, y, z, u}, Hue@z], PlotPoints -> ControlActive[100, Automatic], Boxed -> False, Axes -> False], {a, .001, Pi/3}, AnimationDirection -> ForwardBackward, AnimationRate -> 1] $\endgroup$ – Chip Hurst Nov 20 '15 at 17:28
  • $\begingroup$ @ChipHurst Nice! I've been playing with a RandomWalk for positions and orientations, but my machine is too slow and it is boring :( $\endgroup$ – Dr. belisarius Nov 20 '15 at 17:39
3
$\begingroup$

(with apologies to Temple Fay)

Animate[ParametricPlot3D[{Cos[θ], Sin[θ], (1 + 2 Abs[t - 1]) (1 - Abs[t - 1])^2 - 1/2}
                         (Exp[Cos[θ]] - 2 Cos[4 θ] + Sin[θ/12]^5), {θ, 0, 24 π}, 
                         Axes -> None, Boxed -> False, PerformanceGoal -> "Quality", 
                         PlotRange -> {{-4, 4}, {-4, 4}, {-3, 3}}, 
                         PlotStyle -> Directive[AbsoluteThickness[1], ColorData[97, 2]]],
        {t, 0, 2 - 1/20, 1/20}]

just flaps about

$\endgroup$
  • 6
    $\begingroup$ Are you sure you've seen a butterfly flying in real life, J.M.? :) $\endgroup$ – Rahul Nov 20 '15 at 17:17
  • 1
    $\begingroup$ @Rahul Haven't you been at Chernobyl lately? $\endgroup$ – Dr. belisarius Nov 20 '15 at 17:37
  • $\begingroup$ @Rahul, hence the "apologies". :) $\endgroup$ – J. M. will be back soon Nov 20 '15 at 23:43

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.