13
$\begingroup$

I want to combine Manipulate with ManbelbrotSetPlot just to get Mathematica to give me a quick and dirty Mandelbrot Zoomer. I want to be able to single/double click on a section, and have it zoom in on that section. All I've been able to get is an adjustable viewing window, but that's really not satisfactory. I imagine a Locator might do the trick, but I'm unsure how to get it to work. How might I accomplish this?

$\endgroup$
5
  • 2
    $\begingroup$ Interesting question, sadly, with no effort shown on your side it will be hard to get enough attention to it $\endgroup$
    – Sektor
    Jun 2, 2015 at 18:08
  • 2
    $\begingroup$ What do you suggest I try? $\endgroup$ Jun 2, 2015 at 18:09
  • 1
    $\begingroup$ Here is how to zoom in on a Koch curve, it can probably be adapted. There are several other questions about zooming as well that you might take a look at. $\endgroup$
    – C. E.
    Jun 2, 2015 at 18:23
  • $\begingroup$ @Pickett That's really interesting. I'm going to have to spend quite some time to figure out how it works. $\endgroup$ Jun 2, 2015 at 18:39
  • $\begingroup$ There is also this. $\endgroup$
    – wxffles
    Jun 2, 2015 at 23:17

3 Answers 3

10
$\begingroup$

Another way to zoom around is using Manipulate. Here we use a 2D slider to set the position and a regular slider to set the zoom. It scrolls more evenly if you hold down the option key as you move the sliders.

Manipulate[b = -Log[a]; 
 MandelbrotSetPlot[{u[[1]] + u[[2]] I - b - b I, u[[1]] + u[[2]] I + b + b I}, 
  MaxIterations -> 200], {{a, 0.50, "zoom"}, 0, 0.999}, {u, {-2, -1.3}, {0.6, 1.3}}]

enter image description here

$\endgroup$
21
$\begingroup$

Quick&Dirty:

pt = {0, 0};    
full = MandelbrotSetPlot[];
r = 0.2;

Column[{
  Row[{"Zoom: ", Slider[Dynamic[r], {0.01, 1}]}],
  Row[
   {
    LocatorPane[Dynamic[pt], 
     Dynamic[Show[full, 
       Graphics[{EdgeForm[Red], Transparent, 
         Rectangle[pt + r, pt - r]}], ImageSize -> Scaled[.45]]]],
    Dynamic[
     MandelbrotSetPlot[{pt + r, pt - r}.{1, I}, 
      ImageSize -> Scaled[.45]], TrackedSymbols :> {pt, r}]
    }]
  }]

enter image description here

$\endgroup$
3
  • $\begingroup$ This looks really nice, unfortunately it is aborting in my copy of Mathematica 10 with the error Set::write: "Tag Span in {-0.7,0.4};;full is Protected." $\endgroup$ Jun 2, 2015 at 19:36
  • $\begingroup$ Ok, now it's working. $\endgroup$ Jun 2, 2015 at 19:37
  • $\begingroup$ This is wonderful. Thank you so much. $\endgroup$ Jun 2, 2015 at 19:39
13
$\begingroup$

Here is a less quick and dirty version that includes a few more features. To zoom in, you simply click and drag to select a rectangle. Generally, you've got to hit the Generate button to produce the next picture. If you just click on the image, then a picture of the corresponding Julia set will be printed to the notebook, together with the command to generate it.

enter image description here

The code is as follows:

(* Adjust as desired *)
imageSize = 800;
defaultBailout = 100;
bailoutOptions = {50, 100, 200, 500, 1000, 2000, 5000};
defaultResolution = 400;
resolutionOptions = {400, 800, 1600};
defaultColorScheme = "StarryNightColors"
colorSchemes = ColorData["Gradients"];

(* Initial settings *)
pt = {0, 0}; pt1 = {-2, -1.3}; pt2 = {0.6, 1.3};
plotRange = {{-2, 0.6}, {-1.3, 1.3}};

