Some Simple Parameterizations Yielding Visually Stunning Plots

bryanlettner · December 20, 2015, 12:26am

Some really simple parameterizations yield some elegant-looking results. Some of them are fractal. Here are a few of the coolest I found:

ParametricPlot[Sum[{1/(Sqrt[2])^k Sin[(Sqrt[2])^k t],1/(Sqrt[2])^k Cos[(Sqrt[2])^k t]}, {k, 0, 20}], {t, 0, 1200 Pi}]

It almost looks photorealistic when we take t and k to large values, a bit like an electron microscope image.

ParametricPlot[Sum[{1/(Sqrt[3])^k Sin[(Sqrt[3])^k t],1/(Sqrt[3])^k Cos[(Sqrt[3])^k t]}, {k, 0, 20}], {t, 0, 1200 Pi}]

ParametricPlot[Sum[{1/GoldenRatio^k Sin[GoldenRatio^k t],1/GoldenRatio^k Cos[GoldenRatio^k t]}, {k, 0, 20}], {t, 0, 1200 Pi}]

ParametricPlot[Sum[{1/Fibonacci[k] Sin[Fibonacci[k + 13] t],1/Fibonacci[k] Cos[Fibonacci[k + 13] t]}, {k, 1, 20}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/a^k Sin[a^k t], (-1)^k/a^k Cos[a^k t]}, {k, 0, 20}], {t, 0, 1200 Pi}]

ParametricPlot[Sum[{1/k^2 Sin[k^2 t], 1/k^2 Cos[k^2 t]}, {k, 1, 100}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/2^k Sin[2^k t], 1/2^k Cos[2^k t]}, {k, 0, 50}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/Fibonacci[k] Sin[Fibonacci[k] t], 1/Fibonacci[k] Cos[Fibonacci[k] t]}, {k, 1, 30}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/2^k Sin[2^k t], (-1)^k/2^k Cos[2^k t]}, {k, 0, 20}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/Fibonacci[k] Sin[k^2 t], 1/Fibonacci[k] Cos[k^2 t]}, {k, 1, 150}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/k! Sin[(-1)^k k! t], (-1)^k/k! Cos[(-1)^k k! t]}, {k, 0, 100}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/2^k Sin[(-1)^k 2^k t], (-1)^k/2^k Cos[(-1)^k 2^k t]}, {k, 0, 100}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/k^2 Sin[(-1)^k k^2 t], (-1)^k/k^2 Cos[(-1)^k k^2 t]}, {k, 1, 100}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{(-1)^k/k^2 Sin[(-1)^k (k - 1)^2 t], (-1)^k/k^2 Cos[(-1)^k (k - 1)^2 t]}, {k, 1, 150}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/k^2 Sin[(k - 1)^2 t], 1/k^2 Cos[(k - 1)^2 t]}, {k, 1, 150}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/Fibonacci[k] Sin[Fibonacci[k]^2 t], 1/Fibonacci[k] Cos[Fibonacci[k]^2 t]}, {k, 1, 30}], {t, 0, 2 Pi}]

ParametricPlot[Sum[{1/Sqrt[Fibonacci[k]] Sin[Fibonacci[k] t],1/Sqrt[Fibonacci[k]] Cos[Fibonacci[k] t]}, {k, 1, 30}], {t, 0, 2 Pi}]

samcarrettie · December 21, 2015, 11:13am

This is great, @Bryan Lettner ! But I cannot reproduce your 1st image from your 1st line of code. How did you get it?

bryanlettner · December 21, 2015, 12:07pm

Yes, I left out some code for the sake of brevity. Try this:

ParametricPlot[Sum[{1/(Sqrt[2])^k Sin[(Sqrt[2])^k t], 
   1/(Sqrt[2])^k Cos[(Sqrt[2])^k t]}, {k, 0, 15}], {t, 0, 100 Pi}, MaxRecursion -> 10]

Reduced values of t and k, and a high MaxRecursion, should help. Give it about 30-60 seconds to evaluate. With this, you can begin to see the image take shape. However, you will need k > 20 and t > 500Pi to see the details fully emerge, and PlotStyle-> Thickness has to be just right, otherwise it will appear too dark or too faint. I also assembled the plot piecewise, taking t just 10 Pi at a time, because it is very computationally intensive due to high values for t, k, and MaxRecursion. Here is the actual code I used:

CoolCurve[i_] := ParametricPlot[
   Sum[{1/(Sqrt[2])^k Sin[(Sqrt[2])^k t], 1/(Sqrt[2])^k Cos[(Sqrt[2])^k t]}, {k, 0, 20}]
   , {t, (10 i - 10) Pi, 10 i Pi}, PlotStyle -> Thickness[0.0003], MaxRecursion -> 10, ImageSize -> Large];

Export["fhqwhghads.jpg", Show[Table[CoolCurve[n], {n, 0, 120}]]]

It will take at least a couple hours. The image looks a little saturated (too dark)… If I were doing it over again, I would use Thickness[0.0002], and ImageSize->{5000,Automatic} to make a larger, more detailed image. I chose jpg format because .tiff would have been a gigabyte or more. Make sure you have your jpg compression settings to 0.00 to avoid distortion. You can check this by right-clicking any plot, Save Graphic As, choose JPG, click Options, set compression to 0.

Also, if you want to indulge in a little pareidolia for fun, you can see what look like faces along the vertical axis . Stay tuned, two more plots coming.

bryanlettner · December 23, 2015, 9:01pm

Okay so here are two more cool ones:

CurveG[i_] := ParametricPlot[
  Sum[{(-1)^k/GoldenRatio^k Sin[(-1)^k GoldenRatio^k t], (-1)^k/
     GoldenRatio^k Cos[(-1)^k GoldenRatio^k t]}, {k, 0, 40}]
  , {t, (10 i - 10) Pi, 10 i Pi}, PlotStyle -> Thickness[0.0001], 
  MaxRecursion -> 11, ImageSize -> {850, Automatic}]

Show[Table[CurveG[p], {p, 1, 120}]]

Pretty cool, but this next one is my favorite:

CurveJ[i_] := ParametricPlot[
  Sum[{(-1)^k/1.5^k Sin[(-1)^k 1.5^k t], (-1)^k/1.5^
     k Cos[(-1)^k 1.5^k t]}, {k, 0, 30}]
  , {t, (10 i - 10) Pi, 10 i Pi}, PlotStyle -> Thickness[0.00002], 
  MaxRecursion -> 11, PlotRange -> {{-2.5, 2.5}, {-2.5, 2.5}}, 
  ImageSize -> {5000, Automatic}]

Export["HairyStarfish0to6000.jpg", Show[Table[CurveJ[p], {p, 1, 600}]]]
Export["HairyStarfish6000to12000.jpg", Show[Table[CurveJ[p], {p, 600, 1200}]]]
Export["HairyStarfish12000to18000.jpg", Show[Table[CurveJ[p], {p, 1200, 1800}]]]
Export["HairyStarfish18000to24000.jpg", Show[Table[CurveJ[p], {p, 1800, 2400}]]]
Export["HairyStarfish24000to30000.jpg", Show[Table[CurveJ[p], {p, 2400, 3000}]]]
Export["HairyStarfish30000to36000.jpg", Show[Table[CurveJ[p], {p, 3000, 3600}]]]
Export["HairyStarfish36000to42000.jpg", Show[Table[CurveJ[p], {p, 3600, 4200}]]]
Export["HairyStarfish42000to48000.jpg", Show[Table[CurveJ[p], {p, 4200, 4800}]]]
Export["HairyStarfish48000to54000.jpg", Show[Table[CurveJ[p], {p, 4800, 5400}]]]

I did it piecewise like that because it was too taxing on the CPU to go from t=0 to t= large in one go. Each export took about 7 hours. Then I applied some gamma correction (to make lighter and avoid saturation) and stitched them together using ImageMultiply. The plot looks like:

If we look closely, we can see some interesting details beginning to emerge. Almost like a paisley or tribal design.

I am going to try it again using a larger image size, a lower value for PlotStyle->Thickness, and taking t all the way to 1,000,000 Pi or so to capture most nuanced detail I can manage. I think with some strategic image processing, we would see some laser-like patterns emerge. On that note, some questions:

-What’s the best way to overlay or “add” multiple (10+) images?

-Any general advice on how to enhance the definition and make the patterns “jump out at you”?

I’ve attached the composite image and some of the constituent images.

Topic		Replies	Views
Curlicue Fractals Ideas ruliology , computational-arts , graphics-and-visualization	11	24738	September 2, 2015
Eliminating jagged and inaccurate plots Questions image-processing , mathematica , geometry , graphics-and-visualization , optimization	3	9282	February 14, 2014
Parametric curves in art Ideas computational-arts , geometry , graphics-and-visualization , interface-construction , computational-humanities	1	4547	April 27, 2024
Experimenting with fun curve plots from Wolfram Alpha Questions mathematica , wolfram-alpha , graphics-and-visualization	3	21713	March 8, 2014
Orient properly real-life images based on math curves ? Questions graphics-and-visualization	3	9748	November 21, 2016

Some Simple Parameterizations Yielding Visually Stunning Plots

Related topics