Animating a Potential Function (eigenfunctions of Laplace's equation)

Question

I have written the following DynamicModule. The idea is that you can change the boundary, calculate the eigenfunctions and then animate them. Here is the code:

DynamicModule[{pts, bdr = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}, vals, 
  funs, n = 2, ar = False},
 pts = Table[{6, 6} + 3 {Cos[θ], Sin[θ]}, {θ, 0, 
    2 π - 2 π/10, 2 π/10}];
 bdr = BoundaryDiscretizeGraphics[Line[Join[pts, {pts[[1]]}]]];
 {vals, funs} = 
  NDEigensystem[{-Laplacian[u[x, y], {x, y}]}, 
   u[x, y], {x, y} ∈ bdr, 6];
 ar = False;
 Column[{
   Row[{
     Button["Calculate",
      bdr = BoundaryDiscretizeGraphics[Line[Join[pts, {pts[[1]]}]]];
      {vals, funs} = 
       NDEigensystem[{-Laplacian[u[x, y], {x, y}]}, 
        u[x, y], {x, y} ∈ bdr, 6]
      , ImageSize -> 1 72],
     Spacer[18],
     "Mode Number = ",
     Slider[Dynamic[n], {2, 6, 1}, Appearance -> "Labeled"],
     Spacer[18],
     Button["Toggle Animate", If[ar, ar = False, ar = True], 
      ImageSize -> 2 72]
     }],
   LocatorPane[Dynamic[pts],
    Dynamic@Animate[Show[
       Graphics[{Line[Join[pts, {pts[[1]]}]]}, Frame -> True, 
        PlotRange -> {{0, 12}, {0, 12}}, ImageSize -> 10 72],
       ContourPlot[funs[[n]] Cos[t], {x, y} ∈ bdr, 
        Axes -> None, Frame -> None, AspectRatio -> Automatic, 
        ColorFunction -> 
         Function[f, {Opacity[0.75], ColorData["TemperatureMap"][f]}]]
       ],
      {t, 0, 2 π}, AnimationRunning -> ar]
    ]
   }]
 ]

This is mostly working. The problem is you cannot use the animation slider If you set up a boundary, calculate and then try and use it you get this

The locator has jumped to the animation slider controls. As a workaround I added the Toggle Animate button. This seems to work sometimes but not always. I am not clear what is wrong. How can I animate when requested.

The version is 11.2.0 for Microsoft Windows (64-bit) (September 11, 2017)

Thanks for any help.

Edit

A minor point raised by Kuba. I am simulating an acoustic cavity. For this case the potential function is equivalent to the acoustic pressure while the gradient is equivalent to the acoustic particle velocity. Thus for the boundary conditions I have no Dirichlet boundary condition and use the fact that Mathematica assumes zero Neumann boundary conditions to make the acoustic velocity zero at the boundaries. To have, for example, a membrane simulation add the Dirichlet condition.

Answer 1

The fix is to move Animate outside of LocatorPane, but let's go couple of steps further:

• I turned Eigenvalues procedure into a function calculate[] to prevent code duplication

• The second argument of Dynamic in Slider and LocatorPane is used to neatly invoke calculate[]

• 'Nested Dynamic' and 'combining dynamic plots without Show ' tricks are used, read more in 148412

• Plot3D is added with a neat ScalingTransform trick which spares Plot3D recalculation if only t changes.

And a variation with DirichletCondition[u[x, y] == 0, True]:

Deploy@DynamicModule[{pts, bdr = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}, 
   vals, funs, n = 2, ar = False, calculate},

  Animate[
   Column[{
     Row[{
       "Mode Number = ", 
       Slider[Dynamic[n, {Automatic, calculate[] &}], {2, 6, 1}, 
        Appearance -> "Labeled"], Spacer[18],
       Button["Toggle Animate", If[ar, ar = False, ar = True], 
        ImageSize -> 2 72]
       }],
     Grid[{{
        LocatorPane[Dynamic[pts, {Automatic, calculate[] &}],
         Graphics[{

           {Dynamic[
             First@ContourPlot[
               funs[[n]] Cos[t] , {x, y} \[Element] bdr, Axes -> None,
                Frame -> None, AspectRatio -> Automatic, 
               ColorFunction -> 
                Function[f, {ColorData["TemperatureMap"][f]}],
               PlotPoints -> ControlActive[20, 50]]
             , TrackedSymbols :> {bdr, n, t}]
            },
           {FaceForm@None, EdgeForm@Thick, Polygon@Dynamic@pts}
           }, Frame -> True, PlotRange -> {{0, 12}, {0, 12}}, 
          ImageSize -> 5 72
          ]
         ]
        ,
        Dynamic[
         Graphics3D[
          {GeometricTransformation[

            First@Plot3D[funs[[n]], {x, y} \[Element] bdr, 
              Axes -> None, AspectRatio -> Automatic, PlotRange -> All
              ],
            ScalingTransform[{1, 1, Dynamic@Cos[t]}, {6, 6, 0}]
            ]
           }, PlotRange -> {{0, 12}, {0, 12}, {-1, 1}}, 
          BoxRatios -> {1, 1, .5}, ImageSize -> 500, 
          ViewPoint -> {-6, -20, 20}]]
        }}]
     }]
   , {t, 0, 2 \[Pi]}, AnimationRunning -> ar]
  ,
  Initialization :> (
    pts = 
     Table[{6, 6} + 3 {Cos[\[Theta]], Sin[\[Theta]]}, {\[Theta], 0, 
       2 \[Pi] - 2 \[Pi]/10, 2 \[Pi]/10}];
    calculate[] := (
      bdr = Polygon@pts;
      {vals, funs} = 
       NDEigensystem[{-Laplacian[u[x, y], {x, y}]}, 
        u[x, y], {x, y} \[Element] bdr, 6];


      );
    calculate[];
    )
  ]