Manipulate[
 DynamicModule[{},
  toShow = Show[{mandelbrotPic, Graphics[{
       Thickness[0.005], Opacity[0.5], Gray,
       Dynamic@Line[{pt1, {pt1[[1]], pt2[[2]]}, pt2,
          {pt2[[1]], pt1[[2]]}, pt1}]
       }]}, FrameTicks -> False, PlotRange -> Dynamic@plotRange];
  Deploy[If[showBounds === True,
    Labeled[
     EventHandler[toShow,
      {"MouseClicked" :> With[{cmd = 
       Hold[JuliaSetPlot[#]]&[{1, I}.MousePosition["Graphics"]]},
       CellPrint[{ExpressionCell[Defer @@ cmd, "Input"], 
                  ExpressionCell[ReleaseHold[cmd], "Output"]}]],
       "MouseDown" :> (pt2 = pt1 = pt = MousePosition["Graphics"]),
       "MouseDragged" :> (pt2 = pt = MousePosition["Graphics"]),
       "MouseUp" :> (pt2 = pt = MousePosition["Graphics"])}],
     {pt1, pt2}],
    EventHandler[toShow,
     {"MouseClicked" :> With[{cmd = 
       Hold[JuliaSetPlot[#]]&[{1, I}.MousePosition["Graphics"]]},
       CellPrint[{ExpressionCell[Defer @@ cmd, "Input"], 
                  ExpressionCell[ReleaseHold[cmd], "Output"]}]],
      "MouseDown" :> (pt2 = pt1 = pt = MousePosition["Graphics"]),
      "MouseDragged" :> (pt2 = pt = MousePosition["Graphics"]),
      "MouseUp" :> (pt2 = pt = MousePosition["Graphics"])}]]]],
 Row[{
   Button["Generate",
    plotRange = {{pt1[[1]], pt2[[1]]}, {pt1[[2]], pt2[[2]]}};
    mandelbrotPic = 
     MandelbrotSetPlot[{pt1[[1]] + pt1[[2]]*I, 
       pt2[[1]] + pt2[[2]]*I},
      MaxIterations -> bail, ImageResolution -> resolution, 
      ImageSize -> imageSize,
      ColorFunction -> colorScheme],
    Method -> "Queued"
    ],
   Button["Reset",
    bail = defaultBailout; 
    resolution = defaultResolution;
    colorScheme = defaultColorScheme;
    plotRange = {{-2, 0.6}, {-1.3, 1.3}};
    mandelbrotPic = MandelbrotSetPlot[{-2.0 - 1.3 I, 0.6 + 1.3 I},
      MaxIterations -> bail, ImageResolution -> resolution, 
      ImageSize -> imageSize,
      ColorFunction -> colorScheme];
    pt = {0, 0}; pt1 = {-2, -1.3}; pt2 = {0.6, 1.3};]}],
 {{bail, defaultBailout, "Bailout"}, bailoutOptions, 
  ControlType -> SetterBar}, 
 {{resolution, defaultResolution, "Resolution"}, resolutionOptions},
 {{colorScheme, defaultColorScheme, "Color Scheme"}, colorSchemes},
 {{showBounds, False, "Show PlotRange"}, {True, False}},
 Initialization :> (
   pt = {0, 0}; pt1 = {-2, -1.3}; pt2 = {0.6, 1.3};
   plotRange = {{-2, 0.6}, {-1.3, 1.3}};
   mandelbrotPic = MandelbrotSetPlot[{-2.0 - 1.3 I, 0.6 + 1.3 I},
     MaxIterations -> bail, ImageResolution -> resolution, 
     ImageSize -> imageSize,
     ColorFunction -> colorScheme];)
 ]
$\endgroup$
3
  • $\begingroup$ This is very nice to play with! Something that annoys me about MandelbrotSetPlot is that increasing the MaxIterations will make some interesting features very faint, and will only highlight the inner edges. However, not increasing MaxIterations will not reveal those interesting features. Perhaps something like this can be a fix: Colorize[HistogramTransform@ Image@First@ MandelbrotSetPlot[{-0.924 + 0.33 I, -0.913 + 0.316 I}, MaxIterations -> 1000, ImageResolution -> 1000, ColorFunction -> GrayLevel], ColorFunction -> "BeachColors"] $\endgroup$
    – Szabolcs
    Mar 26, 2017 at 15:37
  • $\begingroup$ Of course, this has its own issues too. Sometimes just raising the image to a power less than 1 is better. 11.1 supports direct image arithmetic. $\endgroup$
    – Szabolcs
    Mar 26, 2017 at 15:38
  • 1
    $\begingroup$ @Szabolcs Thanks! Your complaint is a consequence of the way that iteration counts behave and the fact that those counts are mapped linearly to the colors. One solution is to manipulate those counts inside the ColorFunction. Compare ColorFunction -> "BeachColors" to ColorFunction -> If[#3 == 1, Black, ColorData["BeachColors"][#3^(0.4)]] &), for example. I guess that's essentially what you're doing when you raise the image to a power, though I suspect you have finer control when working with the ColorFunction. It is a little slower, though. $\endgroup$ Mar 26, 2017 at 16:00

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.