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 Stanges 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*)
