Message Boards Message Boards

Curlicue Fractals

Ed Pegg, Wolfram Research
Posted 9 years ago

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?
POSTED BY: Ed Pegg
11 Replies
Sort By:

Nice relevant post: A beautiful picture related to Collatz conjecture
POSTED BY: Vitaliy Kaurov

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]]]]
POSTED BY: Udo Krause

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

POSTED BY: Udo Krause

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.
POSTED BY: Todd Rowland

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.

POSTED BY: Udo Krause

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
POSTED BY: Udo Krause

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
POSTED BY: Marco Thiel
POSTED BY: Marco Thiel
POSTED BY: Eduardo Serna

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
POSTED BY: Vitaliy Kaurov

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
POSTED BY: Vitaliy Kaurov
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract