New fractal based on the Golden mean/ Fibonacci numbers

Discussion in 'Mathematica' started by Roger Bagula, Mar 24, 2006.

  1. Roger Bagula

    Roger Bagula Guest

    I was thumbing through my book on Continuum Mechanics looking for a
    specific fact when I saw Mohr circles.
    I said:" wow, those are half plane modular form tessellation just like
    in the Elliptic curves book."
    They are forming half plane "triangles" in the Moebius/ bilinear
    transform sense.
    A little thought and a minimum of consultation in the Mathematica
    reference book
    and I had a Mohr circle based Fibonacci tessellation
    that represents an actual physical application of the golden mean.
    I've done a Goggle search and it appears nobody has thought of this before
    or put this set of 2 plus 2 together and got 4!
    I tried it for the next higher Bonaccis and it doesn't give this pleasing
    well formed set of curves.
    As most people in complex analysis know there is a classical half plane
    to disk transform
    that makes tessellations like this into tiling of the unit disk.
    These remind one of Ford circles, but they are definitely their kind
    that seems to be both unique and new.

    Here is the very simple notebook for generating this marvel:

    Clear[c, r, n]
    (* centers of Mohr stresses*)
    c[n_, 3] := (Fibonacci[n] + Fibonacci[n + 1])/2
    c[n_, 2] := (Fibonacci[n] + Fibonacci[n + 2])/2
    c[n_, 1] := (Fibonacci[n + 1] + Fibonacci[n + 2])/2
    (* radius of Shear Stress*)
    r[n_, 0] := Abs[(Fibonacci[n + 1] - Fibonacci[n + 2])/2]
    r[n_, 1] := Abs[Fibonacci[n] - (Fibonacci[n + 1] + Fibonacci[n + 2])/2]
    r[n_, 2] := Abs[(Fibonacci[n] - Fibonacci[n + 2])/2]
    r[n_, 3] := Abs[Fibonacci[n + 1] - (Fibonacci[n] + Fibonacci[n + 2])/2]
    r[n_, 4] := Abs[(Fibonacci[n] - Fibonacci[n + 1])/2]
    r[n_, 5] := Abs[Fibonacci[n + 2] - (Fibonacci[n] + Fibonacci[n + 1])/2]
    a = Flatten[Table[{Circle[{c[n, i + 1], 0}, r[n, 2*i +
    j], {0, Pi}]}, {i, 0, 2}, {j, 0, 1}, {n, 1, 25}]];
    Show[Graphics[a], AspectRatio -> Automatic, PlotRange -> All]


    Roger L. Bagula { email: or }

    11759 Waterhill Road,
    Lakeside, Ca. 92040 telephone: 619-561-0814
     
    Roger Bagula, Mar 24, 2006
    #1
    1. Advertisements

  2. Roger Bagula

    Roger Bagula Guest

    My aspect comes out two to one so that when roated 90 degrees it is
    distorted, but this picture comes out fine:

    (* Cartoon/ von Koch as Peak : Besicovitch - Ursell function*)
    f[x_] := 0 /; 0 <= x <= 1/3
    f[x_] := -2 + 6*x /; 1/3 < x <= 1/2
    f[x_] := 4 - 6*x /; 1/2 < x <= 2/3
    f[x_] := 0 /; 2/3 < x <= 1
    ff[x_] := f[Mod[Abs[x], 1]]
    Plot[f[Mod[Abs[x], 1]], {x, 0, 2}]
    s0 = Log[2]/Log[3]
    (* Cartoon/ as Sigmoid : Besicovitch - Ursell function*)
    g[x_] := 0 /; 0 <= x <= 1/3
    g[x_] := (3*x - 1) /; 1/3 < x <= 2/3
    g[x_] := 1 /; 2/3 < x <= 1
    gg[x_] := g[Mod[Abs[x], 1]]
    ParametricPlot[{f[t], gg[t]}, {t, 0, 1}, Axes -> False]
    Plot[gg[t], {t, 0, 2}]
    hh[x_] = Sum[gg[3^k*x]/3^(s0*k), {k, 0, 20}];
    kk[x_] = Sum[ff[3^k*(x)]/3^(s0*k), {k, 0, 20}];
    a = Table[{kk[n/30000], hh[n/30000]}, {n, 1, 30000}];
    ga = Show[Graphics[{PointSize[0.003], Point /@ a}], Axes -> False]
     
    Roger Bagula, Mar 25, 2006
    #2
    1. Advertisements

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.