Message Boards Message Boards

GROUPS:

IFS for apollonian gaskets

Posted 3 years ago
6056 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.

enter image description here

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.apollonian gasket 2 part IFS 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*)

The dipole apollonian gasket 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?

6 Replies

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.

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:

enter image description here

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[
   Developer`ToPackedArray[
    Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]], 
   VertexColors -> Developer`ToPackedArray[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[Developer`ToPackedArray[bb], 
   VertexColors -> Developer`ToPackedArray[cr2 /@ dlst]];
ptlst3 := 
  Point[Developer`ToPackedArray[bb1], 
   VertexColors -> Developer`ToPackedArray[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[Developer`ToPackedArray[dd], 
   VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
ptlst5 := 
  Point[Developer`ToPackedArray[dd1], 
   VertexColors -> Developer`ToPackedArray[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: two scaled quaternonic Klein group breastplate

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.

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[Developer`ToPackedArray[aa],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
ptlst1 :=
Point[Developer`ToPackedArray[aa1],
VertexColors -> Developer`ToPackedArray[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[Developer`ToPackedArray[bb],
VertexColors -> Developer`ToPackedArray[cr2 /@ dlst]];
ptlst3 :=
Point[Developer`ToPackedArray[bb1],
VertexColors -> Developer`ToPackedArray[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[Developer`ToPackedArray[bb0],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
ptlst8 :=
Point[Developer`ToPackedArray[bbb],
VertexColors -> Developer`ToPackedArray[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

Posted 7 months ago
Posted 7 months 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[Developer`ToPackedArray[aa], 
   VertexColors -> Developer`ToPackedArray[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[Developer`ToPackedArray[bb], 
   VertexColors -> Developer`ToPackedArray[cr /@ dlst1]];
ptlst3 := 
  Point[Developer`ToPackedArray[bb1], 
   VertexColors -> Developer`ToPackedArray[cr /@ dlst2]];

g3a = Graphics[{PointSize[.001], ptlst2, ptlst3}, 
  AspectRatio -> Automatic, ImageSize -> 1000, Background -> Black, 
  PlotRange -> {{-3, 3}, {-3, 3}}*4.5/3]

(*end*)
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract