Path integral caustics

caustic.nb

length = Compile[{{x, _Real}, {y, _Real}, {\[Theta], _Real}}, 
   Sin[\[Theta]] + 
    Sqrt[(x + Sin[\[Theta]])^2 + (y - Cos[\[Theta]])^2]];
wavelength = 1/128;
phaseSum = Compile[
   {{a, _Integer}, {b, _Integer}, {n, _Integer}, {\[Lambda], _Real}, \
{x, _Real}, {y, _Real}},
   Module[{i = 0, t = 0. + 0. I},
    For[i = a, i <= b, ++i,
     t += \[Pi]/n Exp[I length[x, y, \[Pi]/n i]/\[Lambda]]];
    t]
   ];

gridSize = 128;
integrationSteps = 128;
grid = ParallelTable[
   Abs[phaseSum[0, integrationSteps, integrationSteps, wavelength, x, 
     y]], {x, -1, 0, 1/gridSize}, {y, -1, 1, 1/gridSize}];

densityPlot = ListDensityPlot[
   Transpose[grid],
   DataRange -> {{-1, 0}, {-1, 1}},
   Epilog -> {
     Thick, Black, Circle[{0, 0}, 1, {\[Pi]/2, 3 \[Pi]/2}]
     },
   RegionFunction -> Function[{x, y}, x^2 + y^2 <= 1],
   AspectRatio -> Automatic,
   ImageSize -> 600,
   ColorFunction -> "SunsetColors"];

spiralSteps = 1000;
generateSpiralPlot[{x_, y_}] := Module[
   {spiralSequence, spiralPoints},
   spiralSequence = 
    Accumulate[
     Table[\[Pi]/
       spiralSteps Exp[ 
        I length[x, y, \[Pi]/spiralSteps i]/wavelength], {i, 0, 
       spiralSteps}]];
   spiralPoints = ReIm[spiralSequence];
   ListLinePlot[
    spiralPoints,
    AspectRatio -> 1,
    PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}},
    PlotStyle -> {Thick, Blue},
    AxesLabel -> {"Re(z)", "Im(z)"},
    PlotLabel -> "Path of partial integrals",
    ImageSize -> 600,
    Epilog -> {
      Thick, Red, Arrow[{spiralPoints[[1]], spiralPoints[[-1]]}],
      Black, 
      Text[Style[Norm[spiralPoints[[1]] - spiralPoints[[-1]]], 
        12], {-0.9, 1.4}],
      Text[Style[{x, y}, 12], {-0.9, 1.3}],
      }
    ]
   ];

generateLengthPlot[{x_, y_}] := Plot[
   length[x, y, \[Theta]], {\[Theta], 0, \[Pi]},
   PlotStyle -> {Thick, Brown},
   AxesLabel -> {"\[Theta]", "lCompiled[x, y, \[Theta]]"},
   PlotRange -> {0, 2.5},
   PlotLabel -> "Path length as function of reflection point",
   AspectRatio -> Automatic,
   ImageSize -> 600,
   Epilog -> {
     PointSize[Medium],
     Blue, 
     Point[Table[{\[Theta], length[x, y, \[Theta]]}, {\[Theta], 
        0, \[Pi], \[Pi]/10}]],
     Black, 
     Table[Text[
       Style[i, 12], {i*\[Pi]/10, 
        length[x, y, i*\[Pi]/10]}, {0, -2}], {i, 0, 10}],
     Arrowheads[0.02],
     Table[
      Arrow[{
        {i*\[Pi]/10, length[x, y, i*\[Pi]/10] - 0.2},
        {i*\[Pi]/10, length[x, y, i*\[Pi]/10] - 0.2} + 
         0.1 {Cos[length[x, y, i*\[Pi]/10]/wavelength], 
           Sin[length[x, y, i*\[Pi]/10]/wavelength]}
        }],
      {i, 0, 10}
      ],
     Table[
      Circle[{i*\[Pi]/10, length[x, y, i*\[Pi]/10] - 0.2}, 0.1],
      {i, 0, 10}]
     }
   ];
clickedPoint = {-0.6, 0.3};

DynamicModule[{},
 Row[{
   EventHandler[
    Show[
     densityPlot,
     Epilog -> {
       Green, PointSize[Large], Point[Dynamic[clickedPoint]],
       Opacity[0.6], LightBlue,
       Table[
        Line[{{0, Cos[\[Theta]]}, {-Sin[\[Theta]], 
           Cos[\[Theta]]}}], {\[Theta], 0, \[Pi], \[Pi]/10}],
       Table[
        Line[{{-Sin[\[Theta]], Cos[\[Theta]]}, 
          Dynamic[clickedPoint]}], {\[Theta], 0, \[Pi], \[Pi]/10}],
       Opacity[1.0],
       Black, 
       Table[Text[
         Style[i, 12], {-1.02 Sin[i \[Pi]/10], 
          1.02 Cos[i \[Pi]/10]}, {0, 0}], {i, 0, 10}],
       Black, Text[Style[Dynamic[
          
          ListInterpolation[grid, {{-1, 0}, {-1, 1}}][
           clickedPoint[[1]], clickedPoint[[2]]]
          ], 12], {-0.85, 0.85}]
       },
     PlotLabel -> "Coffee cup"
     ],
    {
     "MouseClicked" :> (
       clickedPoint = MousePosition["Graphics"];
       If[Norm[clickedPoint] > 1, clickedPoint = {-0.6, 0.3}]
       ),
     "MouseDragged" :> (
       clickedPoint = MousePosition["Graphics"];
       If[Norm[clickedPoint] > 1, clickedPoint = {-0.6, 0.3}]
       )
     }
    ],
   Column[{
     Dynamic[generateSpiralPlot[clickedPoint]],
     Dynamic[generateLengthPlot[clickedPoint]]
     }]
   }]
 ]