You are not logged in.
(* https://resources.wolframcloud.com/PacletRepository/resources/JanM/Dixon/ *)
<< "JanM`Dixon`";
Hold[{f, g, u, v, α, β, s, c, m, x, y, z, b, γ, w1, w2, λ, λ0, λ1, λ2, λd, makeλ, κ, κ0, κ1, κ2, makeκ, μ, ϕ, τ, η, p, q, pr, sqrt},
pr = 50;
α = -RandomReal[WorkingPrecision -> pr];
b = (9*(1 - α + α^2))^(1/3);
γ = CubeRoot[1 + α^3];
sqrt[z_] := RandomChoice[{1, -1}]*Sqrt[z];
w1 = Exp[2*sqrt[-1]*Pi/3];
w2 = Conjugate[w1];
cis[z_] := Exp[I*Sign@Im[w1]*z];
λ0 = Gamma[1/3]^3/(2*Sqrt[3]*Pi); (* λ(0) *)
κ0 = 4*Pi^2/(3*Gamma[1/3]^3); (* κ(0) *)
λd = 2*Pi*3^(-3/2); (* λ(-1) *)
Assert[N[DixonF[λ0, 0] == κ0, pr]];
Assert[N[λ0 * κ0 == λd, pr]];
makeλ[α_] := Block[{x, y, z},
x = λ0*Hypergeometric2F1[1/3, 1/3, 2/3, -α^3];
y = κ0*α*Hypergeometric2F1[2/3, 2/3, 4/3, -α^3];
z = x + y;
If[PossibleZeroQ[Im[α]], z = Re[z]];
{z, w1*x + w2*y, w2*x + w1*y}
];
makeκ[α_] := Block[{x, y, z},
x = κ0*Hypergeometric2F1[-1/3, 2/3, 1/3, -α^3];
y = λ0*α^2*Hypergeometric2F1[1/3, 4/3, 5/3, -α^3]/2;
z = x + y;
If[PossibleZeroQ[Im[α]], z = Re[z]];
α + {x + y, w2*x + w1*y, w1*x + w2*y}
];
{λ, λ1, λ2} = Quiet@makeλ[α];
{κ, κ1, κ2} = Quiet@makeκ[α];
Which[
VectorQ[{λ, κ}, NumericQ] (* γ != 0 *),
Assert[λ + λ1 + λ2 == 0];
With[{m = 3*ReIm[{λ, λ1, λ2}].Inverse@ReIm@DixonPeriods[α]},
Assert[MatrixQ[m, # == Round[#] &]];
Assert[VectorQ[Cross @@ Transpose[m], #^2 == 1 &]];
],
α < 0,
With[{b = 1 + α^(-3)},
{λ, κ} = λd*{
-Hypergeometric2F1[1/3, 2/3, 1, b]/α,
Hypergeometric2F1[2/3, 4/3, 1, b]/α^2
};
κ += α;
]
];
{u, v} = RandomReal[{0, λ}, 2, WorkingPrecision -> pr];
x = DixonSM[0, α];
y = DixonCM[0, α];
Assert[x == 0];
Assert[y == 1];
x = DixonSM[λ, α];
y = DixonCM[λ, α];
Assert[x == 1];
Assert[y == 0];
x = DixonSM[λ/2, α];
y = DixonCM[λ/2, α];
Assert[x == y];
Assert[2*x^3 == 1 + 3*α*x^2];
x = DixonSM[λ/3, α];
y = DixonCM[λ/3, α];
Assert[x^2*y + x - y^2 == 0];
Assert[y^2*x + y - x^2 == b*x*y];
Assert[x^3 + 1 == b*x];
Assert[y^3 + 1 == b*y^2];
x = DixonSM[λ/4, α];
y = DixonCM[λ/4, α];
Assert[x + x^3 == y^3*(1 - x)];
Assert[DixonF[λ, α] == κ];
If[α != -1,
Assert[DixonF[λ1, α] == κ1];
Assert[DixonF[λ2, α] == κ2];
];
s = DixonSM[u, α];
c = DixonCM[u, α];
Assert[s^3 + c^3 == 1 + 3*α*s*c];
Assert[DixonSM[λ - u, α] == c];
Assert[DixonCM[λ - u, α] == s];
Assert[DixonSM[u + λ, α] == DixonCM[-u, α] == 1/c];
Assert[DixonCM[u + λ, α] == DixonSM[-u, α] == -s/c];
Assert[DixonSM[u - λ, α] == DixonCM[-u - λ, α] == -c/s];
Assert[DixonCM[u - λ, α] == DixonSM[-u - λ, α] == 1/s];
Assert[DixonSM[2*u, α] == s*(1 + c^3)/(c*(1 + s^3))];
Assert[DixonCM[2*u, α] == (c^3 - s^3)/(c*(1 + s^3))];
Assert[DixonSM[3*u, α] == s*c*(1 + s^3 + c^3 + s^6 + c^6 - s^3*c^3)/(c^3 - s^6 + 3*s^3*c^3 + c^6*s^3)];
Assert[DixonCM[3*u, α] == -(s^3 - c^6 + 3*s^3*c^3 + s^6*c^3)/(c^3 - s^6 + 3*s^3*c^3 + c^6*s^3)];
x = Null;
With[{v = λ1 - λ2}, If[NumericQ[v],
Assert[DixonSM[u + v, α] == w2*s];
Assert[DixonCM[u + v, α] == w1*c];
x = -3^(-3/2)*Pi*v/(w1 - w2) + (1/2)*α^2*HypergeometricPFQ[{1, 1, 1}, {4/3, 5/3}, -α^3];
]];
(* Power series at α = -1 *)
f[α_] :=
Module[{x, y, z, n, b, c, sum},
b = c = 1 + SetAccuracy[α, Accuracy[α] + 5];
x = 0;
y = 1/3;
sum = x;
n = 2;
While[
z = sum;
sum += c*y;
z != sum,
c *= b;
z = ((1 - 3*n + 3*n^2)*y - (n - 1)^2*x)/(3*n^2);
x = y;
y = z;
n++;
];
SetAccuracy[sum, Accuracy[sum] - 5]
];
(* Differential equations:
w(α) + 7*α*w'(α) + 6*α^2*w''(α) + (1 + α^3)*w'''(α) = 0
Wronskian(λ(α), λ'(α), w(α)) = constant * (1 + α^3)^(-2)
*)
If[Abs[α + 1] < 1,
y = f[α] + (Pi/Sqrt[3] - Sqrt[3]*PolyGamma[1, 1/3]/(2*Pi))*λ;
If[NumericQ[x], Assert[x == y], x = y];
];
With[{b = SetPrecision[α, Infinity], μ = SetPrecision[λ, Infinity]},
y = NIntegrate[Log[DixonSM[u, b]/u], {u, 0, μ}, WorkingPrecision -> pr] + λ*(Log[λ] - 1)
If[NumericQ[x], Assert[x == y]];
];
Module[{s1, s2, s3, s4, c1, c2, c3, c4, f, g, z},
(* Addition theorem *)
{s1, s2, s3, s4} = DixonSM[{u, v, u + v, u - v}, α];
{c1, c2, c3, c4} = DixonCM[{u, v, u + v, u - v}, α];
f = DixonF[#, α] &;
g = Times @@ DixonG[{##}, α] &;
z = c2 + s1*c1*s2^2;
Assert[s3*z == s1 + s2*c2*c1^2];
Assert[s4*z == s1*c2^2 - s2*c1^2];
Assert[c3*z == c1*c2^2 - s1^2*s2];
Assert[c4*z == c1 + s2*c2*s1^2];
Assert[s3*s4*z == s1^2*c2 - s2^2*c1];
Assert[s3*c4*z == s2 + s1*c1*c2^2];
Assert[c3*s4*z == s1*c1 - s2*c2];
Assert[c3*c4*z == c1^2*c2 - s1*s2^2];
Assert[f[u + v] == f[u] + f[v] + s1*s2*c3];
Assert[f[u - v] == f[u] - f[v] - c1*s2*s4];
Assert[f[-u - v] == -f[u] - f[v] + (s1^3 - s2^3)/(s1*c1 - s2*c2)];
Assert[g[u + v, u - v, 0, 0]/g[u, v]^2 == E^(-α*v)*z];
];
With[{v = sqrt[-1]*Log[RandomReal[WorkingPrecision -> pr]]},
Assert[Abs[DixonCM[v, α]] == 1];
];
Assert[Derivative[1, 0][DixonSM][u, α] == c^2 - α*s];
Assert[Derivative[1, 0][DixonCM][u, α] == -s^2 + α*c];
f[u_, α_] := DixonSM[u, α];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[y^3 - 3*α*x*y^2 - x^6 + (2 + 4*α^3)*x^3 - 1 == 0];
If[α < 0 && x > 0, Assert[y*Hypergeometric2F1[1/3, 2/3, 1/2, (1 - x^3)^2/(4*(α*x)^3)] == -α*x]];
f[u_, α_] := DixonCM[u, α];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[y^3 + 3*α*x*y^2 + x^6 - (2 + 4*α^3)*x^3 + 1 == 0];
If[α < 0 && x > 0, Assert[y*Hypergeometric2F1[1/3, 2/3, 1/2, (1 - x^3)^2/(4*(α*x)^3)] == α*x]];
f[u_, α_] := DixonSM[u, α] + DixonCM[u, α];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[3*y^2 + (x + α)*(x^3 - 3*α*x^2 - 4) == 0];
f[u_, α_] := DixonSM[u, α]*DixonCM[u, α];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[y^2 + 4*x^3 == (1 + 3*α*x)^2];
f[u_, α_] := If[PossibleZeroQ[1 + α], -1/3, 1/(DixonSM[u, α] + DixonCM[u, α] + α)];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[3*y^2 == 4*(1 + α^3)*x^3 - (1 - 3*α*x)^2];
If[α < 0,
f[u_, α_] := With[{s = DixonSM[u, α], c = DixonCM[u, α]}, ArcTan[(1 - c - 2*α*s)/(Sqrt[3]*(1 + c))]];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[y*Hypergeometric2F1[1/3, 2/3, 1/2, (1 + α^(-3))*Sin[x]^2] == -Sqrt[3]*α/2];
];
If[α < 2,
f[u_, α_] := With[{s = DixonSM[u, α], c = DixonCM[u, α]}, ArcTan[(1 - c + 2*s)/(Sqrt[3]*(1 + c))]];
x = f[u, α];
y = Derivative[1, 0][f][u, α];
Assert[y*Hypergeometric2F1[1/3, 2/3, 1/2, -((1 + α)/(2 - α))^3*Sin[3*x]^2] == (2 - α)/(2*Sqrt[3])];
];
Clear[f];
If[Context[CarlsonRF] === "System`",
f[u_, v_] :=
Block[{x, y, z, b = Abs[α]^(3/2), ϕ},
ϕ = 2*I*Pi*{1, -1, 0};
ϕ = Which[
α > 0, (ArcCsch[b] + ϕ)/3,
α < 0, (ArcSech[b] + ϕ)/3
];
b = v*α;
{x, y, z} = Which[
b > 0, 1 + Csch[ϕ]^2/4,
b < 0, 1 - Sech[ϕ]^2/4,
True, Table[1, 3]
];
Assert[y == Conjugate[x] && z >= 3/4];
Assert[u == Re[CarlsonRF[x, y, z]]];
Assert[u == Sqrt[2]*CarlsonRF[Re[x] + Abs[x], z + Abs[x] + Abs[z - x], z + Abs[x] - Abs[z - x]]];
]
];
If[α != -1, With[{u = HypergeometricPFQ[{1/2, 1/2, 1}, {5/6, 7/6}, -α^3], s = sqrt[3*α]},
(* Differential equations:
u(α) + 3*α*u'(α) + (1 + α^3)/α*u''(α) + sqrt(3)/(4*α^(5/2)) = 0
5*α*u(α) + 23*α^2*u'(α) + 3*(1 + 5*α^3)*u''(a) + 2*α*(1 + α^3)*u'''(α) = 0
Wronskian(λ(α), λ'(α), u(α)) = π*i/(2*sqrt(3)*α^(3/2)*(1 + α^3)^2)
*)
Assert[DixonSM[s*u, α] == s];
Assert[DixonCM[s*u, α] == 1];
Assert[DixonF[s*u, α] == (3/2)*α + s*(3/5)*α^2*HypergeometricPFQ[{1/2, 1, 3/2}, {7/6, 11/6}, -α^3]];
Assert[DixonF[s*u + λ, α] == κ - (3/2)*α + s*(3/5)*α^2*HypergeometricPFQ[{1/2, 1, 3/2}, {7/6, 11/6}, -α^3]];
Assert[PossibleZeroQ[α] ||
DixonF[s*u - λ, α] == -κ + (3/2)*α + s^(-1)*HypergeometricPFQ[{-1/2, 1/2, 1}, {1/6, 5/6}, -α^3]];
If[α > 0, Assert[s*(u + (1/9)*α^(-3)*HypergeometricPFQ[{5/6, 7/6, 1}, {3/2, 3/2}, -α^(-3)]) == Sign[s]*(3/4)*λ]];
If[α > -1, With[{v = u*Sqrt[1 + α^3]},
With[{b = SetPrecision[(3*α)^3/4, Infinity]},
Assert[u == (1/2)*NIntegrate[(x^3 + b*(x - 1)^2)^(-1/2), {x, 1, Infinity}, WorkingPrecision -> pr]]; (* hard case at x = 3 *)
Assert[u == NIntegrate[(1 + b*x^2*(1 - x^2)^2)^(-1/2), {x, 0, 1}, WorkingPrecision -> pr]]; (* hard case at x = 3^(-1/2) *)
];
If[!PossibleZeroQ[α], With[{b = SetPrecision[1 + α^(-3), Infinity], ϕ = SetPrecision[ArcTan[α^(3/2)], Infinity]},
Assert[v == NIntegrate[(4*x^3 - (1 - 3*x)^2/b)^(-1/2), {x, 1, Infinity}, WorkingPrecision -> pr]];
Assert[v == NIntegrate[(1 - x^2*(3 - x^2)^2/(4*b))^(-1/2), {x, 0, 1}, WorkingPrecision -> pr]];
Assert[u == (2/3)*α^(-3/2)*N[NIntegrate[Hypergeometric2F1[1/3, 2/3, 1/2, b*Sin[x]^2], {x, 0, ϕ},
WorkingPrecision -> pr, PrecisionGoal -> pr/2
], pr/2]];
]];
f[v, -1];
]];
]];
If[α > -1, With[{u = HypergeometricPFQ[{1/2, 1/2, 1}, {5/6, 7/6}, α^3/(1 + α^3)]/Sqrt[1 + α^3], s = sqrt[α]},
(* Differential equations:
4*α^(3/2)*sqrt(1 + α^3)*(α*u(α) + 3*α^2*u'(α) + (1 + α^3)*u''(α)) + 1 = 0
α*(5 + 8*α^3)*u(α) + α^2*(23 + 32*α^3)*u'(α) + 3*(1 + α^3)*(1 + 6*α^3)*u''(α) + 2*α*(1 + α^3)^2*u'''(α) = 0
Wronskian(λ(α), λ'(α), u(α)) = π*i/(6*α^(3/2)*(1 + α^3)^(5/2))
*)
Assert[DixonSM[s*u, α] == s*E^((1/3)*ArcSinh[s^3])];
Assert[DixonCM[s*u, α] == E^((2/3)*ArcSinh[s^3])];
Assert[DixonSM[2*s*u, α] == 2*s*E^(-(1/3)*ArcSinh[s^3])];
Assert[DixonCM[2*s*u, α] == E^(-(2/3)*ArcSinh[s^3])];
Assert[Derivative[1, 0][DixonSM][s*u, α] == Sqrt[1 + α^3]*E^((1/3)*ArcSinh[s^3])];
Assert[Derivative[1, 0][DixonCM][s*u, α] == 0];
Assert[DixonF[s*u, α] == (1/2)*α + (s*(2/5)*α^2/Sqrt[1 + α^3])*HypergeometricPFQ[{1/2, 1/2, 1}, {7/6, 11/6}, α^3/(1 + α^3)]];
Assert[DixonF[s*u + λ, α] == κ - (1/2)*α + (s*(2/5)*α^2/Sqrt[1 + α^3])*HypergeometricPFQ[{1/2, 1/2, 1}, {7/6, 11/6}, α^3/(1 + α^3)]];
Assert[PossibleZeroQ[α] ||
DixonF[s*u - λ, α] == -κ + (3/2)*α + (Sqrt[1 + α^3]/(9*s))*(7 + 2*HypergeometricPFQ[{-1/2, -1/2, 1}, {1/6, 5/6}, α^3/(1 + α^3)])];
If[α < 0, Assert[s*(u - (1/9)*(Sqrt[1 + α^3]/α^3)*HypergeometricPFQ[{5/6, 7/6, 1}, {3/2, 3/2}, 1 + α^(-3)]) == Sign[s]*(1/4)*Abs[λ1 - λ2]]];
If[!PossibleZeroQ[α], With[{b = SetPrecision[α^(-3), Infinity], ϕ = SetPrecision[ArcSinh[α^(3/2)], Infinity]},
Assert[u == NIntegrate[(4*x^3 + (1 - 3*x)^2/b)^(-1/2), {x, 1, Infinity}, WorkingPrecision -> pr]];
Assert[u == NIntegrate[(1 + x^2*(3 - x^2)^2/(4*b))^(-1/2), {x, 0, 1}, WorkingPrecision -> pr]];
Assert[u == (2/3)*α^(-3/2)*N[NIntegrate[Hypergeometric2F1[1/3, 2/3, 1/2, b*Sinh[x]^2], {x, 0, ϕ},
WorkingPrecision -> pr, PrecisionGoal -> pr/2
], pr/2]];
]];
f[u, 1];
]];
If[α <= 0, With[{b = SetPrecision[α^3, Infinity]},
Assert[λ == NIntegrate[(1 - b*x^3)^(-1/3)*(1 + x^3)^(-2/3), {x, 0, Infinity}, WorkingPrecision -> pr]];
Assert[λ == NIntegrate[x*(x^3 - b)^(-1/3)*(1 + x^3)^(-2/3), {x, 0, Infinity}, WorkingPrecision -> pr]];
]];
f[u_, α_] := Through[{DixonSM, DixonCM}[u, α]]; (* ComapApply *)
If[!PossibleZeroQ[γ],
Assert[f[w2*u, w1*α] == {w2*s, c}];
Assert[makeλ[w1*α] == w2*{λ1, λ2, λ}];
Assert[makeκ[w1*α] == w1*{κ1, κ2, κ}];
Assert[f[w1*u, w2*α] == {w1*s, c}];
Assert[makeλ[w2*α] == w1*{λ2, λ, λ1}];
Assert[makeκ[w2*α] == w2*{κ2, κ, κ1}];
β = (2 - α)/(1 + α);
Assert[f[u*(1 + α)/(w2 - w1), β] == -{s + c - 1, s + w2*c - w1}/(s + w1*c - w2)];
Assert[DixonF[u*(1 + α)/(w2 - w1), β] ==
(-(1 - α + α^2)*u/3 + (w1 - w2)*(1 + α*w1)/3 + (w2*c - w1*s)*(s + w1*c + w2*α)/(s + w1*c - w2) + DixonF[u, α])*(w2 - w1)/(1 + α)];
Assert[DixonG[u*(1 + α)/(w2 - w1), β]/DixonG[0, β] ==
E^(-(1 - α + α^2)*u^2/6 + u*(w1 - w2)*(1 + α*w1)/3)*(s + w1*c - w2)*DixonG[u, α]/((w1 - w2)*DixonG[0, α])];
β = -α/γ;
Assert[f[3*u*γ/(w2 - w1), β] == -{3*γ*s*c, s^3 + w2*c^3 - w1}/(s^3 + w1*c^3 - w2)];
Assert[DixonG[3*u*γ/(w2 - w1), β]/DixonG[0, β] ==
E^(-3*α^2*u^2/2 + (w2 - 1)*α*u)*(s^3 + w1*c^3 - w2)*DixonG[u, α]^3/((w1 - w2)*DixonG[0, α]^3)];
Assert[f[u*γ/(w2 - w1), β]^3 == -{α*s - c + 1, α*s - w2*c + w1}/(α*s - w1*c + w2)];
Assert[DixonG[u*γ/(w2 - w1), β]^3/DixonG[0, β]^3 ==
E^(-α^2*u^2/2 + w2*α*u)*(α*s - w1*c + w2)*DixonG[u, α]/((w2 - w1)*DixonG[0, α])];
β = (α - 2)/b;
Assert[f[b*u, β] == {b*s*c, -(s - c^2 + c*s^2)}/(c - s^2 + s*c^2)];
Assert[DixonG[b*u, β]/DixonG[0, β] ==
E^((3*(1 - α)*u^2/2 - (1 + α)*u))*(c - s^2 + s*c^2)*DixonG[u, α]^3/DixonG[0, α]^3];
Assert[f[b*u/3, β]^3 == {α*s - c + 1, α*c - s + 1}/(s + c + α)];
Assert[DixonF[b*u/3, β] ==
((1 - α)*u - s + c - 1 + DixonF[u, α])/b];
Assert[DixonG[b*u/3, β]^3/DixonG[0, β]^3 ==
E^((1 - α)*u^2/2 - u)*(s + c + α)*DixonG[u, α]/((1 + α)*DixonG[0, α])];
β = (2*γ + α)/(γ - α);
Assert[f[(γ - α)*u, β] == {s^3 + (γ - α)*s*c, c^3 + (γ - α)*s*c}/(1 - (γ - α)*s*c)];
Assert[DixonF[(γ - α)*u, β] ==
(γ + 2*α)*u + 1 + (s^3 - c^3)/(1 - (γ - α)*s*c) + 3*DixonF[u, α]/(γ - α)];
Assert[DixonG[(γ - α)*u, β]/DixonG[0, β] ==
E^((γ - α)*((γ + 2*α)*u^2/2 + u))*(1 - (γ - α)*s*c)*DixonG[u, α]^3/DixonG[0, α]^3];
];
If[γ > 0,
β = (2 - α)/(1 + α);
Assert[makeλ[β] == (1 + α)/(w2 - w1)*{λ2 - λ1, -λ2, λ1}];
Assert[makeκ[β] == β + (3*{κ1 - κ2, κ2 - α, α - κ1} + (1 - α + α^2)*{λ2 - λ1, -λ2, λ1})/((w2 - w1)*(1 + α))];
β = -α/γ;
Assert[makeλ[β] == γ/(w2 - w1)*{λ2 - λ1, λ - λ2, λ1 - λ}];
Assert[makeκ[β] == β + ({κ1 - κ2, κ2 - κ, κ - κ1} + α^2*{λ2 - λ1, λ - λ2, λ1 - λ})/((w2 - w1)*γ)];
β = (α - 2)/b;
Assert[makeλ[β] == b*(λ/3 + {0, λ1, λ2})];
Assert[makeκ[β] == β + (κ - α + 3*{0, κ1 - α, κ2 - α} + (1 - α)*(λ + 3*{0, λ1, λ2}))/b];
β = (2*γ + α)/(γ - α);
Assert[makeλ[β] == (γ - α)*{λ, (λ1 - λ)/3, (λ2 - λ)/3}];
Assert[makeκ[β] == β + {3*(κ - α), κ1 - κ, κ2 - κ}/(γ - α) + (γ + 2*α)*{λ, (λ1 - λ)/3, (λ2 - λ)/3}];
];
Clear[f];
f = QPochhammer;
g[q_] := 1 - 24*QPolyGamma[1, 1, q]/Log[q]^2;
g[z_, q_] := (QPolyGamma[Log[q, z], q] + Log[1 - q])/Log[q];
If[NumericQ[λ1],
τ = I*Abs@Im[λ1/λ]/3;
q = -Sign[γ]*Exp[2*I*Pi*τ];
p = CubeRoot[q];
TimeConstrained[
Assert[α == -1 - 9*q*(f[q^9]/f[q])^3];
Assert[γ == -3*p*(f[q^3]/f[q])^4];
Assert[α/γ == 1 + (3*p)^(-1)*(f[p]/f[q^3])^3];
Assert[b == 3*f[q^3]^4/(f[q]^3*f[q^9])];
Assert[γ - α == f[p]^3*f[q^3]/f[q]^4];
Assert[λ/λd == f[q]^3/f[q^3]];
Assert[(κ - α)/λ - (3/4)*α^2 == (1/4)*f[q^3]^2*g[q]/f[q]^6];
Assert[(κ - α)/λ - (1/4)*α^2 == (3/4)*f[q^3]^2*g[q^3]/f[q]^6];
Assert[DixonSM[(3/2)*λ, α] == 2*f[q^2]^3*f[q^3]/(f[q]^3*f[q^6])];
If[q > 0,
Assert[DixonSM[(3/2)*I*Im[λ1], α] == -f[q^(1/2)]^3*f[q^3]/(f[q]^3*f[q^(3/2)])];
Assert[DixonSM[(3/2)*(λ + I*Im[λ1]), α] == -f[-q^(1/2)]^3*f[q^3]/(f[q]^3*f[-q^(3/2)])],
Assert[DixonSM[(3/2)*λ1, α] == -f[q^2]^3*f[q^3]/(f[q]^3*f[q^6]) + Sqrt[-3*q]*(w1 - w2)*f[q^6]^3/(f[q]*f[q^2]*f[q^3])]
];
Assert[DixonSM[(2/3)*I*Im[λ1], α] == -w2*f[p]/f[w2*p]];
Assert[DixonCM[(2/3)*I*Im[λ1], α] == -w1*f[w1*p]/f[w2*p]];
With[{z = w1^(u/(2*λ))},
Assert[DixonSM[u, α] ==
-(Im[z]/Im[w2*z])*Abs[f[q*z^2, q]/f[q*w1*z^2, q]]^2];
Assert[DixonCM[u, α] ==
-(Im[w1*z]/Im[w2*z])*Abs[f[q*w2*z^2, q]/f[q*w1*z^2, q]]^2];
Assert[(α - κ)*u/λ - α/2 + DixonF[u, α] ==
λd*Im[w1]*(4*Im[g[q*w1*z^2, q]] + Re[w2*z]/Im[w2*z])/λ];
Assert[Exp[(α - κ)*u^2/(2*λ) - α*u/2]*DixonG[u, α]/DixonG[0, α] ==
(Im[w2*z]/Im[w2])*Abs[f[q*w1*z^2, q]/f[q*w1, q]]^2];
],
0.1
];
With[{n = 1 + Boole[γ > 0]},
q = Exp[-2*I*Pi/(3*n*τ)];
p = (-1)^(n - 1)*q^(3/n);
TimeConstrained[
With[{q = Surd[p, 9]},
Assert[α == -1 - (3*q)^(-1)*(f[q]/f[p])^3];
Assert[γ == -(3*q)^(-1)*(f[q^3]/f[p])^4];
Assert[α/γ == 1 + 9*q^3*(f[p^3]/f[q^3])^3];
Assert[b == Abs[q]^(-2/3)*f[q^3]^4/(f[p]^3*f[q])];
Assert[γ - α == 3*q^2*f[p^3]^3*f[q^3]/f[p]^4];
Assert[Abs@Im[λ1] == (2*Pi/n)*Abs[q]*f[p]^3/f[q^3]];
Assert[Im[κ1]/Im[λ1] - (3/4)*α^2 == -(1/12)*q^(-2)*f[q^3]^2*g[p]/f[p]^6];
Assert[Im[κ1]/Im[λ1] - (1/4)*α^2 == -(1/36)*q^(-2)*f[q^3]^2*g[q^3]/f[p]^6];
(* ... *)
];
With[{z = q^(u/λ)},
Assert[DixonSM[u, α] ==
q^(1/(3*n))*z^(-n/3)*f[z, p]*f[p/z, p]/(f[q*z, p]*f[p/(q*z), p])];
Assert[DixonCM[u, α] ==
z^(1 - 2*n/3)*f[q/z, p]*f[p*z/q, p]/(f[q*z, p]*f[p/(q*z), p])];
Assert[Exp[-Im[κ1]*u^2/(2*Im[λ1]) - α*u/2]*DixonG[u, α]/DixonG[0, α] ==
z^(n/3 - 1/2)*f[q*z, p]*f[p/(q*z), p]/(f[q, p]*f[p/q, p])];
If[n == 1, Assert[-Im[κ1]*u/Im[λ1] - α/2 + DixonF[u, α] ==
-((1/6)*Log[p] + QPolyGamma[1/3 + u/(3*λ), p] - QPolyGamma[2/3 - u/(3*λ), p])/(3*λ)]];
],
0.1
];
];
];
Block[{u, v},
{u, v} = RandomReal[{0, λ0}, 2, WorkingPrecision -> pr];
With[{s1 = DixonSM[u], c1 = DixonCM[u], s2 = DixonSM[v], c2 = DixonCM[v]},
Assert[DixonSM[u + w1*v] == (s1*c2*(c2 + s1*c1*s2^2) + w1*s2*c1*(c1 + s2*c2*s1^2))/(1 - s1^3*s2^3)];
Assert[DixonCM[u + w1*v] == (c1*(c2 + s1*c1*s2^2) + w1*s1*s2*(s2*c1^2 - s1*c2^2))/(1 - s1^3*s2^3)];
Assert[s1*AppellF1[1/3, 2/3, 1, 4/3, s1^3, s1^3*s2^3] ==
u + s2*(u*DixonF[v] - (Log[DixonG[u + v]] + w1*Log[DixonG[u + w1*v]] + w2*Log[DixonG[u + w2*v]])/3)/c2^2];
Assert[s1^2*AppellF1[2/3, 1/3, 1, 5/3, s1^3, s1^3*s2^3] ==
(2/3)*(Log[DixonG[u + v]] + w2*Log[DixonG[u + w1*v]] + w1*Log[DixonG[u + w2*v]])/(s2*c2)];
Assert[c2*s1*AppellF1[1/3, 2/3, 1, 4/3, s1^3, s1^3*s2^3] - s2^2*s1^2*AppellF1[2/3, 1/3, 1, 5/3, s1^3, s1^3*s2^3]/2 ==
c2*u - (s2/c2)*(Log[DixonG[u + v]] - Log[DixonG[u]] - Log[DixonG[v]] + Log[DixonG[0]] - Log[1 - s1^3*s2^3]/3 - u*DixonF[v])];
];
];
Clear[f];
f[α_, x_, y_] := With[{λ = N[makeλ[α][[1]], pr]},
If[α < 2, Assert[λ == (2*Pi/(Sqrt[3]*(2 - α)))*Hypergeometric2F1[1/3, 2/3, 1, -((1 + α)/(2 - α))^3]]];
With[{b = α^3},
(Sqrt[α]*{Sqrt[3]*x, y/Sqrt[1 + b]} . HypergeometricPFQ[{1/2, 1/2, 1}, {5/6, 7/6}, {-b, b/(1 + b)}]) / λ
]
];
With[{ϕ = GoldenRatio},
Assert[f[1/3, 1, 0] == 1/2];
Assert[f[1/(3*ϕ^2), 1, 0] == 1/3];
Assert[f[ϕ^2/3, 1, 0] == 2/3];
Assert[f[Root[#^3 + 2*# - 1 &, 1]^2/3, 1, 0] == 1/4];
Assert[f[1/2, 0, 1] == 1/3];
Assert[f[80^(-1/3), 0, 1] == 1/4];
Assert[f[1/(5 + Sqrt[33]), 0, 1] == 1/6];
Assert[f[3^(-1/3), 1, 1] == 1];
Assert[f[5^(-2/3)/3, 1, 1] == 1/2];
Assert[f[48^(-1/3), 1, 2] == 1];
Assert[f[(2/25)^(1/3), 1, 3] == 3/2];
Assert[f[(7 - Sqrt[33])/8, 1, 3] == 1];
Assert[f[(7 + Sqrt[33])/8, 1, 3] == 2];
Assert[f[Root[4*#^3 - 10*#^2 + 12*# - 3 &, 1]^2/3, 1, 3] == 1/2];
Assert[f[Root[2*#^3 - 4*#^2 + 3*# - 3 &, 1]^2/3, -1, 3] == 1/2];
];
] /.
HoldPattern[_[vars:{___Symbol}, expr_]] :>
Block[{$AssertFunction = Automatic},
With[{temp = Unique[Unevaluated[vars], Temporary]},
WithCleanup[
Unevaluated[expr] /. Dispatch[Thread@Hold[vars, temp] /. Hold[lhs_, rhs_] :> (HoldPattern[lhs] -> rhs)],
Remove @@ Unevaluated[temp]
] /; ListQ[temp]
]
];Theta functions:
Module[{u, q, a, b},
u = RandomReal[WorkingPrecision -> 50];
q = RandomReal[WorkingPrecision -> 50];
a = ((EllipticTheta[4, q]/EllipticTheta[4, Pi/3, q])^2 + 2*EllipticTheta[4, Pi/3, q]/EllipticTheta[4, q])/3;
b = EllipticTheta[2, q]*EllipticTheta[3, q]*EllipticTheta[4, q]/(2*Sqrt[3]*EllipticTheta[1, Pi/3, q]);
Assert[EllipticTheta[1, u, q^3]^3 == b*(a*EllipticTheta[1, u, q] - EllipticTheta[1, u + Pi/3, q] + EllipticTheta[1, u + 2*Pi/3, q])];
Assert[EllipticTheta[2, u, q^3]^3 == b*(a*EllipticTheta[2, u, q] - EllipticTheta[2, u + Pi/3, q] + EllipticTheta[2, u + 2*Pi/3, q])];
Assert[EllipticTheta[3, u, q^3]^3 == b*(a*EllipticTheta[3, u, q] + EllipticTheta[3, u + Pi/3, q] + EllipticTheta[3, u + 2*Pi/3, q])];
Assert[EllipticTheta[4, u, q^3]^3 == b*(a*EllipticTheta[4, u, q] + EllipticTheta[4, u + Pi/3, q] + EllipticTheta[4, u + 2*Pi/3, q])];
Assert[EllipticTheta[1, u, q^3] == EllipticTheta[1, u/3, q]*EllipticTheta[1, (u + Pi)/3, q]*EllipticTheta[1, (u + 2*Pi)/3, q]/(3*b)];
Assert[EllipticTheta[2, u, q^3] == -EllipticTheta[2, u/3, q]*EllipticTheta[2, (u + Pi)/3, q]*EllipticTheta[2, (u + 2*Pi)/3, q]/(3*b)];
Assert[EllipticTheta[3, u, q^3] == EllipticTheta[3, u/3, q]*EllipticTheta[3, (u + Pi)/3, q]*EllipticTheta[3, (u + 2*Pi)/3, q]/(3*b)];
Assert[EllipticTheta[4, u, q^3] == EllipticTheta[4, u/3, q]*EllipticTheta[4, (u + Pi)/3, q]*EllipticTheta[4, (u + 2*Pi)/3, q]/(3*b)];
Assert[EllipticTheta[1, u, q^9] == -(EllipticTheta[1, u/3, q] - EllipticTheta[1, (u + Pi)/3, q] + EllipticTheta[1, (u + 2*Pi)/3, q])/3];
Assert[EllipticTheta[2, u, q^9] == (EllipticTheta[2, u/3, q] - EllipticTheta[2, (u + Pi)/3, q] + EllipticTheta[2, (u + 2*Pi)/3, q])/3];
Assert[EllipticTheta[3, u, q^9] == (EllipticTheta[3, u/3, q] + EllipticTheta[3, (u + Pi)/3, q] + EllipticTheta[3, (u + 2*Pi)/3, q])/3];
Assert[EllipticTheta[4, u, q^9] == (EllipticTheta[4, u/3, q] + EllipticTheta[4, (u + Pi)/3, q] + EllipticTheta[4, (u + 2*Pi)/3, q])/3];
With[{s = EllipticTheta[1, u, q], m = EllipticTheta[1, u + Pi/3, q], c = EllipticTheta[1, u + 2*Pi/3, q]},
Assert[EllipticTheta[1, u+Pi/9, q]^3 == ( EllipticTheta[1, Pi/9, q]^3*c*m^2 + EllipticTheta[1, 2*Pi/9, q]^3*s*c^2 + EllipticTheta[1, 4*Pi/9, q]^3*m*s^2)/EllipticTheta[1, Pi/3, q]^3]
Assert[EllipticTheta[1, u-Pi/9, q]^3 == (-EllipticTheta[1, Pi/9, q]^3*m*c^2 + EllipticTheta[1, 2*Pi/9, q]^3*s*m^2 - EllipticTheta[1, 4*Pi/9, q]^3*c*s^2)/EllipticTheta[1, Pi/3, q]^3];
];
] & // Block[{$AssertFunction = Automatic}, #[]] &;Inverse of Dixon's sm function:
(* Numerical computation *)
InverseDixonSM[z_, alf_] /;
VectorQ[{z, alf}, NumericQ] && Precision[{z, alf}] < Infinity :=
Module[{g2, g3, c, t},
{g2, g3} = {alf/12 (alf^3 - 8), (8 - alf^3 (20 + alf^3))/216};
t = 1 + alf*z;
c = Nearest[c /. {ToRules[NRoots[c^3 + z^3 == 1 + 3*alf*c*z, c]]}, t][[1]];
t = (1 + alf^3)/(3*(c - t));
t = InverseWeierstrassP[{-z*t - alf^2/4, (1 + c)*t}, {g2, g3}];
t /; InexactNumberQ[t]
];
(* Series expansion *)
InverseDixonSM[z, α] == z*(
+ Sum[Pochhammer[n + 2/3, n]/((3*n+1)*n!)*(α*z)^(3*n)*Hypergeometric2F1[n + 1/3, 2*(n + 1/3), n + 4/3, z^3], {n, 0, Infinity}]
- Sum[Pochhammer[n + 4/3, n]/((3*n+2)*n!)*(α*z)^(3*n+1)*Hypergeometric2F1[n + 2/3, 2*(n + 2/3), n + 5/3, z^3], {n, 0, Infinity}]
)
(* Branch points *)
BranchPoints[InverseDixonSM[z, α], z] == {
E^((2/3)*ArcSinh[α^(3/2)]),
E^(-(2/3)*ArcSinh[α^(3/2)]),
E^((2/3)*(ArcSinh[α^(3/2)]+I*Pi)),
E^(-(2/3)*(ArcSinh[α^(3/2)]+I*Pi)),
E^((2/3)*(ArcSinh[α^(3/2)]-I*Pi)),
E^(-(2/3)*(ArcSinh[α^(3/2)]-I*Pi)),
ComplexInfinity
}Last edited by lanxiyu (2025-06-17 15:51:11)
Offline