Plotting the sum of two points on an elliptic curve
Here's a starting point:
ecp = ContourPlot[y^2 == x (x - 1) (x + 1), {x, -2, 2}, {y, -2, 2}];
ec = RegionNearest[ImplicitRegion[y^2 == x (x - 1) (x + 1), {{x, -2, 2}, {y, -2, 2}}]];
DynamicModule[{pts = {{-1, 0}, {1, 0}, {0, 0}}},
Panel[Row[{LocatorPane[Dynamic[pts, (pts =
Block[{ip = ec /@ Most[#], sol},
sol = {\[FormalX], \[FormalY]} /.
NSolve[{\[FormalY]^2 == \[FormalX]
(\[FormalX] - 1) (\[FormalX] + 1),
\[FormalY] ==
InterpolatingPolynomial[ip, \[FormalX]]},
{\[FormalX], \[FormalY]}];
Append[ip, First[Pick[sol, Normalize[Chop[Min /@
DistanceMatrix[sol, ip], 1.*^-6], Max], 1.]]]];) &],
Show[ecp,
Graphics[{{Yellow, Thick, Dynamic[InfiniteLine[Most[pts]]]},
{PointSize[Large],
{Red, Dynamic[Point[pts[[1]]]]},
{Green, Dynamic[Point[pts[[2]]]]}},
{PointSize[Medium], Brown, Dynamic[Point[pts[[3]]]]}}],
ImageSize -> Medium], Appearance -> None],
Pane[Dynamic[Grid[Transpose[{{Style["Point 1:", Red, Large],
Style["Point 2:", Green, Large],
Style["Point 3:", Brown, Large]},
Style[#, Large] & /@ pts}]]]]}]]]
Extra Credit
Mathematica has the functions EllipticExp[]
and EllipticLog[]
that facilitate the study of the elliptic curve given in the general form $y^2=x^3+ax^2+bx$. (These functions are of course related to the more conventional Weierstrass elliptic functions through a simple change of coordinates.) In particular, these functions make it much easier to show the addition of points. The following will be a manual demonstration; bundling this into a Dynamic[]
demo like the one above is left as an exercise.
Let us again take the elliptic curve $y^2=x(x-1)(x+1)$, corresponding to the parameters $a=0,b=-1$. Generate two random points in the elliptic curve, like so:
ecr = ImplicitRegion[y^2 == x (x - 1) (x + 1), {{x, -2, 2}, {y, -2, 2}}];
BlockRandom[SeedRandom["elliptic"]; (* for reproducibility *)
(* Quiet suppresses a few harmless error messages *)
{p1, p2} = Quiet[RandomPoint[ecr, 2]];]
To add p1
and p2
over the given elliptic curve, do this:
p3 = Chop[EllipticExp[EllipticLog[p1, {0, -1}] + EllipticLog[p2, {0, -1}], {0, -1}]];
Show the addition graphically:
ContourPlot[y^2 == x (x - 1) (x + 1), {x, -2, 2}, {y, -2, 2},
Epilog -> {{Orange, {Thick, InfiniteLine[{p1, p2}]},
{Dashed, Line[{{1, -1} p3, p3}]}},
{PointSize[Large], {Red, Point[p1]}, {Green, Point[p2]}},
{PointSize[Medium], Brown, Point[p3]}}]
Check the collinearity of the two points and the reflection of the addition point:
Chop[Det[PadRight[{p1, p2, {1, -1} p3}, {3, 3}, 1]]]
0
The fine solution offered by J. M. above works in Mma version 11, but not in 10.1 -- it uses the newer semantics for DistanceMatrix. To also work in an earlier version, you can use the following solution, using Complement[] instead of DistanceMatrix[]. (My newbie (low) reputation won't let me post comments, hence this fresh answer.)
ecp = ContourPlot[y^2 == x (x - 1) (x + 1), {x, -2, 2}, {y, -2, 2}];
ec = RegionNearest[ImplicitRegion[y^2 == x (x - 1) (x + 1), {{x, -2, 2}, {y, -2, 2}}]];
DynamicModule[{pts = {{-1, 0}, {1, 0}, {0, 0}}},
Panel[Row[{LocatorPane[Dynamic[pts, (pts =
Block[{ip = ec /@ Most[#], sol},
sol = {\[FormalX], \[FormalY]} /.
NSolve[{\[FormalY]^2 == \[FormalX]
(\[FormalX] - 1) (\[FormalX] + 1),
\[FormalY] ==
InterpolatingPolynomial[ip, \[FormalX]]},
{\[FormalX], \[FormalY]}];
Append[ip, First[Complement[sol, ip, SameTest->(Norm[#1-#2]<1*^-5&)]]]];) &],
Show[ecp,
Graphics[{{Yellow, Thick, Dynamic[InfiniteLine[Most[pts]]]},
{PointSize[Large],
{Red, Dynamic[Point[pts[[1]]]]},
{Green, Dynamic[Point[pts[[2]]]]}},
{PointSize[Medium], Brown, Dynamic[Point[pts[[3]]]]}}],
ImageSize -> Medium], Appearance -> None],
Pane[Dynamic[Grid[Transpose[{{Style["Point 1:", Red, Large],
Style["Point 2:", Green, Large],
Style["Point 3:", Brown, Large]},
Style[#, Large] & /@ pts}]]]]}]]]