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*)
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}], 11];
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*)
So far I have done a limited number of experiments
and haven’t correlated them with the corresponding Descartes-Soddy 4 center curvature vectors.
mu=(-a/b)^(1/4)/Sqrt[2]
a/b->{ -2,-3,7/2,29/11,17/6,19/6,13/4…}
The current experiment is:
(* Apollonian gasket disk:mu=(-19/6)^(1/4)/Sqrt[2]*)
mu =
N[(-19/6)^(1/4)]/2^(1/2)
a = {{1, 0}, {-2*mu, 1}}
A = Inverse[{{1, 0}, {-2*mu, 1}}]
b = {{1 - mu, mu}, {-mu, 1 + mu}}
B = Inverse[b]
This program plots the mu points and the curves that they determine.
Their order is:( between 2 and 4)
{2, 29/11, 17/6, 3, 19/6, 13/4, 7/2}
The complex mu are on a 45 degree line.
The curves appear to look like differential equation solutions.
The Descartes -Soddy “coding” problem exists:
how do these rational numbers (a/b) map to the
four vectors {a0,b0,c0,d0}.
(* rational mu Descartes-Soddy numbers*)
w = {2, 3, 7/2, 29/11, 17/6, 19/6,
13/4}
mu[i_] = N[(-w[[i]])^(1/4)]/2^(1/2)
wc = Table[{Re[mu[i]], Im[mu[i]]}, {i, Length[w]}]
(* complex point plots*)
ListPlot[wc, PlotStyle -> Red,
PlotRange -> {{0.5, 0.7}, {0.5, 0.7}}]
(* elliptic curve plots*)
Table[
ParametricPlot[{Re[N[(-w[[i]])^(t/4)]/2^(1/2)],
Im[N[(-w[[i]])^(t/4)]/2^(1/2)]}, {t, 0, 1}, PlotRange -> All,
PlotStyle -> Red], {i, Length[w]}]
Show[%]
(* end*)
That is pretty much the state of my work to the present.
Here is the first picture:
https://i.pinimg.com/564x/fe/73/c4/fe73c4cf70752c66b7cdf870e0733456.jpg
--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)