• New tile? Kleinian group affine 3 part tiling...

    From Roger Bagula@21:1/5 to All on Fri Jan 6 07:59:02 2017
    I’m getting old and my memory isn’t all that it should be:
    never was…
    But this appears to be a new 3 transform tiling.
    My effort at tiling using a lower resolution made me
    do this higher resolution version.
    I’m really pretty sure this fractal is a tile.
    (* Mathematica*)
    Clear[cr, cols, cr2, cr3, cr4]
    allColors = ColorData["Legacy"][[3, 1]];
    firstCols = {"LightBlue", "DodgerBlue", "Cyan", "White", "Yellow",
    "LightYellow", "LightPink", "White", "Red", "Tomato", "Pink", "LightPink",
    "Purple", "DarkOrchid", "Magenta", "ManganeseBlue", "DeepNaplesYellow",
    "Orange", "DarkOrange", "Tomato", "GoldOchre", "LightPink", "Magenta",
    "Green", "DarkOrchid", "LightSalmon", "LightPink", "Sienna", "Green",
    "Mint", "DarkSlateGray", "ManganeseBlue", "SlateGray", "DarkOrange",
    "MistyRose", "DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow",
    "Yellow", "Tomato", "DeepNaplesYellow", "DodgerBlue", "Cyan", "Red",
    "Blue", "DeepNaplesYellow", "Green", "Magenta", "DarkOrchid",
    "LightSalmon", "LightPink", "Sienna", "Green", "Mint", "DarkSlateGray",
    "ManganeseBlue", "SlateGray", "DarkOrange", "MistyRose",
    "DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow", "LimeGreen"};
    cols = ColorData["Legacy", #] & /@
    Join[firstCols, Complement[allColors, firstCols]];
    rotate[theta_] := {{Cos[theta], -Sin[theta]}, {Sin[theta], Cos[theta]}};
    cr[n_] := cr[n] = cols[[n]];
    cr2[n_] := cr2[n] = cols[[n + 4]];
    cr3[n_] := cr3[n] = cols[[n + 8]];
    cr4[n_] := cr4[n] = cols[[n + 12]];
    cr5[n_] := cr5[n] = cols[[n + 16]]

    Clear[w, ww, n, m, a0, a, b, A, B]
    a0 = -I
    b0 = Exp[I*2*Pi/3]
    ai = Table[i, {i, -1, 1}]
    s[1] = ({{a0, ai[[1]]}, {0, b0*Sqrt[3]}}/Sqrt[a0])
    s[2] = ({{a0, ai[[2]]}, {0, b0*Sqrt[3]}}/Sqrt[a0])
    s[3] = ({{a0, ai[[3]]}, {0, b0*Sqrt[3]}}/Sqrt[a0])
    s[4] = {{1, 0}, {0, 1}}
    {a, b, A, B} = Table[s[i], {i, 1, 4}]
    Det[a]
    Tr[a]
    Det[b]
    Tr[b]
    Det[A]
    Tr[A]
    Det[B]
    Tr[B]

    Affine[{z1_, z2_}] := 0.00001 Round[(z1/z2)/0.00001];
    Children[{z_, n_}] := {Affine[{a, b, A, B}[[#]].{z, 1}], #} & /@
    Delete[Range[4], {3, 4, 1, 2}[[n]]];
    aa1 = {Re[#[[1]]], Im[#[[1]]]} & /@
    Nest[Union[Flatten[Children /@ #, 1]] &,
    Table[{Affine[{a, b, A, B}[[i]].{0, 1}], i}, {i, 1, 4}], 14];
    ll = Length[aa1]
    Last[aa1]
    aa = Delete[Union[aa1], Length[Union[aa1]]];
    ListPlot[aa, AspectRatio -> Automatic, PlotStyle -> {Black, PointSize[0.001]},
    ImageSize -> 1000, PlotRange -> {{-4, 4}, {-4, 4}}/4]

    dlst = Table[1 + Mod[n, 4], {n, Length[aa]}];
    ptlst = Point[Developer`ToPackedArray[aa],
    VertexColors -> Developer`ToPackedArray[cr3 /@ dlst]];
    g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
    ImageSize -> 1000, Background -> Black, PlotRange -> {{-4, 4}, {-4, 4}}/4]
    (* end*)

    --- SoupGate-Win32 v1.05
    * Origin: fsxNet Usenet Gateway (21:1/5)
  • From Stewart Robert Hinsley@21:1/5 to Roger Bagula on Thu Jan 12 19:17:25 2017
    On 06/01/2017 15:59, Roger Bagula wrote:
    I’m getting old and my memory isn’t all that it should be:
    never was…
    But this appears to be a new 3 transform tiling.
    My effort at tiling using a lower resolution made me
    do this higher resolution version.
    I’m really pretty sure this fractal is a tile.

    I can usually manage to extract an IFS from your Mathematica code, but
    this time my lack of knowledge of Mathematica defeats me. You'd have a
    better chance of a response if you gave a link to an image, or stated
    the IFS explicitly.

    References to sqrt(3) and 2pi/3 leads me to suspect that you have a
    trihextal - one of the set including the terdragon, fudgeflake and
    possibly hundreds of other order 3 tiles.

    --
    SRH

    --- SoupGate-Win32 v1.05
    * Origin: fsxNet Usenet Gateway (21:1/5)