1
$\begingroup$

I have been creating animations in two different ways: 1)using Animate 2)using Table to create a list of plots at different times.

1)Let's start with Animate. The function I want to animate is the following

ψTimeDep[x_, r_, ϕ_, α_, t_] := 
 1/Sqrt[Cosh[r]]*((m ω)/(π h))^(1/4) *
  Exp[-((m ω)/(2 h))*x^2 - 
    Conjugate[α]/
     2 (α + Conjugate[α] E^(I ϕ)*Tanh[r]) - 
    I*ω*t - (m ω)/h E^(I ϕ) Tanh[r]*
     E^(-2*I*ω*t)*
     x^2 + (α + Conjugate[α] E^(I ϕ) Tanh[r])*
     E^(-I*ω*t)*Sqrt[(2 m ω)/h] x - 
    1/2*(E^(-I*ω*
         t)*(α + Conjugate[α] E^(I ϕ) Tanh[r]) - 
       E^(-2*I*ω*t)*Sqrt[(2 m ω)/h] E^(I ϕ)
         Tanh[r] x)^2 - 
    Log[1 - E^(I ϕ) Tanh[r]*E^(-2*I*ω*t)]/
    2 - ((E^(I ϕ) Tanh[r]*E^(-2*I*ω*t))/(
      1 - E^(I ϕ) Tanh[r]*E^(-2*I*ω*t))) *1/
     2*(E^(-I*ω*
         t)*(α + Conjugate[α] E^(I ϕ) Tanh[r]) - 
       E^(-2*I*ω*t)*Sqrt[(2 m ω)/h] E^(I ϕ)
         Tanh[r] x)^2]

It is a pretty complicated function, but the thing I'm interested in plotting for now is ψTimeDep[x,-3,0,0,t]. When I run

animation1 = 
 Animate[Plot[Re[ψTimeDep[x, -3, 0, 0, t]], {x, -100, 100}, 
   PlotRange -> {-0.3, 0.3}, PlotStyle -> {Thickness[0.0042], Blue}, 
   Axes -> {False, False}, 
   FrameStyle -> Directive[Black, Thick], FrameTicks -> LinTicks, 
   FrameTicksStyle -> Directive[Thick, FontSize -> 20], Frame -> True,
    PlotPoints -> 100, 
   PlotLegends -> 
    Placed[Framed[LineLegend[{Automatic}, {"r=0,α=0"}]], 
     ImageScaled[{0.8, 0.9}]]], {t, 0, 6, 0.01}, 
  AnimationRate -> 0.15, AnimationRunning -> False]

it animates the plot quickly. However, the problem is that when I try to export it as a .swf file I cannot play it on my computer (I have already asked this in another forum), but more importantly Flash Player will be disabled on December 31st, 2020, so exporting to .swf file is not a good long-term solution.

2)Next, I can create a list of plots at different times using Table, as mentioned here, and export them as a gif. Following the advice of this post I created the following code

animation3 = 
  Table[Plot[Re[ψTimeDep[x, -3, 0, 0, t]], {x, -100, 100}, 
    PlotRange -> {-0.3, 0.3}, PlotStyle -> {Thickness[0.0042], Blue}, 
    Axes -> {False, False},
     Frame -> True, PlotPoints -> 100, 
    PlotLegends -> 
     Placed[Framed[LineLegend[{Automatic}, {"r=-3,α=0"}]], 
      ImageScaled[{0.8, 0.9}]]], {t, 0, 8, 0.1}];

This solution works, but it takes a lot of time to run this piece of code (my computer is 6 years old). I had to remove the FrameTicks, FrameStyle, FrameTicksStyle options to make it run in a considerable amount of time.

I have been using option 2), but I would really like to reduce the amount of time it takes to create my animation. Does anybody know any other way I can create an animation and exporting it in the least possible amount of time?

EDIT: I set ω=1, m=1 and h=1

$\endgroup$

1 Answer 1

1
$\begingroup$

Replace := by = and define a new f.

Clear["`*"];
f[x_, t_] = 
 1/Sqrt[Cosh[r]]*((m ω)/(π h))^(1/4)*
    Exp[-((m ω)/(2 h))*x^2 - 
      Conjugate[α]/
        2 (α + Conjugate[α] E^(I ϕ)*Tanh[r]) - 
      I*ω*t - (m ω)/h E^(I ϕ) Tanh[r]*
       E^(-2*I*ω*t)*
       x^2 + (α + Conjugate[α] E^(I ϕ) Tanh[r])*
       E^(-I*ω*t)*Sqrt[(2 m ω)/h] x - 
      1/2*(E^(-I*ω*t)*(α + 
             Conjugate[α] E^(I ϕ) Tanh[r]) - 
          E^(-2*I*ω*t)*
           Sqrt[(2 m ω)/h] E^(I ϕ) Tanh[r] x)^2 - 
      Log[1 - E^(I ϕ) Tanh[r]*E^(-2*I*ω*t)]/
       2 - ((E^(I ϕ) Tanh[r]*E^(-2*I*ω*t))/(1 - 
           E^(I ϕ) Tanh[r]*E^(-2*I*ω*t)))*1/
        2*(E^(-I*ω*t)*(α + 
             Conjugate[α] E^(I ϕ) Tanh[r]) - 
          E^(-2*I*ω*t)*
           Sqrt[(2 m ω)/h] E^(I ϕ) Tanh[
            r] x)^2] /. {r -> -3, ϕ -> 0, α -> 0, m -> 1, 
    h -> 1, ω -> 1} // Re
animation1 = 
 Animate[Plot[f[x, t], {x, -100, 100}, PlotRange -> {-0.3, 0.3}, 
   PlotStyle -> {Thickness[0.0042], Blue}, Axes -> {False, False}, 
   FrameStyle -> Directive[Black, Thick], 
   FrameTicksStyle -> Directive[Thick, FontSize -> 20], Frame -> True,
    PlotPoints -> 100, 
   PlotLegends -> 
    Placed[Framed[LineLegend[{Automatic}, {"r=0,α=0"}]], 
     ImageScaled[{0.8, 0.9}]]], {t, 0, 6, 0.01}, 
  AnimationRate -> 0.15, AnimationRunning -> False]
(*
animation3 = 
 Table[Plot[f[x,t], {x, -100, 100}, PlotRange -> {-0.3, 0.3}, 
   PlotStyle -> {Thickness[0.0042], Blue}, Axes -> {False, False}, 
   Frame -> True, PlotPoints -> 100, 
   PlotLegends -> 
    Placed[Framed[LineLegend[{Automatic}, {"r=-3,α=0"}]], 
     ImageScaled[{0.8, 0.9}]]], {t, 0, 8, 0.1}] *)
$\endgroup$
2
  • $\begingroup$ I just edited my question $\endgroup$
    – eemg
    Oct 16, 2020 at 4:04
  • $\begingroup$ It takes less time, but still it is very slow compared to Animate. Is this the best it can do? $\endgroup$
    – eemg
    Oct 16, 2020 at 15:24

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.