This file performs computations related to some notes on elliptic curves (http://www.math.su.se/~teke/elliptic_curves.pdf).

Off[General::spell1];
Protect[q];

We start by by proving Euler's addition theorem for elliptic integrals. We work with two variable points (r,s) and (u,v) and let (x,y) be the third intersection point:

<<  Graphics`ImplicitPlot`

Show[
      ImplicitPlot[{(w^2) == (z^3) - z, 
          w == (1/2) (z + 1)}, {z, -1.5, 1.8}, 
        AspectRatio  ->  1, Axes  ->  False, 
        DisplayFunction  ->  Identity], 
      Graphics[{Disk[{-1, 0}, 0.03], 
          Text["(r,s)", {-1, -0.1}, {-1, 
              0}], 
Disk[{-0.1753, 
              0.5 (1 + -0.1753)}, 
            0.03], 
Text["(u,v)", {-0.1753 + 0.05, 
              0.5 (1 + -0.1753) - 0.05}, {-1, 
              0}], 
Disk[{1.4253, 0.5 (2.4253)}, 
            0.03] , 
Text["(x,y)", {1.4253 + 0.05, 
              0.5 (2.4253) - 0.05}, {-1, 
              0}], 
Line[{{-1.5, -0.25}, {2, 
                1.5}}]}], 
AspectRatio ->  Automatic, 
      DisplayFunction  ->  $DisplayFunction]

(x,y) then fulfills the relations:

(y^2) ==  (x^3) + a x + b;
y - 
          s  ==  ((v - s)/(u - r)) (x - r);

These have as a consequence the relations:

(((((v - s)/(u - r))))^2) ==  
        u + x + r;
y - 
          s  ==  ((v - s)/(u - r)) (x - r);

They are resolved into defining relations for x and y as follows:

x  =  (((((v - s)/(u - r))))^2) - u - 
          r;
y  =  ((v - s)/(u - r)) (x - r) + s;

Having taken care of that we start by imposing the relations that the coordinates r, s, u, and v fulfill, as well as introducing the function ratred that reduces a fraction according to some relations by reducing numerator and denominator separately:

vars  =  {s, v, r, u};
bas  =  
        GroebnerBasis[{(v^2) - ((u^3) + a u + b), 
            (s^2) - ((r^3) + a r + b)}, 
          vars];
polred[l_List, bas_, vars_]  :=  polred[#, bas, vars] &  /@  
          l;
ratred[l_List, bas_, vars_]  :=  ratred[#, bas, vars] &  /@  
          l;
polred[p_, bas_, 
          vars_]  :=  PolynomialReduce[p, bas, 
            vars][[2]];
ratred[r_, bas_, vars_]  :=  
        Module[{rr  =  Together[r]}, 
polred[
              Numerator[rr], bas, vars]/
            polred[Denominator[rr], bas, vars]];

We then define deriv that takes the derivative of an expression with respect to two variables that fulfill the relation for being a point on the curve:

deriv[p_, {u_, v_}]  :=  
        D[p, u]  +  D[p, v] (3  (u^2) + a)/(2  v);

Finally, we verify Euler's relation (dx/y) + (du/v) + (dr/s) = 0.

{ratred[ deriv[x, {r, s}]/y  + 1/s, bas, 
        vars], 
ratred[ deriv[x, {u, v}]/y  + 1/v, bas, 
        vars]}

We then clear our variables so that we may later, if we wish, use them as variables.

Clear[x, y];

The following verifies the differential equation for ℘:

Module[{℘}, 
℘  =  
        Series[(1/(z^2)) + ((Subscript[g, 2])/20) (z^2) + ((Subscript[g, 3])/28) (z^4), {z, 0, 
            4}]; 
D[℘, z]^2 - (4  (℘^3) - (Subscript[g, 2]) ℘ - (Subscript[g, 3]))]

If we want to see how the (Subscript[G, n])'s can be expressed in terms of (Subscript[g, 2])and (Subscript[g, 3])we can do the following calculation.

p  =  
        Series[(1/(z^2)) + Sum[(Subscript[h, i]) (z^(2 i)), {i, 1, 7}], {z, 0, 
            14}];
(Table[(Subscript[h, i]), {i, 1, 7}] /. 
            Solve[D[p, z]^2 == 4  (p^3) - (Subscript[g, 2]) p - (Subscript[g, 3]), 
              Table[(Subscript[h, i]), {i, 1, 
                  7}]])[[1]] (1/
          Table[2  n - 1, {n, 2, 8}])

Here we express the third derivative of ℘ by differentiating the the differential equation twice.

D[D[℘'[z]^2 - (4  ℘[z]^3 - (Subscript[g, 2]) ℘[z] + (Subscript[g, 3])), z]/℘'[z] , z]/2  //  
      Simplify

The following calculation shows that the addition formula is holomorphic at u=0.

Module[{p, q},
p  =  Series[(1/(u^2)), {u, 0, 1}];
q  =  
            Series[℘[u + v], {u, 0, 2}];
Det[(({{p, D[p, u], 1}, {℘[v], ℘'[v], 1}, {q, -D[q, u], 1}}))]]

Here we check directly that the Möbius transformations mentioned form a group. Matrices are easier to compose though. Remember however that G and -G give the same Möbius transformation.

G = {(({{1, 0}, {0, 1}})),(({{0, 1}, {1, 0}})),(({{-1, 1}, {0, 1}})),(({{0, 1}, {-1, 1}})),(({{1, 0}, {1, -1}})),(({{1, -1}, {1, 0}}))};
GG  =  
        Join[G, -G];
MemberQ[GG, 
          G[[#[[1]]]]  .  
            G[[#[[2]]]]]  &  /@  
      Flatten[Table[{i, j}, {i, 1, 5}, {j, 1, i}], 1]

We then construct the Möbius transformations themselves

\(M\  = \ \(#[[1]] . {λ, 1}\/#[[2]] . {λ, 1} &\)\  /@ \ 
          G\  // \ Simplify\)

and consider the polynomial that have them as roots.

ll = (Together  /@  
          CoefficientList[
            Product[t - M[[i]], {i, 1, 
                6}], t] )

We then check that we get the j-invariant from the third coefficient

(2^8) (6 - 
            ll[[3]])  //   Factor

and check that the middle coefficient can be expressed as 2j-7:

ll[[4]]  - (2^(-7)) ((2^8) (6 - ll[[3]]))  //  
      Together

We now define invariants by completing the cube of the polynomial and picking out the coefficients (and then scaling by -4  to get what we want to mean by (Subscript[g, 2])and (Subscript[g, 3])).

{(Subscript[g, 3]), 
        (Subscript[g, 2])}  =  -4 CoefficientList[
            (t^3) + b (t^2) + c t + d /. t  ->  t - (b/3) , 
            t][[{1, 2}]]

and even though it can be proven by ``pure thought'' that they are invariant under x ↦ x+s we verify directly that they are invariant.

({(Subscript[g, 2]), (Subscript[g, 3])} /. {b  ->  b + 3 s, 
              c ->  c + 2 b s + 3 (s^2), 
              d  ->  d + c s + b (s^2) + (s^3)} ) - {(Subscript[g, 2]), 
          (Subscript[g, 3])}  //  Simplify

Here we check that when applied to x(x-1)(x-λ) we get the evaluation that we want.

Factor  /@ ({(Subscript[g, 2]), (Subscript[g, 3]), 
            ((Subscript[g, 2])^3) - 
              27 ((Subscript[g, 3])^2), ((1728 ((Subscript[g, 2])^3))/(((Subscript[g, 2])^3) - 27 ((Subscript[g, 3])^2)))} /. {b ->  -λ - 1, c ->  λ, 
            d ->  0} )

We define Eisenstein to give the q-expansion of the functions (Subscript[E, k]) and GEisenstein to give the q-expansion of (Subscript[G, k]).

Eisenstein[k_, q_, o_]  :=  
Series[
          1 -  ((4 k)/BernoulliB)[2  k] 
              Sum[DivisorSigma[2  k - 1, n] (q^n), {n, 1, o}], {q, 0, 
            o}];
GEisenstein[k_, q_, o_]  :=  
        2 Zeta[2  k] Eisenstein[k, q, o];

We can now look at the q-expansion of the j-function.

j[q_, 
          n_]  := 
Module[{E2, 
            E3}, 
E2  =  
            Eisenstein[2, q, n + 1]^3; 
E3  =  
            Eisenstein[3, q, n + 1]^2; 
1728 
             (E2/(E2 - E3))];

j[q, 5]

We want to check that the expressions in the coefficients of the general equation for an elliptic defining Δ and j really gives the same quantities as the old ones. We start by writing down the polynomial.

Clear[x, y, g, a, Δ, j, 
        p];
p  =  
        y^2 + (Subscript[a, 1]) x y + (Subscript[a, 3]) 
            y - ((x^3) + (Subscript[a, 2]) (x^2) + (Subscript[a, 4]) x + (Subscript[a, 6]));

We then complete squares to get rid of the xy- and y-terms.

p = 
        p /. {y  ->  
              y - ((Subscript[a, 1])/2) x - ((Subscript[a, 3])/2)};
{Coefficient[p, x y], Coefficient[p, y], 
      Coefficient[p, (x^2)]}

We then get rid of the (x^2)-coefficient.

p  =  
        (y^2) - p /. {x ->  
              x - ((Subscript[a, 1]^2)/12) - ((Subscript[a, 2])/3)};
Coefficient[p, ((x )^2)]

The next step is to pick out (Subscript[g, 2])and (Subscript[g, 3])and define Δ and j in terms of them.

{(Subscript[g, 3]), 
          (Subscript[g, 2])}  =  -4 CoefficientList[p, x][[{1, 
              2}]];
(Subscript[Δ, 1]) =  
        (Subscript[g, 2]^3) - 27 (Subscript[g, 3]^2);
(Subscript[j, 1]) = 1728 ((Subscript[g, 2]^3)/(Subscript[Δ, 1]));

We now start afresh and use the formulas that directly defines Δ and j in terms of the coefficients.

(Subscript[b, 2]) =  (Subscript[a, 1]^2) + 4  (Subscript[a, 2]);
(Subscript[b, 4]) =  (Subscript[a, 1]) (Subscript[a, 3]) + 2  (Subscript[a, 4]);
(Subscript[b, 6]) =  (Subscript[a, 3]^2) + 4  (Subscript[a, 6]);
(Subscript[b, 8]) =  (Subscript[a, 1]^2) (Subscript[a, 6]) - (Subscript[a, 1]) (Subscript[a, 3]) (Subscript[a, 4]) + 
          4  (Subscript[a, 2]) (Subscript[a, 6]) + (Subscript[a, 2]) (Subscript[a, 3]^2) - (Subscript[a, 4]^2);
(Subscript[c, 4]) =  (Subscript[b, 2]^2) - 24  (Subscript[b, 4]);
(Subscript[c, 6]) = -(Subscript[b, 2]^3) + 36  (Subscript[b, 2]) (Subscript[b, 4]) - 
          216  (Subscript[b, 6]);
(Subscript[Δ, 2])  = -(Subscript[b, 2]^2) (Subscript[b, 8]) - 8  (Subscript[b, 4]^3) - 27  (Subscript[b, 6]^2) + 
          9  (Subscript[b, 2]) (Subscript[b, 4]) (Subscript[b, 6]);
(Subscript[j, 2])  =  ((Subscript[c, 4]^3)/(Subscript[Δ, 2]));

Finally, we compare these two expressions.

{(Subscript[Δ, 1]) -  (Subscript[Δ, 2]), (Subscript[j, 1]) - (Subscript[j, 2])}   //  
      ExpandAll

Here we check that the coordinate transformations act on the a's in the claimed manner.

Clear[r, s, t, u, x, y, a];
transs  =  {x  ->  (u^2) x + r, 
          y  ->  (u^3) y + s (u^2) x + 
              t};
m  =  {(Subscript[a, 1]), (Subscript[a, 3]), (Subscript[a, 2]), (Subscript[a, 4]), (Subscript[a, 6])};
p  =  
        y^2 + (Subscript[a, 1]) x y + (Subscript[a, 3]) 
            y - ((x^3) + (Subscript[a, 2]) (x^2) + (Subscript[a, 4]) x + 
              (Subscript[a, 6]));
q  =  p /. transs;
n  = (u^(-6)) 
            Join[{Coefficient[q, x y], 
                Coefficient[q /. x -> 0, 
                  y]}, 
-Coefficient[
                  q /. y -> 0, {(x^2), 
                    x}], 
{-q /. {x -> 0, 
                    y -> 0}}]  //  
          Factor  ;
atranss  = Inner[Rule, m, n, List];
atranss  //  MatrixForm

Then we check that the b's transform as claimed.

btranss  = 
{
(Subscript[B, 2]) ->  (u^(-2)) ( (Subscript[b, 2]) + 
                  12  r), 
(Subscript[B, 4]) ->  (u^(-4)) ( (Subscript[b, 4]) + r (Subscript[b, 2]) + 
                  6  (r^2)), 
(Subscript[B, 6]) ->  (u^(-6)) ( (Subscript[b, 6]) + 2  r (Subscript[b, 4]) + (r^2) (Subscript[b, 2]) + 
                  4  (r^3)), 
(Subscript[B, 8]) ->  (u^(-8)) ( (Subscript[b, 8]) + 3  r (Subscript[b, 6]) + 3  (r^2) (Subscript[b, 4]) + (r^3) (Subscript[b, 2]) + 
                  3  (r^4))
};
({(Subscript[b, 2]), (Subscript[b, 4]), (Subscript[b, 6]), (Subscript[b, 8])} /. 
            atranss)  -  ({(Subscript[B, 2]), (Subscript[B, 4]), (Subscript[B, 6]), (Subscript[B, 8])} /. btranss) //  
      Simplify

Finally, we check the c's and Δ.

({(u^4) (Subscript[c, 4]), (u^6) (Subscript[c, 6]), (u^12) (Subscript[Δ, 2])} /. 
            atranss)  -  {(Subscript[c, 4]), (Subscript[c, 6]), (Subscript[Δ, 2])}  //  
      Simplify

To compute the modular polynomial för n=2 we start by computing the modular modulo the appropriate power of q.

k  =  j[q, 8];
k1  =  Normal[k];
kk = Series[(t - k1 /. 
              q ->  (q^(1/2))) (t - k1 /. 
              q ->  -(q^(1/2))) (t - k1 /. 
              q ->  (q^2)), {q, 0, 1}]

We then successively subtract off appropriate powers of j:

kk  - ( 
          (k^3) + (-162000 + 1488 t - (t^2)) 
              (k^2) + (8748000000 + 40773375 t + 1488 (t^2)) k - 
            157464000000000 + 8748000000 t - 162000 (t^2) + (t^3))  //  
      ExpandAll

This is then turned into a polynomial in s and t.

ff  =  
      (s^3) + (-162000 + 1488 t - (t^2)) 
            (s^2) + (8748000000 + 40773375 t + 1488 (t^2)) s - 
          157464000000000 + 8748000000 t - 162000 (t^2) + (t^3) //  
        Expand

Now we make a function which gives reduced (i.e., in the fundamental domain) representatives for the lattices whose complex mutliplications is the order of discriminant -D.

reducedQ[{a_, b_, c_}, D_] := 
        IntegerQ[a] && IntegerQ[b] && IntegerQ[c] && GCD[a, b, c] == 1 && 
          a > 0 && (b^2) - 4 a c == D && 
          (b^2) - D ≥ 4 (a^2) && -a < b && b ≤ a && 
          If[(b^2) - D == 4 (a^2), b ≥ 0, True];
Reduced[D_Integer] := 
        Module[{a, 
              b}, (((#1[[2]] + (Sqrt[D]))/(2 #1[[1]])) &) /@ 
              Select[Flatten[
                  Table[{a, b, (((b^2) - D)/(4 a))}, {a, 0, 
                      Floor[(Sqrt[-(D/3)])]}, {b, -a + 1, a}], 1], 
                reducedQ[#1, D] &]] /; 
          D < 0 && MemberQ[{0, 1}, Mod[D, 4]];
ClassNumber[D_Integer] := 
        Length[Reduced[D]] /; 
          D < 0 && MemberQ[{0, 1}, Mod[D, 4]];

We test it for discriminant -23.

rr  =  Reduced[-23]

If we set the two variables of (Subscript[Φ, 2]) equal to each other and factor the resulting polynomial we get

ff /. s -> t   //  Factor

The j-function can be computed using

jj =  Normal[j[q, 15]];
J[τ_, o_:  19]  :=  
        jj /. q -> N[(E^(2  π I τ)), o];

{J[I], J[(Sqrt[-2])], J[((1 + (Sqrt[-7]))/2)]}

(E^(-π (Sqrt[3]))) // N

However, the j-function is built in (though with another normalisation) and we shall use that instead:

1728 KleinInvariantJ[#] - 
          J[#] &  /@  {I, (Sqrt[-2]), ((1 + (Sqrt[-7]))/2)}

Continuing with discriminant D=-23 we have the numerical values:

vals =  N[1728 KleinInvariantJ[#], 19] &  /@  
        rr

The polynomial with them as roots is

tt  =  
        Times  @@ (t - vals)  //  Expand;
AccountingForm[tt]

It is quite clear that we have computed with sufficient precision so that the integer coefficients should be:

pp = 
      Round[CoefficientList[tt, t]]  .  Table[(t^i), {i, 0, 3}]

We can make the coefficients make smaller by a simple transformation.

pp1 = ((pp /. t ->  125 (7 (7  t + 2) + 1))/(7^6 (125^3)))  //  Expand

In this way we have eliminated some, but not all of, the factors of the discrimant of the polynomial:

Discriminant[p_, t_]  :=  Resultant[p, D[p, t], t];

Discriminant[#, t] &  /@  {pp, pp1}  //  
      FactorInteger

Considering D=163 we have only a single class:

Reduced[-163]

Its j-invariant has then the following value

N[1728 KleinInvariantJ[((1 + (Sqrt[-163]))/2)], 40]  //  
      AccountingForm

and the main term in the q-expansion is

N[(E^(π (Sqrt[ 163]))), 40]  //  AccountingForm

Note that if we instead take D=167 then we have more than 1 class

ClassNumber[-167]

and the main term is not close to an integer

N[(E^(π (Sqrt[ 167]))), 40]  //  AccountingForm

We want to draw transformations of the fundamental domain by elements of (Subscript[SL, 2])(Z) and hence set up  general Möbius transformations, geodesics, and  geodesic triangles. We start with Möbius transformations and their action on geodesics and geodesic triangles.

Möbius /:  
        Format[ Möbius[a_, b_, c_, 
            d_]]  :=  ((a τ + b)/(c τ + d));
Möbius /:  
        Möbius[a_, b_, c_, d_]  **  
          Möbius[a1_, b1_, c1_, 
            d1_]  := 
Möbius[a a1 + b c1, 
          a b1 + b d1, a1 c + c1 d, 
          b1 c + d d1];
Möbius /:  
        Möbius[a_, b_, c_, d_]^(-1)  :=  
        Möbius[d, -b, -c, 
          a];
Möbius /:  Möbius[_, _, 
            0, _][∞]  :=  ∞;
Möbius /:  Möbius[a_, b_, c_, 
            d_][∞]  :=  a/c;
Möbius /:  (g_Möbius)[
          Geodesic[α_, β_]]  :=  
        Geodesic[g[α], g[β]];
Möbius /:  (g_Möbius)[
          t_GTriangle]  :=  g  /@  t;
Möbius /:  Möbius[a_, b_, c_, 
            d_][τ_]  := 
Module[{r  =  
              a τ + b, s = c τ + d}, 
If[
            s  ==  0, ∞, 
            r/s]];
Möbius /:  g_Möbius[t_GTriangle]  :=  
        g  /@  t;

We then turn to turning geodesics (and their triangles) to drawing primitives. We use epsilon to specify when a geodesic is so close to a line that it should be drawn by a line. We determine the center of the circle by finding the real point of equal distance to the two points.

epsilon  =  0.00001;
GeoToArc[Geodesic[∞, α_], 
          eps_:  epsilon]  := 
GeoToArc[
          Geodesic[α, ∞], 
          eps] ;
GeoToArc[Geodesic[α_, ∞], 
          eps_:  epsilon]  := 
Module[{pt = {Re[α], 
                Im[α]}, 
            an}, 
Line[{pt, pt + {0, 1/eps}}]];
GeoToArc[Geodesic[α_, β_], 
          eps_:  epsilon]  := 
Module[{x, 
            rα = Re[α], 
            rβ = Re[β]}, 
If[
            Abs[rα - rβ]  <  eps, 
            Return[
Line[{{rα, 
                    Im[α]}, {rβ, 
                    Im[β]}}]]]; 
x  =  ((Abs[β]^2 - Abs[α]^2)/(2 (Re[β] - Re[α]))); 
an  =  
            Arg  /@  ({α, β} - x); 
If[
            an[[1]]  >  
              an[[2]], 
            an  =  Reverse[an]]; 
Circle[{x, 0}, 
            Abs[α - x], 
            an]
];
GTrToArc[t_GTriangle, 
          eps_:  epsilon]  := 
Sequence  @@  (GeoToArc[#, eps] &  /@  t);
GGraphics[l_List, o___]  := 
Graphics[
          l /. {g_Geodesic  :>  GeoToArc[g], 
              g_GTriangle  :>  GTrToArc[g]}, o];

We then draw the transformation of the fundamental domain by coset representatives for the kernel of multiplication by 2. We have that (Subscript[SL, 2])(Z/2) equals (Subscript[S, 3]) and the latter group's elements are products of two transpositions. We model that by our choices (note that in one case, (hg^(-1)), do we use the inverse of g though it is of order 2 in (Subscript[SL, 2])(Z/2)).

i  =  Möbius[1, 0, 0, 1];
g  =  Möbius[1, 1, 0, 1];
h  =  
      Möbius[0, 1, -1, 0]; ll = {i, g, 
        h, g ** h, h ** (g^(-1)), g ** h ** g}

The fundamental domain for (Subscript[SL, 2])(Z) is first specified.

fund  =  
        GTriangle[Geodesic[(E^(π I /3)), ∞], 
          Geodesic[(E^(2 π I /3)), ∞], 
          Geodesic[(E^(π I /3)), 
            (E^(2 π I /3))]];

Now we draw the picture.

\(Show[
      GGraphics[
        Join[\(#[fund] &\)\  /@ \ 
            ll, 
{Text["id", {0, 1.5}], 
            Text["g", {1, 1.5}], 
Text["h", {0, 
                0.7}], Text["gh", {1, 
                0.7}], 
Text[\*""(hg^(-1))"", {0.32, 0.44}], 
            Text["ghg", {0.68, 
                0.44}]}]], 
AspectRatio -> \ 
        Automatic, PlotRange -> {\(-0.2\), 2}, 
      Axes -> {True, False}]\)

A fundamental domain for (Subscript[Γ, 0])(15):

ll  =  
        Join[
{Möbius[1, 0, 0, 1], Möbius[6, 1, 5, 1], Möbius[10, 1, 9, 1]}, 
Table[Möbius[k, 1, -1, 0], {k, 0, 14}], 
Table[Möbius[1, 0, 3  k, 1], {k, 0, 4}], 
Table[Möbius[1, 0, 5  k, 1], {k, 0, 2}]]^(-1);
Show[
      GGraphics[#[fund] &  /@  
          ll], 
AspectRatio ->  Automatic, 
      PlotRange -> {-0.2, 1.2}, 
      Axes -> {True, False}]

On[General::spell1];

``Junk part´´

The following is not referenced anywhere in the notes but have been used for verifying formulas, drawing pictures etc and might be useful for someone.

AddPoints[{r_, s_}, {u_, v_}]  := 
Module[{x, y, 
            k  =  ((v - s)/(u - r))}, 
x  =  
            (k^2) - u - r; 
y  = 
            k (x - r) + 
              s; 
{x, -y}];
DoublePoint[{r_, s_}, 
          a_]  :=  
Module[{x, y, 
            k  =  ((3 (x^2) + a)/(2  y))}, 
x  =  
            (k^2) - 2  r; 
y  = 
            k (x - r) + s; 
{x, -y}];

\(Show[
      ImplicitPlot[{w\^2 == z\^3 - z, 
          w == \(1\/2\) \((z + 1)\)}, {z, \(-1.5\), 1.8}, 
        AspectRatio\  -> \ 1, Axes\  -> \ False, 
        DisplayFunction\  -> \ Identity], 
      Graphics[{Disk[{\(-1\), 0}, 0.03], 
          Text[\*""(Subscript[p, 1])"", {\(-1\), \(-0.1\)}, {\(-1\), 
              0}], 
Disk[{\(-0.1753\), 
              0.5 \((1 + \(-0.1753\))\)}, 
            0.03], 
Text[\*""(Subscript[p, 2])"", {\(-0.1753\) + 0.05, 0.5 \((1 + \(-0.1753\))\) - 0.05}, {\(-1\), 
              0}], 
Disk[{1.4253, 0.5 \((2.4253)\)}, 
            0.03]\ , 
Disk[{1.4253, \(-0.5\) \((2.4253)\)}, 
            0.03]\ , 
Text[\*""(Subscript[p, 1])+(Subscript[p, 2])"", {1.4253 + 
                0.05, \(-\((0.5 \((2.4253)\) - 0.05)\)\)}, {\(-1\), 
              0}], 
Line[{{\(-1.5\), \(-0.25\)}, {2, 
                1.5}}], 
Line[{{1.4253, 
                0.5 \((2.4253)\) + 0.2}, {1.4253, \(-0.5\) \((2.4253)\) - 
                  0.2}}]
}], 
AspectRatio -> \ Automatic, DisplayFunction\  -> \ $DisplayFunction]\)

vars12  =  {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[x, 1]), (Subscript[x, 2])};
bas12  =  
      GroebnerBasis[{((Subscript[y, 1])^2) - (((Subscript[x, 1])^3) + a (Subscript[x, 1]) + b ), 
          ((Subscript[y, 2])^2) - (((Subscript[x, 2])^3) + a (Subscript[x, 2]) + b)}, vars12]; 
vars1  =  {y, x}; 
bas1  =  
        GroebnerBasis[{(y^2) - ((x^3) + a x + b )}, vars1];
\({Append[\(({\(z\_1\^4\) z\_2\^4, \(z\_1\^6\) z\_2\^6} 
                polred[{\((x\_1 - x\_2)\)\^2, \((x\_1 - x\_2)\)\^3} 
                    AddPoints[{x\_1, y\_1}, {x\_2, y\_2}], bas12, 
                  vars12]\  /. {x\_1 -> \ x\_1\/z\_1\^2, 
                y\_1 -> \ y\_1\/z\_1\^3, x\_2 -> \ x\_2\/z\_2\^2, 
                y\_2 -> \ y\_2\/z\_2\^3}\  // \ Factor\ )\), \(x\_1\) 
            z\_2\^2 - \(x\_2\) z\_1\^2], 

      Append[{z\^8, z\^12} 
              polred[{4  y\^2, 8  y\^3} DoublePoint[{x, y}, a], bas1, 
                vars1]\  /. {x -> x\/z\^2, y -> \ y\/z\^3}\  // \ 
          Factor, 2  y\ z]}\)

(x ((Subscript[ψ, n])^2) - (Subscript[ψ, n - 
                      1]) (Subscript[ψ, n + 1])) ((Subscript[ψ, n + 1])^2) - (x ((Subscript[ψ, n + 1])^2) - (Subscript[ψ, n]) (Subscript[ψ, n + 2])) ((Subscript[ψ, n])^2) // Expand

f = (({{℘'[u], ℘[u], 1}, {℘''[u], ℘'[u], 0}, {℘'[-2 u], ℘[-2 
                    u], 1}})) // Det

f /. {℘'[u]^2 ->  
            4 ℘[u]^3 - (Subscript[g, 2]) ℘[u] - 
              (Subscript[g, 3]), ℘''[u]  ->  
            6  ℘[u]^2 - (Subscript[g, 2])}  //  Simplify

Integrate[(1/Sqrt)[1 - x^2], x]

Integrate[-(2/(1 + (k^2))), k]

NSolve[{(y^2) == (x^3) - x, y = (1/2) (x - 1)}]

NSolve[((y^2) - ((x^3) - x) /. 
            y  ->  (1/2) (x + 1)) == 0]

<<  profile.m
ff[n_, 0]  :=  
        Table[{((π  i)/n), 0}, {i, -n, 
            n + 1}];
ff[n_, 0.0]  :=  ff[n, 0];
ff[n_, r_]  :=  
        Table[{Sin[((π r i)/n)]/r, ((Cos[((π r i)/n)] - 1)/r)}, {i, -n, n + 1}];
s = 
      0; Show[ProfOchStyrTillYta[#, 2  #], 
              Boxed  ->  
                False, 
ViewPoint  ->  {0.2, 
                  0.7, -1}
] &[
          ff[10, #]] & /@  (0.1  Range[0, 10])

Apart[{-((-1 + 3 λ - 5 (λ^3) + 
                  3 (λ^5) - (λ^6))/((((-1 + λ))^2) (λ^2))), ((2 - 6 λ + 5 (λ^2) + 5 (λ^4) - 6 (λ^5) + 2 (λ^6))/(2 (((-1 + λ))^2) (λ^2))), 
((((1 - λ + (λ^2)))^3)/((((-1 + λ))^2) (λ^2)))}] // 
      MatrixForm

2 ((-1 + 3 λ - 5 (λ^3) + 3 (λ^5) - (λ^6))/((((-1 + λ))^2) (λ^2))) + ((2 - 6 λ + 5 (λ^2) + 5 (λ^4) - 6 (λ^5) + 2 (λ^6))/((((-1 + λ))^2) (λ^2)))  //  
      Simplify

6 - ((-1 + 3 λ - 5 (λ^3) + 3 (λ^5) - (λ^6))/((((-1 + λ))^2) (λ^2))) // Simplify

Clear[r, s, t, u, x, y, a];
m  =  {(Subscript[a, 1]), (Subscript[a, 3]), (Subscript[a, 2]), (Subscript[a, 4]), (Subscript[a, 6])};
p  =  
        y^2 + (Subscript[a, 1]) x y + (Subscript[a, 3]) 
            y - ((x^3) + (Subscript[a, 2]) (x^2) + (Subscript[a, 4]) x + 
              (Subscript[a, 6]));
q  =  
        p /. {x  ->  (u^2) x + r, 
            y  ->  (u^3) y + s (u^2) x + 
                t};
n  = 
        Join[Coefficient[
                q, {x y, y}], 
-Coefficient[
                  q /. y -> 0, {(x^2), 
                    x}], 
{-q /. {x -> 0, 
                    y -> 0}}] {(u^(-5)), (u^(-3)), (u^(-4)), 
              (u^(-2)), 1}  //  Factor  ;
Inner[Rule, m, n, List]  //  MatrixForm

Drop

minus[{x_, y_, 
            z_}]  :=  {x, -y - (Subscript[a, 1]) x z - (Subscript[a, 3]) (z^6), 
          z};
add[{x1_, y1_, z1_}, {x2_, y2_, 
          z2_}]  := 
Module[{λ  =  ((y2 - y1)/(x2 - x1)), μ=

(Subscript[P, 1])[x_, a_, b_]  :=  1;
(Subscript[P, 2])[x_, a_, b_]  :=  2;
(Subscript[P, 3])[x_, a_, b_]  :=  
        3  (x^4) + 6  a (x^2) + 12 b x - (a^2);
(Subscript[P, 4])[x_, a_, b_]  :=  
        4 ((x^6) + 5  a (x^4) + 20 b (x^3) - 5 (a^2) (x^2) - 
              4  a b x - 8  (b^2) - (a^3));
(Subscript[P, n])_[x_, a_, b_]  :=  
        Module[{m = (n - 1)/2}, 
(Subscript[P, m + 2])[x, a, b] 
                (Subscript[P, m])[x, a, b]^3 - (Subscript[P, m + 1])[x, a, b]^3 
                (Subscript[P, m - 1])[x, a, b] 16 ((((x^3) + a x + b))^2)] /; 
          Mod[n, 4] == 3;
(Subscript[P, n])_[x_, a_, b_]  :=  
        Module[{m = (n - 1)/
                  2}, 
16 ((((x^3) + a x + b))^2) 
                (Subscript[P, m + 2])[x, a, b] 
                (Subscript[P, m])[x, a, b]^3 - (Subscript[P, m + 1])[x, a, b]^3 
                (Subscript[P, m - 1])[x, a, b] ] /; 
          Mod[n, 4] == 1;
(Subscript[P, n])_[x_, a_, b_]  :=  
        Module[{m = n/2}, 
(Subscript[P, m])[x, a, 
                b] ((Subscript[P, m + 2])[x, a, b] (Subscript[P, m - 1])[x, a, b]^2 - 
                  (Subscript[P, m - 2])[x, a, 
                      b] (((Subscript[P, m + 1])[x, a, b] )^2))] /; 
          Mod[n, 2] == 0;

(Subscript[P, 11])[x, a, b]

(Subscript[X, 1])  =  
        ((Subscript[x, 1])/((Subscript[z, 1])^2));

    (Subscript[Y, 1])  =  ((Subscript[y, 1])/((Subscript[z, 1])^3));

    (Subscript[X, 2])  =  ((Subscript[x, 2])/((Subscript[z, 2])^2));

    (Subscript[Y, 2])  =  ((Subscript[y, 2])/((Subscript[z, 2])^3));

    λ  =  (((Subscript[Y, 2]) - (Subscript[Y, 1]))/((Subscript[X, 2]) - (Subscript[X, 1])));

    μ  =  (((Subscript[Y, 1]) (Subscript[Y, 2]) - (Subscript[Y, 2]) (Subscript[X, 1]))/((Subscript[X, 2]) - (Subscript[X, 1])));

    (Subscript[X, 3]) = (λ^2) - (Subscript[X, 1]) - (Subscript[X, 2]);

    (Subscript[Y, 3]) = -λ (Subscript[X, 3]) - μ;

    (Subscript[z, 3]) =  
        (Subscript[x, 2]) (Subscript[z, 1]^3) (Subscript[z, 2]) - (Subscript[x, 1]) (Subscript[z, 1]) (Subscript[z, 2]^3);

    (Subscript[x, 3]) = ((Subscript[z, 3])^2) (Subscript[X, 3]);

    (Subscript[y, 3]) = ((Subscript[z, 3])^3) (Subscript[Y, 3]);

Clear[x, y, z, a, b]

vars  =  {(Subscript[x, 1]), (Subscript[y, 1]), (Subscript[x, 2]), (Subscript[y, 2]), (Subscript[z, 2])};

vars  =  {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[x, 1]), (Subscript[z, 1]), (Subscript[x, 2]), (Subscript[z, 2])};

vars  =  {(Subscript[x, 1]), (Subscript[y, 1]), (Subscript[x, 2]), (Subscript[y, 2]), (Subscript[z, 1]), 
          (Subscript[z, 2])};
bas  =  
        GroebnerBasis[{((Subscript[y, 1])^2) - (((Subscript[x, 1])^3) + a (Subscript[x, 1]) ((Subscript[z, 1])^4) + 
                  b  ((Subscript[z, 1])^6)), 
            ((Subscript[y, 2])^2) - (((Subscript[x, 2])^3) + a (Subscript[x, 2]) ((Subscript[z, 2])^4) + b ((Subscript[z, 2])^6))}, 
          vars];

(polred[#, bas, vars] &  /@ ({(Subscript[x, 3]), (Subscript[y, 3]), (Subscript[z, 3])})  //  
        Factor)

Clear[y, x, a, b, z];
vars  =  {y, x, a, b};
bas  =  
        GroebnerBasis[(y^2) - ((x^3) + a x + b), vars];

polred[#, bas, 
            vars] &  /@ ({(Subscript[x, 3]), (Subscript[y, 3]), (Subscript[z, 3])} /. {(Subscript[x, 1]) ->  x, 
              (Subscript[y, 1]) -> y, (Subscript[z, 1]) -> 1, 
              (Subscript[x, 2]) ->  
                x ((Subscript[ψ, n])^2) - (Subscript[ψ, n - 1]) (Subscript[ψ, n + 1]), 
              (Subscript[y, 2]) ->  (1/(2  
                        y)) ((Subscript[ψ, n + 
                              2]) ((Subscript[ψ, n - 1])^2) - (Subscript[ψ, n - 
                              2]) ((Subscript[ψ, n + 1])^2)), 
              (Subscript[z, 2]) ->  (Subscript[ψ, n])})  //  Factor

(({(Subscript[x, 3]), (Subscript[y, 3]), (Subscript[z, 3])}  // ExpandAll  //  
            Simplify))  //  Factor

(n + 2) (((n - 1))^2) - (n - 2) (((n + 1))^2) //  
      Expand

(Subscript[X, 1])  =  
        ((Subscript[x, 1])/((Subscript[z, 1])^2));

    (Subscript[Y, 1])  =  ((Subscript[y, 1])/((Subscript[z, 1])^3));

    (Subscript[X, 2])  =  ((Subscript[x, 2])/((Subscript[z, 2])^2));

    (Subscript[Y, 2])  =  ((Subscript[y, 2])/((Subscript[z, 2])^3));

    λ  =  (((Subscript[Y, 2]) - (Subscript[Y, 1]))/((Subscript[X, 2]) - (Subscript[X, 1])));

    μ  =  (((Subscript[Y, 1]) (Subscript[Y, 2]) - (Subscript[Y, 2]) (Subscript[X, 1]))/((Subscript[X, 2]) - (Subscript[X, 1])));

    (Subscript[X, 3]) = (λ^2) + (Subscript[a, 1]) λ - (Subscript[a, 2]) - (Subscript[X, 1]) - 
          (Subscript[X, 2]);

    (Subscript[Y, 3]) = -(λ + (Subscript[a, 1])) (Subscript[X, 3]) - μ - 
          (Subscript[a, 3]);

    (Subscript[z, 3]) =  
        (Subscript[x, 2]) (Subscript[z, 1]^3) (Subscript[z, 2]) - (Subscript[x, 1]) (Subscript[z, 1]) (Subscript[z, 2]^3);

    (Subscript[x, 3]) = ((Subscript[z, 3])^2) (Subscript[X, 3]);

    (Subscript[y, 3]) = ((Subscript[z, 3])^3) (Subscript[Y, 3]);

{(Subscript[x, 3]), (Subscript[y, 3]), (Subscript[z, 3])}  // ExpandAll  //  
        Simplify // Factor

℘[
        2  z] = -2 ℘[
            z] + (1/4) (((℘''[z]/(℘')[z]))^2)

\(\(\(\(\(℘'\)[z]\^3\/2\) 
        D[\(-2\) ℘[
                z] + \(1\/4\) \((\(℘''\)[z]\/\(℘'\)[z])\)\^2, z]\)\(\ \)\(//\)\(\ \)\(Expand\)\(\ \)\)\)

\(\(\(\((\(\(℘'\)[z]\^3\/2\) 
              D[\(-2\) ℘[
                      z] + \(1\/4\) \((\(℘''\)[z]\/\(℘'\)[z])\)\^2, z]\  // \ 
            Expand)\) /. {\(℘''\)[z]\  -> \ 
            6  ℘[z] - g\_2\/2, \(℘'''\)[
              z]\  -> \ 
            12\ ℘[z] \(℘'\)[
                z]}\)\(\ \)\(//\)\(Expand\)\(\ \)\)\)

\(\(\((\((\(\(℘'\)[z]\^3\/2\) 
                  D[\(-2\) ℘[
                          z] + \(1\/4\) \((\(℘''\)[z]\/\(℘'\)[z])\)\^2, z]\  // \ 
                Expand)\) /. {\(℘''\)[z]\  -> \ 
                6  ℘[z]\^2 - g\_2\/2, \(℘'''\)[
                  z]\  -> \ 
                12\ ℘[z] \(℘'\)[z]} // 
          Expand)\)\(/.\)\({\(℘'\)[z]\^2 -> \ 
          4  ℘[z]\^3 - \(g\_2\) ℘[z] - 
            g\_3, \(℘'\)[z]\^4 -> \ \((4  ℘[z]\^3 - \(g\_2\) ℘[z] - g\_3)\)\^2}\)\(\ \)\)\)

\(\(\(Collect[
      2 \((\((\(\(℘'\)[z]\^3\/2\) 
                        D[\(-2\) ℘[
                                z] + \(1\/4\) \((\(℘''\)[z]\/\(℘'\)[z])\)\^2, z]\  // \ 
                      Expand)\) /. {\(℘''\)[z]\  -> \ 
                      6  ℘[z]\^2 - 
                        g\_2\/2, \(℘'''\)[z]\  -> \ 
                      12\ ℘[z] \(℘'\)[z]} // 
                Expand)\) /. {\(℘'\)[z]\^2 -> \ 
              4  ℘[z]\^3 - \(g\_2\) ℘[z] - 
                g\_3, \(℘'\)[z]\^4 -> \ \((4  ℘[z]\^3 - \(g\_2\) ℘[z] - g\_3)\)\^2}\  // \ 
        Expand\ , ℘[z]]\)\(\ \)\)\)

Clear[usage];
(usage[#]  =  {#}) & /@  
        Range[4];
usage[n_]  :=  usage[n]  =  
        Module[{m = Floor[n/2]}, 
Union[
            Flatten[{m + #, usage[m + #]} &  /@ {-1, 0, 1, 
                  2}]]
]

usage[115]

(Length[Union[Flatten[usage[#]]]]/
              N[Log[#]^2] &  /@ 
Range[100000000000, 
            100000900000])  //  ListPlot

Series[(1/q) + 1 + q, {q, 0, 1}] 
      Series[(1/q) + 1 + q, {q, 0, 1}]

Solve[a (k^2) + b k  + c  + o  ==  (1/(q^2))]

?*Klein*

k  =  j[q, 12];
k1  =  Normal[k];

k

o = Series[q, {q, 0, 0}];
o1 = Series[(q^2), {q, 0, 1}];

Express[l_, 
          n_]  :=  
Module[{k = j[q, n], 
            o = Series[q, {q, 0, 0}], 
            a}, 
(Table[a[i], {i, 0, n}] /. 
                Solve[Sum[a[i] (k^i), {i, 0, n}]  ==  
                    l])[[1]]];

Express[tt[[1]], 6]  .  
      (j^Range)[0, 6]

g  = (Express[#, 6]  .  (j^Range)[0, 6] &  /@  tt) . 
          (t^Range)[0, 6]  //  Expand