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?
-
2$\begingroup$ Interesting question, sadly, with no effort shown on your side it will be hard to get enough attention to it $\endgroup$– SektorCommented Jun 2, 2015 at 18:08
-
2$\begingroup$ What do you suggest I try? $\endgroup$– silvascientistCommented 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. ♦Commented 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$– silvascientistCommented Jun 2, 2015 at 18:39
-
$\begingroup$ There is also this. $\endgroup$– wxfflesCommented Jun 2, 2015 at 23:17
3 Answers
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}}]
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}]
}]
}]
-
$\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$ Commented Jun 2, 2015 at 19:36
-
-
$\begingroup$ This is wonderful. Thank you so much. $\endgroup$ Commented Jun 2, 2015 at 19:39
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.
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];)
]
-
$\begingroup$ This is very nice to play with! Something that annoys me about
MandelbrotSetPlot
is that increasing theMaxIterations
will make some interesting features very faint, and will only highlight the inner edges. However, not increasingMaxIterations
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$– SzabolcsCommented 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$– SzabolcsCommented 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
. CompareColorFunction -> "BeachColors"
toColorFunction -> 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 theColorFunction
. It is a little slower, though. $\endgroup$ Commented Mar 26, 2017 at 16:00