Mandelbrot Set

Author

Eric W. Weisstein
April 17, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Fractals/MandelbrotSet.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Mandelbrot-Set.html.

©2024 Wolfram Research, Inc. except for portions noted otherwise

Graphics

Built-in MandelbrotSetPlot

MandelbrotSetPlot[ColorFunction->(GrayLevel[1-#3]&),Frame->False]

MandelbrotSetPlot[Frame->False]

MandelbrotSetPlot[ColorFunction->Hue]

MandelbrotSetPlot[ColorFunction->(Hue[#3]&)]

V6 package

<<MathWorld`Fractal`

MandelbrotSet[{-2-1.1I,0.5+1.1I},ColorFunction->(Hue[#/20]&),ColorFunctionScaling->False,MaxRecursion->5]

V5 package

MandelbrotSet[{-2-1.1I,0.5+1.1I},PlotPoints->250]//Timing

MandelbrotSet[{-2-1.1I,0.5+1.1I},PlotPoints->250,ColorFunction->Hue]//Timing

MandelbrotSet[{-2-1.1I,0.5+1.1I},PlotPoints->250,ColorFunctionScaling->False,ColorFunction->(Hue[#/10]&)]//Timing

MandelbrotSet[{-2-1.1I,0.5+1.1I}]

Named valleys

rect[{{x1_,y1_},{x2_,y2_}}]:=Line[{{x1,y1},{x2,y1},{x2,y2},{x1,y2},{x1,y1}}]

http://66.39.71.195/Derbyshire/manguide.html

Whirl Region

rect[{{x1_,y1_},{x2_,y2_}}]:=Line[{{x1,y1},{x2,y1},{x2,y2},{x1,y2},{x1,y1}}]

With[{
reg=(.009+.005I)/2{-1,1}-1.25+.047I,
plot={-1.4,-1.2+.1I},
title="whirl region"
},
Labeled[
GraphicsRow[{
MandelbrotSetPlot[plot,ColorFunction->(GrayLevel[1-#3]&),Epilog->{Red,rect[ReIm[reg]]}],
MandelbrotSetPlot[reg,ColorFunction->(GrayLevel[1-#3]&)]}],
Style[title,Directive[16,FontFamily->"Times",Italic]],Top]
]

1. Seahorse Valley

rect[{{x1_,y1_},{x2_,y2_}}]:=Line[{{x1,y1},{x2,y1},{x2,y2},{x1,y2},{x1,y1}}]

With[{
reg={-.89+.01I,-.63+0.22I},
plot={-1.4-.1I,-.5+.5I},
title="sea horse valley"
},
Labeled[
GraphicsRow[{
MandelbrotSetPlot[plot,ColorFunction->(GrayLevel[1-#3]&),Epilog->{Red,rect[ReIm[reg]]}],
MandelbrotSetPlot[reg,ColorFunction->(GrayLevel[1-#3]&)]}],
Style[title,Directive[16,FontFamily->"Times",Italic]],Top]
]

6. Scepter Valley

rect[{{x1_,y1_},{x2_,y2_}}]:=Line[{{x1,y1},{x2,y1},{x2,y2},{x1,y2},{x1,y1}}]

With[{
reg=2(.009+.01I){0,1}-1.375,
plot={-1.4-.1I,-1.2+.1I},
title="scepter valley"
},
Labeled[
GraphicsRow[{
MandelbrotSetPlot[plot,ColorFunction->(GrayLevel[1-#3]&),Epilog->{Red,rect[ReIm[reg]]}],
MandelbrotSetPlot[reg,ColorFunction->(GrayLevel[1-#3]&)]}],
Style[title,Directive[16,FontFamily->"Times",Italic]],Top]
]

Elephant Valley

rect[{{x1_,y1_},{x2_,y2_}}]:=Line[{{x1,y1},{x2,y1},{x2,y2},{x1,y2},{x1,y1}}]

With[{
reg={.2-.1I,.4+.1I},
plot={-1-.7I,.5+.7I},
title="elephant valley"
},
Labeled[
GraphicsRow[{
MandelbrotSetPlot[plot,ColorFunction->(GrayLevel[1-#3]&),Epilog->{Red,rect[ReIm[reg]]}],
MandelbrotSetPlot[reg,ColorFunction->(GrayLevel[1-#3]&)]}],
Style[title,Directive[16,FontFamily->"Times",Italic]],Top]
]

Lemniscates

lemniscates=NestList[c+#^2&,0,6]

Expand[Take[lemniscates,5]]//ColumnForm//TraditionalForm

CoefficientList[#,c]&/@lemniscates

Exponent[#,c]&/@lemniscates

Factor/@lemniscates//ColumnForm

(lemneq=Factor[ComplexExpand[FunctionExpand[Abs[#]^2]]]&/@(lemniscates/.c->x+I y))//ColumnForm

lemniscates=Rest@NestList[c+#^2&,0,6];

lemneq=Factor[ComplexExpand[FunctionExpand[Abs[#]^2]]]&/@(lemniscates/.c->x+I y);

ContourPlot[Evaluate[Thread[lemneq==4]],{x,-2,2},{y,-2,2},ContourStyle->{Black,Red,Yellow,Green,Blue,Purple},WorkingPrecision->20]

ContourPlot[Evaluate[#==4&/@Rest[lemneq]],{x,-2,2},{y,-2,2},
ContourStyle->{Black,Red,Yellow,Green,Blue,Purple},PlotPoints->50,MaxRecursion->5,
WorkingPrecision->20,ImageSize->300]

Areas

n == 1

n==2

A193780

Region[lemniscate2=ImplicitRegion[((x^2)+(y^2)) (1+2 x+(x^2)+(y^2))<4,{x,y}],Frame->True]

RegionPlot[lemniscate2,AspectRatio->Automatic]

Area[lemniscate2]

NIntegrate[Boole[((x^2)+(y^2)) (1+2 x+(x^2)+(y^2))<4],{y,-2,2},{x,-2,2}]

(area2=Integrate[Boole[((x^2)+(y^2)) (1+2 x+(x^2)+(y^2))<4],{y,-2,2},{x,-2,2}])//Timing

area2/.r_Root:>ToRadicals[r,Assumptions->-(Sqrt[7])/2<y<(Sqrt[7])/2]//FullSimplify

N[%]

Plot[(Sqrt[1-4 (y^2)+4 (Sqrt[4-(y^2)])]),{y,0,(Sqrt[7])/2}]

2 NIntegrate[(Sqrt[1-4 (y^2)+4 (Sqrt[4-(y^2)])]),{y,0,(Sqrt[7])/2},PrecisionGoal->20,WorkingPrecision->50]

Integrate[(Sqrt[1-4 (y^2)+4 (Sqrt[4-(y^2)])]),y]

(area2=Integrate[Boole[((x^2)+(y^2)) (1+2 x+(x^2)+(y^2))<4],{x,-2,2},{y,-2,2}])//Timing

Integrate[(Sqrt[2])(Sqrt[-1-2x-2(x^2)+(Sqrt[17+4x+4(x^2)])]),x]

n==3

A193750

Region[lemniscate3=ImplicitRegion[((x^2)+(y^2)) (1+2 x+5 (x^2)+6 (x^3)+6 (x^4)+4 (x^5)+(x^6)-3 (y^2)-2 x (y^2)+8 (x^2) (y^2)+8 (x^3) (y^2)+3 (x^4) (y^2)+2 (y^4)+4 x (y^4)+3 (x^2) (y^4)+(y^6))<4,{x,y}],Frame->True]

RegionPlot[lemniscate3,AspectRatio->Automatic]

NIntegrate[Boole[((x^2)+(y^2)) (1+2 x+5 (x^2)+6 (x^3)+6 (x^4)+4 (x^5)+(x^6)-3 (y^2)-2 x (y^2)+8 (x^2) (y^2)+8 (x^3) (y^2)+3 (x^4) (y^2)+2 (y^4)+4 x (y^4)+3 (x^2) (y^4)+(y^6))<4],{y,-2,2},{x,-2,2}]

NIntegrate[Boole[((x^2)+(y^2)) (1+2 x+5 (x^2)+6 (x^3)+6 (x^4)+4 (x^5)+(x^6)-3 (y^2)-2 x (y^2)+8 (x^2) (y^2)+8 (x^3) (y^2)+3 (x^4) (y^2)+2 (y^4)+4 x (y^4)+3 (x^2) (y^4)+(y^6))<4],{y,-2,2},{x,-2,2},WorkingPrecision->25,PrecisionGoal->10]

Area

A098403

BFileSequence[098403]

FromDigits[{%,1}]//N[#,7]&

From grayscale

set=MandelbrotSetPlot[ColorFunction->(GrayLevel[1-#3]&),Frame->False]

vals=#[[All,1]]&/@set[[1,1]];

Dimensions[vals]

npix=Times@@%

(Subscript[z, min])=-2-1.3` i and (Subscript[z, max])=0.6` +1.3` i

(1-((Total[vals,2])/npix))Area[Rectangle[{-2,-1.3},{.6,1.3}]]

From black

Default ImageResolution

set=MandelbrotSetPlot[ColorFunction->(If[#3>.99,Black,White]&)]

vals=#[[All,1]]&/@set[[1,1]];

Dimensions[vals]

npix=Times@@%

(1-((Total[vals,2])/npix))Area[Rectangle[{-2,-1.3},{.6,1.3}]]

Higher ImageResolution

set=MandelbrotSetPlot[ColorFunction->(If[#3>.99,Black,White]&),ImageResolution->1000]

vals=#[[All,1]]&/@set[[1,1]];

Dimensions[vals]

npix=Times@@%

(1-((Total[vals,2])/npix))Area[Rectangle[{-2,-1.3},{.6,1.3}]]

By pixel counting

Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,50,SameTest->(Abs[#2]>2&)]],{x,-2,2,.5},{y,-2,2,.5}]//TraditionalForm

ArrayPlot[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,50,SameTest->(Abs[#2]>2&)]],{x,-2,.5,.1},{y,-1,1,.1}]]

With[{dx=.1,its=50},Total[Flatten[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,its+1,SameTest->(Abs[#2]>2&)]],{x,-2,2,dx},{y,-2,2,dx}]]]dx^2/its]//Timing

With[{dx=.1,its=5000},Total[Flatten[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,its+1,SameTest->(Abs[#2]>2&)]],{x,-2,2,dx},{y,-2,2,dx}]]]dx^2/its]//Timing

With[{dx=.05,its=5000},Total[Flatten[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,its+1,SameTest->(Abs[#2]>2&)]],{x,-2,2,dx},{y,-2,2,dx}]]]dx^2/its]//Timing

With[{dx=.01,its=5000},Total[Flatten[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,its+1,SameTest->(Abs[#2]>2&)]],{x,-2,2,dx},{y,-2,2,dx}]]]dx^2/its]//Timing

With[{dx=.005,its=10^4},Total[Flatten[Table[-2+Length[FixedPointList[(x+I y)+#^2&,x+I y,its+1,SameTest->(Abs[#2]>2&)]],{x,-2,2,dx},{y,-2,2,dx}]]]dx^2/its]//Timing

By Recursive Formula

Clear[b,w,a,u]

b[0]:=-1/2
b[n_]:=b[n]=-w[n,n+1]/n
w[0,m_]:=0
w[n_,m_]:=w[n,m]=a[m-1]+w[n-1,m]+Sum[a[j]w[n-1,m-j-1],{j,0,m-2}]
a[j_]:=a[j]=u[0,j+1]
u[n_,k_]:=u[n,k]=Which[
2^n-1==k,1,
2^n-1>k,Sum[u[n-1,j]u[n-1,k-j],{j,0,k}],
2^(n+1)-1>k,0,
True,(u[n+1,k]-Sum[u[n,j]u[n,k-j],{j,k-1}])/2
]

b/@Range[0,10]

Transpose[NumeratorDenominator[%]]

#b[#]&/@Range[0,10]

Through[{Numerator,Denominator}[%]]

(areas=Table[π(1-Sum[n b[n]^2,{n,nmax}]),{nmax,300}]);//Timing

ListPlot[areas,Joined->True,PlotStyle->Red,AxesLabel->{n,Subscript[A,n]}]

(areas=Table[π(1-Sum[n b[n]^2,{n,nmax}]),{nmax,1000}]);//Timing

nareas=N[areas,20]

Last[nareas]

And@@Table[-1<n b[n]<1,{n,1000}]

ListPlot[nareas,Joined->True,PlotStyle->Red,AxesLabel->{n,Subscript[A,n]}]

Generalized Mandelbrot

sin(z/c)

DensityPlot[
-Length[FixedPointList[Sin[#/(x+I y)]&,x+I y,10,SameTest->(Abs[#]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->300,ColorFunction->Hue,Mesh->False];//Timing

DensityPlot[
-Length[FixedPointList[Sin[#/(x+I y)]&,x+I y,100,SameTest->(Abs[#2]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->400,ColorFunction->(Hue[2#]&),Mesh->False]//Timing

DensityPlot[
-Length[FixedPointList[Sin[#/(x+I y)]&,.1,100,SameTest->(Abs[#2]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->400,ColorFunction->Hue,Mesh->False];//Timing

DensityPlot[
-Length[FixedPointList[Sin[#/(x+I y)]&,I+1,100,SameTest->(Abs[#2]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->400,ColorFunction->(Hue[4#]&),Mesh->False]//Timing

(z^2)+c

Mandelbrot[#^2+c&,{c,-2-I,1+I}]//Timing

DensityPlot[
-Length[FixedPointList[#^2+(x+I y)&,0,20,SameTest->(Abs[#]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->200,ColorFunction->Hue,Mesh->False];//Timing

DensityPlot[
-Length[FixedPointList[#^2+(x+I y)&,0,50,SameTest->(Abs[#]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->200,ColorFunction->Hue,Mesh->False];//Timing

DensityPlot[
-Length[FixedPointList[#^2+(x+I y)&,x+I y,50,SameTest->(Abs[#]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->200,ColorFunction->Hue,Mesh->False];//Timing

DensityPlot[
-Length[FixedPointList[#^2+(x+I y)&,1+I,50,SameTest->(Abs[#]>10^5&)]],
{x,-1,1},{y,-1,1},PlotPoints->200,ColorFunction->Hue,Mesh->False];//Timing

Images

The following should take 3 s, but instead takes 16 because it does not get compiled

Mandelbrot[Sin[#/c]&,{c,-1,1}]//Timing

Mandelbrot2[f_,{c_,zmin_,zmax_},opts___]:=Mandelbrot2[f,{c,zmin(I+1),zmax(I+1)},opts]/;Im[zmin]==Im[zmax]==0
Mandelbrot2[f_,{c_,zmin_,zmax_},opts___]:=Module[
{
dopts=FilterOptions[DensityPlot,opts,Options[Mandelbrot]],
its=MaxIterations/.{opts}/.Options[Mandelbrot],
r=MaxRadius/.{opts}/.Options[Mandelbrot],
x,y
},
DensityPlot[
-Length[FixedPointList[Sin[#/(x+I y)]&,x+I y,50,SameTest->(Abs[#2]>2&)]],
{x,Re[zmin],Re[zmax]},
{y,Im[zmin],Im[zmax]},
Evaluate[dopts]
]
]/;Im[zmin]≠0||Im[zmax]≠0

Mandelbrot2[Sin[#/c]&,{c,-1,1}]//Timing

Mandelbrot[Sin[c/#]&,{c,-1,1}]//Timing

Generalized Version for Arbitrary Powers

MandelbrotPlot[2,{{-2.01,.7},{-1.1,1.1}},PlotPoints->500]//Timing

With[{opts=Sequence[ColorFunction->(Hue[.67#]&),DisplayFunction->Identity]},
Show[GraphicsArray[
Partition[{
MandelbrotPlot[2,{{-2.01,.7},{-1.1,1.1}},opts],
MandelbrotPlot[3,{{-1.,1.},{-1.5,1.5}},opts],
MandelbrotPlot[4,{{-1.5,1.},{-1.5,1.5}},opts],
MandelbrotPlot[-2,{{-2.1,1.5},{-2.,2.}},opts],
MandelbrotPlot[-3,{{-1.5,1.5},{-1.5,1.5}},opts],
MandelbrotPlot[-4,{{-2.,2.},{-2.,2.}},opts]
},
3]],GraphicsSpacing->{-.1,0}]
]