An online animation gif:
made me do a search for apollonian gaskets in Mathematica.
I have this very old IFS that is updated:
(* Mathematica*)
Clear[f, dlst, pt, cr, ptlst]
dlst = Table[ Random[Integer, {1, 2}], {n, 220000}];
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"Red", "ManganeseBlue", "Blue", "Magenta", "Green",
"DarkOrchid", "LightSalmon", "LightPink", "Sienna", "Green",
"Mint", "DarkSlateGray", "ManganeseBlue", "SlateGray",
"DarkOrange", "MistyRose", "DeepNaplesYellow", "GoldOchre",
"SapGreen", "Yellow"};
cols = ColorData["Legacy", #] & /@
Join[firstCols, Complement[allColors, firstCols]];
s = Sqrt[3];
z = x + I*y;
f1a[z_] = ComplexExpand[ 3 / ( 1 + s - z) - (1 + s) / (2 + s)];
f2a[z_] = ComplexExpand[ f1a[z] (-1 + s *I) / 2];
f3a[z_] = ComplexExpand[ f1a[z] (-1 - s *I) / 2];
f[1, {x_, y_}] = N[{Re[f1a[z]], Im[f1a[z]]}];
f[2, {x_, y_}] =
N[{Re[f2a[z]],
Im[f2a[z]]}/({Re[f2a[z]], Im[f2a[z]]}.{Re[f2a[z]], Im[f2a[z]]})];
pt = {0.5, 0.5};
cr[n_] := cr[n] = cols[[n]];
ptlst = Point[
Developer`ToPackedArray[
Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
PlotRange -> {{-4, 6}, {-5, 5}}, ImageSize -> 1000]
(* end*)
But that doesn’t give the Penny, nickle, dime type number theory gaskets
that mostly use a circles type definition like the MathWorld entry.
A second dipole type apollonian gasket is made by a comformal mapping approach:
(*Mathematica*)
Clear[a, aa]
a = ComplexExpand[ (-1 + x + I*y)/(1 + (x + I*y))]
w[i_] = {Re[a], Im[a]} /. x -> aa[[i, 1]] /. y -> aa[[i, 2]]
Clear[f, dlst, pt, cr, ptlst]
dlst = Table[ Random[Integer, {1, 4}], {n, 50000}];
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"Red", "Cyan", "Blue", "Magenta", "Green", "DarkOrchid",
"LightSalmon", "LightPink", "Sienna", "Green", "Mint", "DarkSlateGray",
"ManganeseBlue", "SlateGray", "DarkOrange", "MistyRose",
"DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow"};
cols = ColorData["Legacy", #] & /@
Join[firstCols, Complement[allColors, firstCols]];
s = Sqrt[3];
z = x + I*y;
f1a[z_] = ComplexExpand[ 3 / ( 1 + s - z) - (1 + s) / (2 + s)];
f2a[z_] = ComplexExpand[ f1a[z] (-1 + s *I) / 2];
f3a[z_] = ComplexExpand[ f1a[z] (-1 - s *I) / 2];
f[1, {x_, y_}] = N[{Re[f1a[z]], Im[f1a[z]]}];
f[2, {x_, y_}] = N[{Re[f2a[z]], Im[f2a[z]]}];
f[3, {x_, y_}] = N[{Re[f3a[z]], Im[f3a[z]]}];
f[4, {x_, y_}] =
N[{Re[f1a[z]],
Im[f1a[z]]}/({Re[f1a[z]], Im[f1a[z]]}.{Re[f1a[z]], Im[f1a[z]]})];
pt = {0.5, 0.5};
cr[n_] := cr[n] = cols[[n]];
aa = Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}];
bb = Table[{-2 Im[aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
Re[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)],
Im[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
2 Re[aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)]}, {i, Length[aa]}];
ListPlot[bb, PlotStyle -> {PointSize -> 0.001, Red}, ImageSize -> 1000]
ptlst2 = Point[Developer`ToPackedArray[bb],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g1 = Graphics[{PointSize[.001], ptlst2}, AspectRatio -> Automatic,
PlotRange -> {{-1.8, 1.8}, {-1.8, 1.8}}, ImageSize -> 1000]
ptlst = Point[
Developer`ToPackedArray[Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
PlotRange -> All, ImageSize -> 1000]
(* end*)
This post is my first in this community/ group. I was wondering if there was a way to get
an {28,24,21} integral apollonian gasket into my IFS besides my crude scaling method?
