• Kleinian groups for the Descartes-Soddy uneven Apollonian circle packin

    From Roger Bagula@21:1/5 to All on Sun May 27 08:38:58 2018
    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)