# IFS for apollonian gaskets

Posted 4 years ago
7132 Views
|
6 Replies
|
11 Total Likes
|
 An online animation gif: http://militzer.berkeley.edu/EPS109/apollonian7.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[ DeveloperToPackedArray[ Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]], VertexColors -> DeveloperToPackedArray[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[DeveloperToPackedArray[bb], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; g1 = Graphics[{PointSize[.001], ptlst2}, AspectRatio -> Automatic, PlotRange -> {{-1.8, 1.8}, {-1.8, 1.8}}, ImageSize -> 1000] ptlst = Point[ DeveloperToPackedArray[Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]], VertexColors -> DeveloperToPackedArray[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?
Answer
6 Replies
Sort By:
Posted 4 years ago
 Welcome to Wolfram Community, Roger, thanks for sharing your apollonian gaskets! You by the way can add animated GIFs as any images - I added it to your post, along with a few related groups.
Answer
Posted 4 years ago
 Question is out of my league, but perhaps this may come handy: Apollonian Gasket and The Circles of Descartes. There is also this and this:
Answer
Posted 4 years ago
 A new algorithm developed from Indra's Pearl's type of Klein groups plotted as IFS: (* mathematica*) (* advanced Klein group SL(2,c) apollonian fractals*) \ Clear[f, dlst, pt, cr, ptlst, ptlst2, cr2] dlst = Table[ Random[Integer, {1, 8}], {n, 50000}]; allColors = ColorData["Legacy"][[3, 1]]; firstCols = {"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]]; s = Sqrt[3]; z = x + I*y; (*two scales quaternonic 4 matrix Klein group*) c0 = (3/4)^2 c1 = (1)^2 a = {{I*2*Sqrt[c1], I}, {I, 0}} a1 = Inverse[a] c = {{1, I*2*Sqrt[c0]}, {0, 1}} b = N[{{1, 0}, {I*2*Sqrt[c0], 1}}] b1 = Inverse[b] d = N[{{0, I}, {I, I*2*Sqrt[c1]}}] c1 = Inverse[c] d1 = Inverse[d] f1a[z_] = ComplexExpand[(a[[1, 1]]*z + a[[1, 2]])/(a[[2, 1]]*z + a[[2, 2]])]; f2a[z_] = ComplexExpand[(b[[1, 1]]*z + b[[1, 2]])/(b[[2, 1]]*z + b[[2, 2]])]; f3a[z_] = ComplexExpand[(c[[1, 1]]*z + c[[1, 2]])/(c[[2, 1]]*z + c[[2, 2]])]; f4a[z_] = ComplexExpand[(d[[1, 1]]*z + d[[1, 2]])/(d[[2, 1]]*z + d[[2, 2]])]; f5a[z_] = ComplexExpand[(a1[[1, 1]]*z + a1[[1, 2]])/(a1[[2, 1]]*z + a1[[2, 2]])]; f6a[z_] = ComplexExpand[(b1[[1, 1]]*z + b1[[1, 2]])/(b1[[2, 1]]*z + b1[[2, 2]])]; f7a[z_] = ComplexExpand[(c1[[1, 1]]*z + c1[[1, 2]])/(c1[[2, 1]]*z + c1[[2, 2]])]; f8a[z_] = ComplexExpand[(d1[[1, 1]]*z + d1[[1, 2]])/(d1[[2, 1]]*z + d1[[2, 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[f4a[z]], Im[f4a[z]]}]; f[4, {x_, y_}] = N[{Re[f4a[z]], Im[f4a[z]]}]; f[5, {x_, y_}] = N[{Re[f5a[z]], Im[f5a[z]]}]; f[6, {x_, y_}] = N[{Re[f6a[z]], Im[f6a[z]]}]; f[7, {x_, y_}] = N[{Re[f7a[z]], Im[f7a[z]]}]; f[8, {x_, y_}] = N[{Re[f8a[z]], Im[f8a[z]]}]; pt = {0.5, 0.5}; cr[n_] := cr[n] = cols[[n]] cr2[n_] := cr2[n] = cols[[4 + n]] ptlst := Point[ DeveloperToPackedArray[ Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic, PlotRange -> {{-3, 3}, {-3, 3}}, ImageSize -> 1000] (* half plane to disk: gives a strip up the y axis*) aa = Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]; bb = Table[{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)], -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)]}, {i, Length[aa]}]; bb1 = Table[{-(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)]), -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)]}, {i, Length[aa]}]; ListPlot[{bb, bb1}, PlotStyle -> {{Red, PointSize[0.001]}, {Blue, PointSize[0.001]}}, ImageSize -> 1000] ptlst2 := Point[DeveloperToPackedArray[bb], VertexColors -> DeveloperToPackedArray[cr2 /@ dlst]]; ptlst3 := Point[DeveloperToPackedArray[bb1], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; g3 = Graphics[{PointSize[.001], ptlst3, ptlst2}, AspectRatio -> Automatic, PlotRange -> {{-3.5, 3.5}, {-3.5, 3.5}}, ImageSize -> 1000] Show[g3, Background -> Black] (* pharoah's breastplate conformal map:take a strio to an disk around \ a line a Sqrt[5]: Mandelbrot book cover algorithm *) aa = bb; r = N[Sqrt[5.0]]; d = N[0.01]; dd = Table[{aa[[i, 2]]/(d + {aa[[i, 1]] + r, aa[[i, 2]]}.{aa[[i, 1]] + r, aa[[i, 2]]}), -(r + aa[[i, 1]])/(d + {aa[[i, 1]] + r, aa[[i, 2]]}.{aa[[i, 1]] + r, aa[[i, 2]]})}, {i, Length[bb]}]; dd1 = Table[{-aa[[i, 2]]/(d + {aa[[i, 1]] + r, aa[[i, 2]]}.{aa[[i, 1]] + r, aa[[i, 2]]}), -(r + aa[[i, 1]])/(d + {aa[[i, 1]] + r, aa[[i, 2]]}.{aa[[i, 1]] + r, aa[[i, 2]]})}, {i, Length[bb]}]; ListPlot[{dd, dd1}, PlotStyle -> {{PointSize -> 0.001, Red}, {PointSize -> 0.001, Cyan}}, ImageSize -> 1000] ptlst4 := Point[DeveloperToPackedArray[dd], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; ptlst5 := Point[DeveloperToPackedArray[dd1], VertexColors -> DeveloperToPackedArray[cr2 /@ dlst]]; g5 = Graphics[{PointSize[.001], ptlst5, ptlst4}, AspectRatio -> Automatic, PlotRange -> {{-0.65, 0.65}, {-1.2, 0.1}} , ImageSize -> 1000, Background -> Black] (* end*) The picture: Not the same as the 4 integer number theory apollonian gaskets, but very pretty as a #fractal! I tried this sort of program with four individual scales, but the result is distorted circles, not apollonian at all. I'm posting this because it gives Mathematica something no other program has right now: complex Klein group IFS.
Answer
Posted 3 years ago
 elliptical based apollonian Roger Bagula Nov 30 This actually is an advance over the polynomial approach as there is more control in scaled elliptic functions: Wile’s used elliptical functions in his Fermat conjecture proof... Although this tiles 4 fold in the half plane to disk: the center of the breastplate conformal map is 8 fold. (* Mathematica*) N[Abs[(3*Cos[2*Pi/3] - 2*I*Sin[2*Pi/3])]] wa = N[(3*Cos[2*Pi/3] - 2*I*Sin[2*Pi/3])/GoldenRatio] wb = N[(3*Cos[2*Pi/3] + 2*I*Sin[2*Pi/3])/GoldenRatio] a = {{I, wa}, {0, -I}} b = {{1, 0}, {wb, 1}} (* mathematica*) Clear[f, dlst, pt, cr, ptlst, ptlst2, cr, cr2, cols, x, y, \ z, s, a, q, a, b, c, d] dlst = Table[ Random[Integer, {1, 4}], {n, 500000}]; allColors = ColorData["Legacy"][[3, 1]]; firstCols = {"DeepNaplesYellow", "Tomato", "DarkOrange", "Yellow", "ManganeseBlue", "Blue", "DodgerBlue", "Cyan", "Green", "Magenta", "DarkOrchid", "Green", "Red", "Yellow", "Blue", "LightSalmon", "LightPink", "Mint", "ManganeseBlue", "DarkOrange", "MistyRose", "DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow", "LimeGreen", "Red", "Blue", "Sienna", "DarkSlateGray", "SlateGray", "Green"}; cols = ColorData["Legacy", #] & /@ Join[firstCols, Complement[allColors, firstCols]]; s = Sqrt[3]; z = x + I*y; f1a[z_] = ComplexExpand[(I*z + wb)/(-I)]; f2a[z_] = ComplexExpand[z/(z*wa + 1)]; f3a[z_] = ComplexExpand[f1a[z]*Exp[-I*2*Pi/3]]; 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[f1a[z]], Im[f1a[z]]}/({Re[f1a[z]], Im[f1a[z]]}.{Re[f1a[z]], Im[f1a[z]]})]; f[4, {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_] := cols[[n]] cr2[n_] := cols[[n + 2]] aa = Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]; aa1 = Table[-aa[[i]], {i, Length[aa]}]; ptlst0 := Point[DeveloperToPackedArray[aa], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; ptlst1 := Point[DeveloperToPackedArray[aa1], VertexColors -> DeveloperToPackedArray[cr2 /@ dlst]]; g2 = Graphics[{PointSize[.001], ptlst0}, AspectRatio -> Automatic, PlotRange -> {{-3, 3}, {-3, 3}}, ImageSize -> 1000, Background -> Black] (* half plane to disk*) aa = Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]; bb = Table[{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)], -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)]}, {i, Length[aa]}]; bb1 = Table[{-(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)]), -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)]}, {i, Length[aa]}]; ListPlot[{bb, bb1}, PlotStyle -> {{Red, PointSize[0.001]}, {Blue, PointSize[0.001]}}, ImageSize -> 1000] ptlst2 := Point[DeveloperToPackedArray[bb], VertexColors -> DeveloperToPackedArray[cr2 /@ dlst]]; ptlst3 := Point[DeveloperToPackedArray[bb1], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; g3 = Graphics[{PointSize[.001], ptlst2}, AspectRatio -> Automatic, PlotRange -> {{-8, 8}, {-8, 8}}, ImageSize -> 1000] Show[g3, Background -> Black] g5 = Graphics[{PointSize[.001], ptlst5, ptlst4}, AspectRatio -> Automatic, PlotRange -> {{-1.25, 1.25}, {-2.0, 0.5}} , ImageSize -> {1000, 1000}, Background -> Black] (* Gaussian sphere {x,y}*) bb0 = Table[{2* aa[[i, 1]]/(1 + {aa[[i, 1]], aa[[i, 2]]}.{aa[[i, 1]], aa[[i, 2]]}), 2*aa[[i, 2]]/(1 + {aa[[i, 1]], aa[[i, 2]]}.{aa[[i, 1]], aa[[i, 2]]})}, {i, Length[aa]}]; bbb = Table[{-2* aa[[i, 1]]/(1 + {aa[[i, 1]], aa[[i, 2]]}.{aa[[i, 1]], aa[[i, 2]]}), 2*aa[[i, 2]]/(1 + {aa[[i, 1]], aa[[i, 2]]}.{aa[[i, 1]], aa[[i, 2]]})}, {i, Length[aa]}]; ptlst7 := Point[DeveloperToPackedArray[bb0], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; ptlst8 := Point[DeveloperToPackedArray[bbb], VertexColors -> DeveloperToPackedArray[cr2 /@ dlst]]; g1 = Graphics[{PointSize[.001], ptlst7, ptlst8}, AspectRatio -> Automatic, PlotRange -> {{-1.1, 1.1}, {-1.1, 1.1}}, ImageSize -> {1000, 1000}, Background -> Black] (*Export["3_2elliptic_Roger_Bagula.jpg",g1]*) (* end*) https://groups.yahoo.com/neo/groups/Active_Mathematica/conversations/messages/5010 cid:D6ADB135-395E-46A8-95C0-8C17A62D54CE@attlocal.net
Answer
Posted 1 year ago
 Attachments:
Answer
Posted 1 year ago
 This morning I found a way to get Kleinian groups limit sets for some of the uneven Apollonian coin packings: I have three good ones so far: my post online.An uneven coin type Apollonian as a Bianchi -Clifford base: This kind of Apollonian disk has been a long term problem: I asked and no one knew a Kleinian group for this sort. of circle packing. I did extensive searches, nothing…Kate Stange’s Bianchi group paper was my first real clue. I had to develop a whole new Blaschke disk-Banach space approach as an Clifford base Hilbert space to finally crack this mystery! The group uses (-3)^(1/4), the second Clifford base for -3 : (* Apollonian gasket disk:mu=(-3)^(1/4)*) mu = N[(-3)^(1/4)]/Sqrt[2] a = {{1, 0}, {-2*mu, 1}} A = Inverse[{{1, 0}, {-2*mu, 1}}] b = {{1 - mu, mu}, {-mu, 1 + mu}} B = Inverse[b] The Clifford base Hilbert space of: (-1)^(t/2^n) lead to the Bianchi generalization of Hilbert spaces: (-Prime[n])^(t/2^n) and they all plotted to Prime[60].As far as I know this approach in entirely new. (* mathematica: using ![enter image description here][1]Paul Nylander's Limit set program*) Clear[cr, cols, cr2, cr3, cr4, firstCols, s, s0] allColors = ColorData["Legacy"][[3, 1]]; firstCols = {"White", "AliceBlue", "LightBlue" , "Cyan", "ManganeseBlue", "DodgerBlue" , "Blue", "Magenta", "Purple", "Pink", "Tomato", "Red", "DarkOrange", "Orange", "DeepNaplesYellow", "Gold", "Banana", "Yellow", "LightYellow", "Orange", "Pink", "LightPink", "Yellow", "LightYellow", "LightPink", "White", "DeepNaplesYellow", "Orange", "DarkOrange", "Tomato", "Red", "Tomato", "Pink", "LightPink", "DeepNaplesYellow", "Orange", "DarkOrange", "Tomato", "White", "Pink", "Banana", "LightBlue", "DodgerBlue", "Cyan", "White", "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[mu, a, b, A, B] (* Apollonian gasket disk:mu=(-3)^(1/4)*) mu = N[(-3)^(1/4)]/Sqrt[2] a = {{1, 0}, {-2*mu, 1}} A = Inverse[{{1, 0}, {-2*mu, 1}}] b = {{1 - mu, mu}, {-mu, 1 + mu}} B = Inverse[b] Det[a] Tr[a] Det[b] Tr[b] Det[A] Tr[A] Det[B] Tr[B] Affine[{z1_, z2_}] := 0.000001 Round[(z1/z2)/0.000001]; 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}], 13]; ll = Length[aa1] Last[aa1] aa = Delete[Union[aa1], Length[Union[aa1]]]; ListPlot[aa, AspectRatio -> Automatic, PlotStyle -> {Black, PointSize[0.001]}, ImageSize -> 1000, PlotRange -> All] dlst = Table[ Floor[1 + (1 + Floor[4*Norm[aa[[i]]]])/(Abs[ Cos[Arg[aa[[i, 1]] + I*aa[[i, 2]]]]] + Abs[Sin[Arg[aa[[i, 1]] + I*aa[[i, 2]]]]])], {i, Length[aa]}]; Min[dlst] Max[dlst] ptlst = Point[DeveloperToPackedArray[aa], VertexColors -> DeveloperToPackedArray[cr /@ dlst]]; g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic, ImageSize -> 1500, Background -> Black, PlotRange -> All] (* endend limit set*) (* Half plane to disk conformal map*) bb = Delete[ Union[Table[{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)], -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)]}, {i, Length[aa]}]], Length[aa]]; bb1 = Delete[ Union[Table[{-(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)]), -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)]}, {i, Length[aa]}]], Length[aa]]; dlst1 = Table[ Floor[1 + (1 + Floor[5*Norm[bb[[i]]]])/(Abs[ Cos[Arg[bb[[i, 1]] + I*bb[[i, 2]]]]] + Abs[Sin[Arg[bb[[i, 1]] + I*bb[[i, 2]]]]])], {i, Length[bb]}]; Min[dlst1] Max[dlst1] dlst2 = Table[ Floor[1 + (1 + Floor[5*Norm[bb1[[i]]]])/(Abs[ Cos[Arg[bb1[[i, 1]] + I*bb1[[i, 2]]]]] + Abs[Sin[Arg[bb1[[i, 1]] + I*bb1[[i, 2]]]]])], {i, Length[bb1]}]; Min[dlst2] Max[dlst2] ListPlot[{bb, bb1}, PlotStyle -> {{Red, PointSize[0.001]}, {Orange, PointSize[0.001]}}, ImageSize -> 1000, Axes -> True, PlotRange -> {{-4, 4}, {-4, 4}}*1.5, Background -> White] ptlst2 := Point[DeveloperToPackedArray[bb], VertexColors -> DeveloperToPackedArray[cr /@ dlst1]]; ptlst3 := Point[DeveloperToPackedArray[bb1], VertexColors -> DeveloperToPackedArray[cr /@ dlst2]]; g3a = Graphics[{PointSize[.001], ptlst2, ptlst3}, AspectRatio -> Automatic, ImageSize -> 1000, Background -> Black, PlotRange -> {{-3, 3}, {-3, 3}}*4.5/3] (*end*) 
Answer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments