You are not logged in.
Pages: 1
Special values:
Module[{w1, w2, w3, g2, g3, Δ, p, ζ, case},
w1 = RandomReal[WorkingPrecision -> 50];
z = w1*RandomReal[WorkingPrecision -> 50];
p[z_] := WeierstrassP[z, {g2, g3}];
ζ[z_] := WeierstrassZeta[z, {g2, g3}];
case[t_] := (w3 = t*w1; w2 = -w1 - w3; {g2, g3} = WeierstrassInvariants[{w1, w3}]; Δ = g2^3 - 27*g3^2);
case[I]; (* Lemniscatic cases *)
Assert[ζ[w1] == Pi/(4*w1)];
Assert[ζ[w3] == -I*Pi/(4*w1)];
Assert[p[w1] == Gamma[1/4]^4/(32*Pi*w1^2)];
Assert[p[w2] == 0];
Assert[p[w3] == -Gamma[1/4]^4/(32*Pi*w1^2)];
Assert[g2 == Gamma[1/4]^8/(16*Pi*w1^2)^2];
Assert[g3 == 0];
Assert[Δ == Gamma[1/4]^24/(16*Pi*w1^2)^6];
Assert[g2^3/Δ == 1];
Assert[p[(2/5)*w1] - p[(4/5)*w1] == Sqrt[GoldenRatio]*Gamma[1/4]^4/(16*Pi*w1^2)];
With[{x = p[z], y = p'[z]},
Assert[p[(1 + I)*z] == I*(g2/x - 4*x)/8];
Assert[p'[(1 + I)*z] == -(1 + I)*y*(g2/x^2 + 4)/16];
Assert[p[(1 + I)*z/2] == -I*x*(1 + Sqrt[4 - g2/x^2]/2)];
Assert[z == x^(-1/2)*Hypergeometric2F1[1/4, 1/2, 5/4, g2/(4*x^2)]];
];
case[Exp[2*Pi*I/3]]; (* Equianharmonic cases *)
Assert[ζ[w1] == Pi/(2*Sqrt[3]*w1)];
Assert[ζ[w2] == Exp[2*Pi*I/3]*Pi/(2*Sqrt[3]*w1)];
Assert[ζ[w3] == Exp[-2*Pi*I/3]*Pi/(2*Sqrt[3]*w1)];
Assert[p[w1] == Gamma[1/3]^6/(2^(14/3)*(Pi*w1)^2)];
Assert[p[w2] == Exp[-2*Pi*I/3]*Gamma[1/3]^6/(2^(14/3)*(Pi*w1)^2)];
Assert[p[w3] == Exp[2*Pi*I/3]*Gamma[1/3]^6/(2^(14/3)*(Pi*w1)^2)];
Assert[g2 == 0];
Assert[g3 == Gamma[1/3]^18/(4*Pi*w1)^6];
Assert[Δ == -27*Gamma[1/3]^36/(4*Pi*w1)^12];
Assert[g2^3/Δ == 0];
Assert[p[(2/5)*w1] - p[(4/5)*w1] == Sqrt[3]*5^(-1/12)*(2 + Sqrt[5])^(1/6)*Gamma[1/3]^6/(4*Pi*w1)^2];
With[{x = p[z], y = p'[z]},
Assert[p[I*Sqrt[3]*z] == 3^(-1)*(g3/x^2 - x)];
Assert[p'[I*Sqrt[3]*z] == I*3^(-3/2)*y*(1 + 8*g3/(y^2 + g3))];
Assert[p[I*z/Sqrt[3]] == -2^(-1)*x^(-1/2)*g3^(1/2)*Csc[ArcCsc[2*x^(3/2)*g3^(-1/2)]/3]];
Assert[z == x^(-1/2)*Hypergeometric2F1[1/6, 1/2, 7/6, g3/(4*x^3)]];
];
case[I*Infinity]; (* Degenerate cases *)
Assert[ζ[w1] == Pi^2/(12*w1)];
Assert[p[w1] == (Pi/w1)^2/6];
Assert[g2 == (Pi/w1)^4/12];
Assert[g3 == (Pi/w1)^6/216];
Assert[Δ == 0];
Assert[p[(2/5)*w1] - p[(4/5)*w1] == 5^(-1/2)*(Pi/w1)^2]
case[I*Sqrt[2]];
Assert[ζ[w1] == (Gamma[1/8]*Gamma[3/8])^2/(384*Pi*w1) + Pi/(2^(5/2)*w1)];
Assert[ζ[w3] == I*(Sqrt[2]*(Gamma[1/8]*Gamma[3/8])^2/(384*Pi*w1) - Pi/(4*w1))];
Assert[p[w1] == (3 + Sqrt[2])*(Gamma[1/8]*Gamma[3/8])^2/(2^(13/2)*3*Pi*w1^2)];
Assert[p[w2] == -(3 - Sqrt[2])*(Gamma[1/8]*Gamma[3/8])^2/(2^(13/2)*3*Pi*w1^2)];
Assert[p[w3] == -(Gamma[1/8]*Gamma[3/8])^2/(2^5*3*Pi*w1^2)];
Assert[g2 == 5*(Gamma[1/8]*Gamma[3/8])^4/(2^11*3*(Pi*w1^2)^2)];
Assert[g3 == 7*(Gamma[1/8]*Gamma[3/8])^6/(2^16*(3*Pi*w1^2)^3)];
Assert[Δ == (Gamma[1/8]*Gamma[3/8])^12/(2^33*(Pi*w1^2)^6)];
Assert[g2^3/Δ == 125/27];
case[I*Sqrt[3]];
Assert[ζ[w1] == Gamma[1/3]^6/(2^(20/3)*Pi^2*w1) + Pi/(4*Sqrt[3]*w1)];
Assert[ζ[w3] == I*(Sqrt[3]*Gamma[1/3]^6/(2^(20/3)*Pi^2*w1) - Pi/(4*w1))];
Assert[p[w1] == (2*Sqrt[3] + 1)*Gamma[1/3]^6/(2^(20/3)*(Pi*w1)^2)];
Assert[p[w2] == -Gamma[1/3]^6/(2^(17/3)*(Pi*w1)^2)];
Assert[p[w3] == -(2*Sqrt[3] - 1)*Gamma[1/3]^6/(2^(20/3)*(Pi*w1)^2)];
Assert[g2 == 15*Gamma[1/3]^12/(2^(34/3)*(Pi*w1)^4)];
Assert[g3 == 11*Gamma[1/3]^18/(2^17*(Pi*w1)^6)];
Assert[Δ == 27*Gamma[1/3]^36/(2^32*(Pi*w1)^12)];
Assert[g2^3/Δ == 125/4];
] & // Block[{$AssertFunction = Automatic}, #[]] &;Half period and Quarter period values:
Module[{w1, w2, w3, w4, g2, g3, Δ, e1, e2, e3, η1, η2, a, b, c, ϕ, p, ζ, σ},
On[Assert];
w1 = 1;
w2 = I*Sqrt[Tan[RandomReal[WorkingPrecision -> 50]*Pi/2]];
w3 = w1 + w2;
w4 = w1 - w2;
{g2, g3} = WeierstrassInvariants[{w1, w2}];
Δ = g2^3 - 27*g3^2;
p[z_] := WeierstrassP[z, {g2, g3}];
ζ[z_] := WeierstrassZeta[z, {g2, g3}];
σ[z__] := Times @@ WeierstrassSigma[{z}, {g2, g3}];
(* Half period values *)
{e1, e2, e3} = p[{w1, w2, w3}];
{η1, η2} = ζ[{w1, w2}];
Assert[4*#^3 - g2*# - g3 == 0] & /@ {e1, e2, e3};
Assert[e1 + e2 + e3 == 0];
Assert[g2 == 2*(e1^2 + e2^2 + e3^2) == -4*(e1*e2 + e1*e3 + e2*e3)];
Assert[g3 == 4*e1*e2*e3 == (4/3)*(e1^3 + e2^3 + e3^3)];
Assert[Δ == 16*(e1 - e2)^2*(e1 - e3)^2*(e2 - e3)^2];
Assert[Δ == #^2*(4*#^2 - 3*g2)^2] & /@ (Subtract @@@ Permutations[{e1, e2, e3}, {2}]);
Assert[4*(e1 - e2)*(e1 - e3) == 12*e1^2 - g2];
Assert[4*(e2 - e3)*(e2 - e1) == 12*e2^2 - g2];
Assert[4*(e3 - e1)*(e3 - e2) == 12*e3^2 - g2];
Assert[p'[#] == 0] & /@ {w1, w2, w3};
a = Sqrt[g2/3];
ϕ = ArcSin[g3/a^3]/3;
Assert[e1 == a*Cos[Pi/6 - ϕ]];
Assert[e2 == -a*Cos[Pi/6 + ϕ]];
Assert[e3 == -a*Sin[ϕ]];
Assert[ζ[w3] == η1 + η2];
Assert[ζ[w4] == η1 - η2];
Assert[σ[w1] == Sqrt[2]*E^((1/2)*w1*η1)/(12*e1^2 - g2)^(1/4)];
Assert[σ[w2] == I*Sqrt[2]*E^((1/2)*w2*η2)/(12*e2^2 - g2)^(1/4)];
(* Quarter period values *)
a = Sqrt[e1 - e2];
b = Sqrt[e1 - e3];
c = Sqrt[e3 - e2];
Assert[p[(1/2)*w1] == e1 + a*b];
Assert[p[(1/2)*w2] == e2 - a*c];
Assert[p[(1/2)*w3] == e3 - I*b*c];
Assert[p[(1/2)*w4] == e3 + I*b*c];
Assert[p[(1/2)*w1 + w2] == e1 - a*b];
Assert[p[(1/2)*w2 + w1] == e2 + a*c];
Assert[p'[(1/2)*w1] == -2*a*b*(a + b)];
Assert[p'[(1/2)*w2] == -2*I*a*c*(a + c)];
Assert[p'[(1/2)*w3] == 2*b*c*(b + I*c)];
Assert[p'[(1/2)*w4] == 2*b*c*(b - I*c)];
Assert[p'[(1/2)*w1 + w2] == 2*a*b*(a - b)];
Assert[p'[(1/2)*w2 + w1] == 2*I*a*c*(a - c)];
Assert[ζ[(1/2)*w1] == (1/2)*(ζ[w1] + (a + b))];
Assert[ζ[(1/2)*w2] == (1/2)*(ζ[w2] - I*(a + c))];
Assert[σ[(1/2)*w1] == E^((1/8)*w1*η1)/(2^(1/4)*(a + b)^(1/4)*(a*b)^(3/8))];
Assert[σ[(1/2)*w2] == I*E^((1/8)*w2*η2)/(2^(1/4)*(a + c)^(1/4)*(a*c)^(3/8))];
(* Dedekind eta function representations *)
With[{τ = w2/w1, η = DedekindEta},
Assert[e1 == (Pi/w1)^2*((η[τ/2]^8 + 8*η[2*τ]^8)/η[τ]^4)/6];
Assert[e2 == -(Pi/w1)^2*((η[τ/2]^8 + 32*η[2*τ]^8)/η[τ]^4)/12];
Assert[e3 == -(Pi/w1)^2*((η[τ/2]^8 - 16*η[2*τ]^8)/η[τ]^4)/12];
];
] & // Block[{$AssertFunction = Automatic}, #[]] &;One-third period values:
Module[{w1, w2, w3, w4, g2, g3, Δ, x, y, η1, η2, cbrtΔ, a0, a1, a2, a3, a4, p, ζ, σ},
w1 = 1;
w2 = I*Sqrt[Tan[RandomReal[WorkingPrecision -> 50]*Pi/2]];
w3 = w1 + w2;
w4 = w1 - w2;
{g2, g3} = WeierstrassInvariants[{w1, w2}];
Δ = g2^3 - 27*g3^2;
p[z_] := WeierstrassP[z, {g2, g3}];
ζ[z_] := WeierstrassZeta[z, {g2, g3}];
σ[z__] := Times @@ WeierstrassSigma[{z}, {g2, g3}];
{x, y} = Through[{p, p'}[(2/3)*{w1, w2, w3, w4}]];
Assert[#^4 - (1/2)*g2*#^2 - g3*# - (1/48)*g2^2 == 0] & /@ x;
Assert[#^8 - 8*g3*#^6 - (2/3)*Δ*#^4 - (1/27)*Δ^2 == 0] & /@ Join[y, -y];
Assert[g2 == Total[x^2]];
Assert[g3 == Total[x^3]/3 == Total[y^2]/8];
Assert[Δ == -I*3^(3/2)*(Times @@ y)];
cbrtΔ = CubeRoot[Δ];
a0 = (g2 - cbrtΔ)/3;
a1 = Sign[g3]*Sqrt[a0];
a2 = 2*If[a1 == 0, g2/Sqrt[3], g3/a1];
a3 = g2 - a0;
a4 = Sqrt[a2 - a0 - cbrtΔ];
Assert[x[[1]] == (a1 + Sqrt[a2 + a3])/2];
Assert[x[[2]] == (a1 - Sqrt[a2 + a3])/2];
Assert[x[[3]] == (-a1 - I*Sqrt[a2 - a3])/2];
Assert[x[[4]] == (-a1 + I*Sqrt[a2 - a3])/2];
Assert[y[[1]] == -cbrtΔ/(Sqrt[3]*Sqrt[a4 - a1])];
Assert[y[[2]] == -I*cbrtΔ/(Sqrt[3]*Sqrt[a4 + a1])];
{η1, η2} = ζ[{w1, w2}];
Assert[ζ[(2/3)*w1] == (2/3)*η1 + Sqrt[x[[1]]]/Sqrt[3]];
Assert[ζ[(2/3)*w2] == (2/3)*η2 - I*Sqrt[-x[[2]]]/Sqrt[3]];
Assert[σ[(2/3)*w1] == E^((2/9)*w1*η1)/(-y[[1]])^(1/3)];
Assert[σ[(2/3)*w2] == I*E^((2/9)*w2*η2)/(I*y[[2]])^(1/3)];
(* Dedekind eta function representations *)
With[{τ = w2/w1, η = DedekindEta},
Assert[x[[1]] == (Pi*(η[τ/3]^3 + 3*η[3*τ]^3)/(w1*η[τ]))^2/4];
Assert[x[[2]] == -(Pi*(η[τ/3]^3 + 9*η[3*τ]^3)/(w1*η[τ]))^2/12];
Assert[x[[3]] == -(Pi*(η[τ/3]^3 + I*3^(3/2)*η[3*τ]^3)/(w1*η[τ]))^2/12];
Assert[x[[4]] == -(Pi*(η[τ/3]^3 - I*3^(3/2)*η[3*τ]^3)/(w1*η[τ]))^2/12];
Assert[y[[1]] == -(Pi*η[τ]^3/(Sqrt[3]*w1*η[3*τ]))^3];
Assert[y[[2]] == -I*(Pi*η[τ]^3/(w1*η[τ/3]))^3];
Assert[y[[3]] == Sqrt[ I]*(Pi*η[τ]^3/(w1*η[(τ+1)/3]))^3];
Assert[y[[4]] == Sqrt[-I]*(Pi*η[τ]^3/(w1*η[(τ-1)/3]))^3];
];
] & // Block[{$AssertFunction = Automatic}, #[]] &;One-fifth period values:
Module[{w1, w2, g2, g3, Δ, p, ζ, σ},
w1 = 1;
w2 = I*Sqrt[Tan[RandomReal[WorkingPrecision -> 50]*Pi/2]];
{g2, g3} = WeierstrassInvariants[{w1, w2}];
Δ = g2^3 - 27*g3^2;
p[z_] := WeierstrassP[z, {g2, g3}];
ζ[z_] := WeierstrassZeta[z, {g2, g3}];
σ[z__] := Times @@ WeierstrassSigma[{z}, {g2, g3}];
Module[{x, y, sqrtx, t, a},
{x, y} = p[(2/5)*#] + {-1, 1}*p[(4/5)*#];
t = Sign[#];
sqrtx = Sqrt[t^2*x]/t;
t = Δ/x^6;
a = 3*y/x + (11 + t)/2;
Assert[x^12 - (12/5)*g2*x^10 + 2*Δ*x^6 + (1/5)*Δ^2 == 0];
Assert[y == x*Sqrt[5^3 + 22*t + t^2]/6];
Assert[p[(2/5)*#] == (y + x)/2 == x*(2/a + 17 + t)/12];
Assert[p[(4/5)*#] == (y - x)/2 == x*(2/a + 5 + t)/12];
Assert[p'[(2/5)*#] == -sqrtx^3*a^( 1/2)];
Assert[p'[(4/5)*#] == -sqrtx^3*a^(-1/2)];
Assert[ζ[(2/5)*#] == (2/5)*ζ[#] + sqrtx*(1 + 3*a)/(10*Sqrt[a])];
Assert[ζ[(4/5)*#] == (4/5)*ζ[#] - sqrtx*(3 - 1*a)/(10*Sqrt[a])];
Assert[σ[(2/5)*#] == E^((2/25)*#*ζ[#])*a^(-1/10)/sqrtx];
Assert[σ[(4/5)*#] == E^((8/25)*#*ζ[#])*a^( 1/10)/sqrtx];
(* https://mathworld.wolfram.com/AbelsImpossibilityTheorem.html *)
] & /@ {w1, w2};
(* Dedekind eta function representations *)
With[{τ = w2/w1, η = DedekindEta},
Assert[p[(2/5)*w1] - p[(4/5)*w1] == (Pi/w1)^2*η[τ]^5/(Sqrt[5]*η[5*τ])];
Assert[p[(2/5)*w2] - p[(4/5)*w2] == -(Pi/w1)^2*η[τ]^5/η[τ/5]];
];
(* Hypergeometric series representations *)
With[{t = g3*(3/g2)^(3/2), f = (Times @@ Hypergeometric2F1[1/6, 5/6, {4/5, 6/5}, #]) &},
Assert[p[(2/5)*w1] - p[(4/5)*w1] == 2*Sqrt[(3/5)*g2]/f[(1 - t)/2]];
Assert[p[(2/5)*w2] - p[(4/5)*w2] == -2*Sqrt[(3/5)*g2]/f[(1 + t)/2]];
];
] & // Block[{$AssertFunction = Automatic}, #[]] &;Sigma function notation:
Module[{z, a, b, c0, c1, c2, w1, w2, g2, g3, d, p, ζ, σ},
w1 = 1;
w2 = I*Sqrt[Tan[RandomReal[WorkingPrecision -> 50]*Pi/2]];
{g2, g3} = WeierstrassInvariants[{w1, w2}];
z = w1*(2*RandomReal[WorkingPrecision -> 50] - 1);
a = w1*(2*RandomReal[WorkingPrecision -> 50] - 1);
b = w1*(2*RandomReal[WorkingPrecision -> 50] - 1);
c0 = a - b;
p[z_] := WeierstrassP[z, {g2, g3}];
ζ[z_] := WeierstrassZeta[z, {g2, g3}];
σ[z__] := Times @@ WeierstrassSigma[{z}, {g2, g3}];
With[{wp = p[c0], pd = p'[c0]},
c1 = InverseWeierstrassP[{(-wp + Sqrt[g2 - 3*wp^2])/2, pd}, {g2, g3}];
c2 = -c0 - c1;
];
Assert[ζ[z + a] - ζ[z - a] == 2*ζ[a] - σ[2*a, z, z]/σ[z + a, z - a, a, a]];
d = ζ[a - b];
Assert[ζ[z + a] - ζ[z + b] == d - σ[a - b, z + a + c1, z + b - c1]/σ[z + a, z + b, c1, c2]];
Assert[ζ[z - a] - ζ[z - b] == -d + σ[a - b, z - a - c1, z - b + c1]/σ[z - a, z - b, c1, c2]];
Assert[ζ[z + a] - ζ[z + b] == d - (σ[2*(z + b), z + a, z + a]/σ[z + b, z + b] + σ[2*(z + a), z + b, z + b]/σ[z + a, z + a])/(2*σ[a - b, 2*z + a + b])];
Assert[ζ[z - a] - ζ[z - b] == -d + (σ[2*(z - b), z - a, z - a]/σ[z - b, z - b] + σ[2*(z - a), z - b, z - b]/σ[z - a, z - a])/(2*σ[a - b, 2*z - a - b])];
d = ζ[a - b] + (3*p[a - b]^2 - g2/4)/p'[a - b];
Assert[ζ[z + a] - ζ[z + b] == d + σ[z - a + 2*b, z - b + 2*a]/σ[z + a, z + b, 2*(a - b)]];
Assert[ζ[z - a] - ζ[z - b] == -d - σ[z + a - 2*b, z + b - 2*a]/σ[z - a, z - b, 2*(a - b)]];
] & // Block[{$AssertFunction = Automatic}, #[]] &;Relations to Jacobi elliptic functions:
Module[{z, p, s, c, d, n, ϕ, g2, g3, m, w1, w2},
m = RandomReal[WorkingPrecision -> 50];
w1 = EllipticK[m];
w2 = I*EllipticK[1 - m];
z = w1*RandomReal[WorkingPrecision -> 50];
With[{t = m*(1 - m)},
g2 = (4/3)*(1 - t);
g3 = (4/27)*(1 - 2*m)*(2 + t);
];
Assert[WeierstrassInvariants[{w1, w2}] == {g2, g3}];
p = WeierstrassP[z/2, {g2, g3}];
s = WeierstrassPPrime[z/2, {g2, g3}];
c = 1 - m - (p - (2 - m)/3)^2;
d = m*(m - 1) - (p + (1 - 2*m)/3)^2;
n = m - (p + (1 + m)/3)^2;
ϕ = -2*ArcTan[2*(p + (1 - 2*m)/3)/s];
Assert[JacobiSN[z, m] == s/n];
Assert[JacobiCN[z, m] == c/n];
Assert[JacobiDN[z, m] == d/n];
Assert[PossibleZeroQ@Mod[JacobiAmplitude[z, m] - ϕ, 2*Pi, -Pi]];
Assert[PossibleZeroQ@Mod[EllipticF[ϕ, m] - z, 2*w1, -w1]];
With[{ζ = WeierstrassZeta[#, {g2, g3}] &},
Assert[JacobiZeta[ϕ, m] == ζ[z + w2] - ζ[w2] - z*ζ[w1]/w1];
Assert[EllipticE[m] == ζ[w1] + w1*(2 - m)/3];
Assert[I*EllipticE[1 - m] == -ζ[w2] + w2*(1 + m)/3];
];
Assert[WeierstrassP[z, {g2, g3}] == Csc[ϕ]^2 - (1 + m)/3 == Cot[ϕ]^2 + (2 - m)/3];
Assert[WeierstrassPPrime[z, {g2, g3}] == -2*Csc[ϕ]^2*Cot[ϕ]*Sqrt[1 - m*Sin[ϕ]^2]];
] & // Block[{$AssertFunction = Automatic}, #[]] &;Last edited by lanxiyu (2025-04-13 10:05:16)
Offline
Pages: 1