Message Boards Message Boards

IFS for apollonian gaskets

GROUPS:

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?

POSTED BY: Roger L. Bagula
Answer
2 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.

POSTED BY: Vitaliy Kaurov
Answer
2 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:

enter image description here

POSTED BY: Sam Carrettie
Answer
2 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[
   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.

POSTED BY: Roger L. Bagula
Answer
2 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[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 BY: Roger L. Bagula
Answer
2 years ago
Attachments:
POSTED BY: Roger Bagula
Answer
24 days 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*)
POSTED BY: Roger Bagula
Answer
24 days ago

Group Abstract Group Abstract