Message Boards Message Boards

GROUPS:

Curlicue Fractals

Posted 4 years ago
12085 Views
|
11 Replies
|
46 Total Likes
|

The CurlicueFractal can be simplified with AnglePath.

Graphics[Line[AnglePath[N[ (7 Sqrt[7] Khinchin Pi E EulerGamma) Range[-20000, 20000]]]]]

curlicue fractal

Who else can find some nice ones?

11 Replies

I'm game. I'd add a bit of Opacity to see structure in concentrated places. Some of these could probably make nice tattoos ;-)

Multicolumn[
Graphics[{Opacity[.5], Line[AnglePath[N[# Range[-20000, 20000]]]]}, 
    ImageSize -> 500] & /@ {51 E, 350, 30 E, 37 E, 90 E, 406 E}, 2]  

enter image description here

Following cool ideas from Marco's answer I am adding Collatz to my gallery. The longest progression for any initial starting number less than 10 billion it is 9,780,657,631, with 1132 steps. I plot its neighbor 9,780,657,630 too and for 1200 to see the cycle.

data0 = NestList[If[EvenQ[#], #/2, 3 # + 1] &, 9780657630, 1200];
data1 = NestList[If[EvenQ[#], #/2, 3 # + 1] &, 9780657631, 1200];
Graphics[{
  Red, BSplineCurve[Reverse /@ AnglePath[Log@N@data0]],
  Blue, BSplineCurve[Reverse /@ AnglePath[Log@N@data1]]}, 
 ImageSize -> 900, Background -> GrayLevel[.1]]

enter image description here

Do not dwell too long on Collatz though... "Mathematics may not be ready for such problems." ~ Paul Erdős about the Collatz conjecture

enter image description here

Dear Ed and Vitaliy,

these are beautiful and nicely symmetric curves. I have tried some other, less regular systems. Let's run a chaotic logistic map:

logistmap=NestList[4.*#*(1 - #) &, RandomReal[], 100];

We can plot this:

ListLinePlot[ NestList[4.*#*(1 - #) &, RandomReal[], 100], Mesh -> Full, MeshStyle -> Red]

enter image description here

Note that it is a time discrete map in a chaotic regime; the blue line is just to guide the eye. I chose to start at a random initial condition, which is generated by the RandomReal[]. The AnglePath looks like this:

Graphics[Line[AnglePath[NestList[4.#(1 - #) &, RandomReal[], 10000]]]]

enter image description here

Now, every time you run this, we use a different initial condition, i.e. the path is always different. We could try to figure out where we are on average over, say, 1000 runs and then plot that:

coords = Table[AnglePath[NestList[4.*#*(1 - #) &, RandomReal[], 1000]], {k, 1, 1000}];
SmoothHistogram3D[Flatten[coords, 1], ColorFunction -> "Rainbow"]

enter image description here

Ok. Let's compare that to Ed's example. All trajectories are the same; it makes no difference but to be consistent with the logistic map example I'll run it 1000 times:

coords2 = Table[AnglePath[N[(7 Sqrt[7] Khinchin Pi E EulerGamma) Range[-2000, 2000]]], {k, 1, 1000}];
SmoothHistogram3D[Flatten[coords2, 1], ColorFunction -> "Rainbow"]

enter image description here

We can now also look at a Levy-flight-like situation:

Graphics[Line[AnglePath[Accumulate@(RandomChoice[{-1, 1}, 1000]*RandomVariate[LevyDistribution[0, 0.0001], 1000])]]]

enter image description here

and

coords3 = Table[AnglePath[Accumulate@(RandomChoice[{-1, 1}, 1000]*RandomVariate[LevyDistribution[0, 0.0001], 1000])], {k, 1,1000}];
SmoothHistogram3D[Flatten[coords3, 1], ColorFunction -> "Rainbow"]

enter image description here

It is very nice that the geometry can represent the dynamics. Of course, it is easy to find something for those who like "patterns and numbers".

Let's look at the digit path of $Pi$.

Graphics[Line[AnglePath[RealDigits[N[Pi, 1000]][[1]]]]]

enter image description here

Then $\sqrt{2}$

Graphics[Line[AnglePath[RealDigits[N[Sqrt[2], 1000]][[1]]]]]

enter image description here

I guess that $e$ is also important:

Graphics[Line[AnglePath[RealDigits[N[Exp[1], 1000]][[1]]]]]

enter image description here

These paths all look quite "random" which is typical for "normal numbers", i.e. numbers the digits of which could come from a random draw of digits. You get beautiful patterns for non-normal numbers like 1/3.

Graphics[Line[AnglePath[RealDigits[N[1/3, 1000]][[1]]]]]

enter image description here

Here's 1/7:

Graphics[Line[AnglePath[RealDigits[N[1/7, 1000]][[1]]]]]

enter image description here

Heres it comes for the inverses of the first 5 primes:

GraphicsRow[Graphics[Line[AnglePath[RealDigits[N[1/#, 1000]][[1]]]]] & /@ Prime[Range[5]]]

enter image description here

Finally, we can look at the patterns in different bases, here for 1/7:

Graphics[Line[AnglePath[RealDigits[N[1/7, 200], #, 200][[1]]]]] & /@ Range[2, 10]

enter image description here

It can also be useful to visualise sound. Here is what a viola looks like:

sndviola = ExampleData[{"Sound", "Viola"}];
Graphics[Line[AnglePath[sndviola[[1, 1, 1]]]]]

enter image description here

An organ is a completely different kettle of fish (I admit that this was not a very common sentence!):

sndorgan = ExampleData[{"Sound", "OrganChord"}];
Graphics[Line[AnglePath[sndorgan[[1, 1, 1]]]]]

enter image description here

This is "Houston we have a problem!":

sndapollo = ExampleData[{"Sound", "Apollo13Problem"}];
Graphics[Line[AnglePath[snd[[1, 1, 1]]]]]

enter image description here

Obviously, this works with images, too. Here is Lena:

Graphics[Line[AnglePath[Flatten[ImageData[ExampleData[{"TestImage", "Lena"}]]]]]]

enter image description here

As expected, more regular data

ExampleData[{"TestImage", "ResolutionChart"}]

enter image description here

look more regular:

Graphics[Line[AnglePath[Flatten[ImageData[ExampleData[{"TestImage", "ResolutionChart"}]]]]]]

enter image description here

I know that there are many people here who like CellularAutomata. AnglePath can also produce a nice visualisation of the resulting patterns:

Graphics[Line[AnglePath[Flatten[CellularAutomaton[30, {{1}, 0}, 50]]]]]

enter image description here

and

Graphics[Line[AnglePath[Flatten[CellularAutomaton[{1599, {3, 1}}, {Table[1, {1}], 0}, 80]]]]]

enter image description here

It appears to me that it can even be used for the analysis of graphs.

Graphics[Line[AnglePath[Flatten[Normal[AdjacencyMatrix[RandomGraph[BarabasiAlbertGraphDistribution[100, 2]]]]]]]]

enter image description here

The degree distribution, for example, changes the AnglePaths substantially.

Well, that's all I got for now...

Cheers,

Marco

This is so cool

Ups,

I did forget something. You can of course slightly modify the AnglePath function so that it also plots time:

sndviola = ExampleData[{"Sound", "Viola"}];
angleviola = AnglePath[sndviola[[1, 1, 1]]];
ListPointPlot3D[Flatten /@ Table[{k, angleviola[[k]]}, {k, 1, Length[sndviola[[1, 1, 1]] - 1]}], AspectRatio -> 1]

enter image description here

Cheers,

Marco

Let SubstitutionSystem produce the patterns

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
              Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[Pi, 30]]], 2], {1}, 44]]]]]]

enter image description here

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[E, 30]]], 2], {1}, 45]]]]]]

enter image description here

the circle number $\pi$ gives a rounder picture than the Euler number $e$. One can do thousands of figures

Gaphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[Pi, 30]]], 2], {7, 3, 2}, 104]]]]]]

one more

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[E, 30]]], 2], First[RealDigits[N[E, 3]]], 45]]]]]]    

imposing as

enter image description here

Or doing something ill-looking

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[E, 30]]], 2], First[RealDigits[N[E \[Pi], 133]]], 45]]]]]]

enter image description here

Just one more thing (.... I'm sorry about this ....)

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[Pi, 30]]], 2], {7, 3, 2, 8}, 304]]]]]]

enter image description here

after seven steps it gets into repetition.

Very cool. Udo's example (how can I l write a link that goes to his example?) reminds me of one of Stephen Wolfram's live experiments at the 2015 summer school which might have used SubstitutionSystem, but might have also been even simpler.

Take some negative numbers too

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
      Rule[#[[1]], {RandomChoice[{-1, 1}] #[[2]]}] & /@ 
       Partition[First[RealDigits[N[E, 30]]], 2], 
      First[RealDigits[N[E \[Pi], 133]]], 31]]]]]]

enter image description here

and one symmetrical (despite the pesudo-randomness in the rule, it's only active during rule creation)

Graphics[Line[
  AnglePath[
   N[Flatten[
     SubstitutionSystem[
      Rule[#[[1]], {RandomChoice[{-1, 1}] #[[2]]}] & /@ 
       Partition[First[RealDigits[N[Pi, 30]]], 2], {7, 3, 2, 8}, 
      304]]]]]]

giving

enter image description here

replace $\pi$ again with $e$

Graphics[Line[AnglePath[N[Flatten[SubstitutionSystem[
          Rule[#[[1]], {RandomChoice[{-1, 1}] #[[2]]}] & /@ 
           Partition[First[RealDigits[N[E, 30]]], 2], {7, 3, 2, 8}, 304]]]]]]

and hit the return key a few times to see

enter image description here

Here is a case which finds after a rather long path into repetition

Graphics[Line[AnglePath[Partition[N[Flatten[
      SubstitutionSystem[Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[E, 130]]], 2], 
       First [RealDigits[N[1/EulerGamma, 150]]], 146]]], 2]]]]

enter image description here

Want to look into the evil eye? Try

Graphics[Line[AnglePath[Partition[N[Flatten[
      SubstitutionSystem[Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[\[Pi], 30]]], 2], 
       First [RealDigits[N[1/E, 10]]], 206]]], 2]]]]

or

Graphics[Line[AnglePath[Partition[N[Flatten[
      SubstitutionSystem[Rule[#[[1]], {#[[2]]}] & /@ Partition[First[RealDigits[N[\[Pi], 30]]], 2], 
       First [RealDigits[N[\[Pi]/E, 10]]], 144]]], 2]]]]
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract