5
$\begingroup$

I'm trying to replicate "symmetric icons" from this book:

https://www.amazon.com/Symmetry-Chaos-Search-Pattern-Mathematics/dp/0898716721

Here is what I have so far:

n = 6;
α = 5;
β = 1.5;
γ = 1;
ω = 0;
λ = -2.7;
f[z_] := (λ + α z Conjugate[z] + β Re[z^n] + ω I)z + γ Conjugate[z]^(n - 1);
z0 = .1 +.1 I;
(*data=NestList[f,z0,100000];*)
ListPlot[
  {Re[#], Im[#]}& /@ NestList[f, z0, 100000],
  AspectRatio -> 1,
  Axes -> False,
  PlotStyle -> {Opacity[.45], White, Small},
  Background -> Black]

I have two questions:

1) I have a vague idea that instead of using ListPlot, I can use Image and then map the points to pixels, counting the number of times a pixel is hit, and then coloring each pixel somehow using ColorFunction. However, I'm not real sure.

2) To make the image above nicer, you should change 100000 to a million, or ten million, and make the Opacity lower. However, I worry that I'm being very inefficient. Is there an obvious way to make this much more efficient?

Edit

From the help below, the "best" code I have for this is:

f[z_] = (λ + α z Conjugate[z] + β Re[z^n] + ω I)z + γ Conjugate[z]^(n - 1);
z0 = .1 + .1 I;
iter = 10000000;
opac=.1;
Graphics[
  {Black, Opacity[opac], PointSize[Tiny], Point[ReIm @ NestList[f, z0, iter]]}]

producing

enter image description here

I would like to be able to "simply" add custom colors (based on the number of times a neighborhood is hit by a point in the iteration) to an Image like this:

res = 1000;
colorLim = 1;
dataBin = 
  Map[GrayLevel, 
    Sqrt[(1/colorLim) * 
      Transpose @ 
        BinCounts[
          {Re[#],Im[#]}&/ @ NestList[f, z0, 1000000], 
          {-1, 1, 1/res}, {-1, 1,1/res}]], 
    {2}];
Image[dataBin]

but this is eluding me right now.

$\endgroup$
  • $\begingroup$ Note: Re[#], Im[#]} & can be replaced with ReIm. $\endgroup$ – m_goldberg Dec 27 '19 at 1:13
  • $\begingroup$ Thanks! Currently the "best" code I know for this is has been edited above. $\endgroup$ – Bart Snapp Dec 28 '19 at 13:59
6
$\begingroup$
dat = Quiet@ReIm@NestList[f, z0, 10000000];

Binning

Using the method from this answer for bin counts:

res = 1000; 
epsilon = 1*^-10;
indices = 1 + Floor[(1 - epsilon) res Rescale[dat]];
System`SetSystemOptions["SparseArrayOptions" -> {"TreatRepeatedEntries" -> Total}];
matrix = SparseArray[indices -> 1., {res, res}];
System`SetSystemOptions["SparseArrayOptions" -> {"TreatRepeatedEntries" -> First}]; 

Image

You can play with different scalings for bincounts:

Image[1 - Rescale[matrix^(1/4)], ImageSize -> Large]

enter image description here

Image[Map[Blend[{ Red, Orange, Yellow,  White}, #^4] &, 
  1 - Rescale[Normal[matrix]^(1/4)], {2}], ImageSize -> Large]

enter image description here

MatrixPlot

 MatrixPlot[Rescale[matrix^(1/4)], ImageSize -> Large, 
  MaxPlotPoints -> Infinity, Frame -> False, 
  ColorFunction -> "Rainbow", ColorFunctionScaling -> False]

enter image description here

Add the option ColorRules -> {0. -> Black} to get

enter image description here

ComplexListPlot

ComplexListPlot[NestList[f, z0, 50000], 
  AspectRatio -> 1, Axes -> False, Background -> Black, 
 ColorFunction -> (ColorData["Rainbow"][Abs[ f[# + #2 I]]] &), 
 ColorFunctionScaling -> False]

enter image description here

ListPlot + VertexColors

You can post-process ListPlot output to add VertexColors:

{min, max} = MinMax[Abs@NestList[f, z0, 500000]]; 

ListPlot[ReIm@NestList[f, z0, 500000], AspectRatio -> 1, 
  Axes -> False, BaseStyle -> PointSize[Tiny]] /. 
 Point[x_] :>  Point[x, VertexColors -> (Opacity[.5, #] & /@ 
      ColorData[{"Rainbow", {min, max}}] /@ (Abs@f[# + I #2] & @@@ x))]

enter image description here

Graphics + VertexColors

{min, max} = MinMax[Abs@NestList[f, z0, 500000]]; 

Graphics[{PointSize[Tiny], Opacity[.5], 
  Point[#, VertexColors -> ColorData[{"Rainbow", {min, max}}]/@ (Abs@f[# + I #2]&@@@#)]&[
   ReIm@NestList[f, z0, 500000]]}, 
 AspectRatio -> 1]

enter image description here

$\endgroup$
  • $\begingroup$ This is really great, I love the colors, but I would like to set the color by the number of times a neighborhood is hit by a point in the iteration. $\endgroup$ – Bart Snapp Dec 28 '19 at 14:06
4
$\begingroup$

Here's a quick-and-dirty approach which might be helpful - but is pretty slow on reasonable image sizes (that is, could be improved):

With[{bc = 
    BinCounts[ReIm@data, 
     Sequence @@ ({#1, #2, (#2 - #1)/256} & @@@ 
        CoordinateBounds@ReIm@data)]}, 
  bc /. Map[
    Evaluate[# -> 
       ColorData["SunsetColors"]@
        N@CDF[HistogramDistribution@Flatten@bc, #] &], 
    Union@Flatten@bc]] // Image

Histogram-based

BinCounts is performed for a square defined by bounds of the dataset and color is assigned to each unique value in the count on basis of CDF of the distribution of these values. In this case ColorData["SunsetColors"] is used as a palette, but something custom could be used as well.

Something similar can be also achieved by "gamma-correcting" the range of bin counts. This is dramatically faster for a reason or another:

With[{bc = 
    BinCounts[ReIm@data, 
     Sequence @@ ({#1, #2, (#2 - #1)/256} & @@@ 
        CoordinateBounds@ReIm@data)]}, 
  Map[
   ColorData["SunsetColors"],
   (bc/N@Max@Flatten@bc)^(1/5), {2}]] // Image

Gamma corrected

$\endgroup$
1
$\begingroup$

Suppose you had data = NestList[f, z0, 10000000].

Then you might want DensityHistogram[ReIm@data, 100, "PDF"] or something similar, playing around with the ColorFunction option.

densityhistogram

$\endgroup$
  • $\begingroup$ I think this is actually the answer I'm looking for. However, I am unable to set the function for the coloring that will yield anything as interesting as the grayscale picture above. I think this is the answer, but I am unable to use it to produce the desired graph. $\endgroup$ – Bart Snapp Dec 28 '19 at 14:07
  • $\begingroup$ Crank up the number of bins. With 2^8 bins, I get wispy structure like your example, but to get it to look 'nice' may require a lot more data and a lot more bins (read: rendering time). $\endgroup$ – evanb Dec 29 '19 at 4:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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