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)