## Plotting the sum of two points on an elliptic curve

8

5

I am doing an experiment to prove the associativity of the addition of points on an elliptic curve. So far, I have produced a code which allows me to move points on my curve.

To find their sum, I need to draw a line till it intersects a curve in the third point, then mirror this point around $x$ axis and put a dot there.

But I am completely stuck in this moment. I have tried using NSolve with InterpolatingPolynomial, but got no result.

Here is the code so far:

Extr = {x /. #, y /. #} &;
Att =
Extr[
NMinimize[{(x - #[[1]])^2 + (y - #[[2]])^2, x - x^3 + y^2 == 0}, {x, y}, AccuracyGoal -> 10, PrecisionGoal -> 8][[2]]] &;

DynamicModule[{loc1 = {0, 0}, pt1 = {0, 0}, pt2 = {1, 0}, loc2 = {1, 0}, pt3= {-1, 0}},
{
LocatorPane[Dynamic[{loc1, loc2}],
ContourPlot[{y^2 - x (x - 1) (x + 1) == 0}, {x, -2, 2}, {y, -2, 2},
AxesLabel -> Automatic, ImageSize -> 600,
Epilog -> {Red, PointSize[Large],
Point[Dynamic[pt1 = Att[loc1]]],
Green,
Point[Dynamic[pt2 = Att[loc2]]],
Yellow, Thick,
Dynamic[InfiniteLine[{pt1, pt2}]]
}
]
],
Dynamic[{pt1, pt2, pt3}];
}
]


How should I get a point of intersection into pt3 so it will be of the same type as pt1 and pt2?

To clarify: your example elliptic curve here is $y^2=x(x-1)(x+1)$? Are the two points to be added always on the oval, or can they be on the branch? – J. M.'s ennui – 2016-10-02T13:49:47.807

@J.M. Yes, $y^2=x(x-1)(x+1)$. The points can be added anywhere, but at first one is on the oval, another on the branch – Michael Freimann – 2016-10-02T13:57:30.440

I see; you wouldn't have anything to demonstrate if both points to be added were on the branch, after all. So, either one on the oval and one on the branch, or both on the oval, correct? Just so I can determine whether to use heavy machinery or not: do you know about elliptic functions? – J. M.'s ennui – 2016-10-02T13:59:26.020

@J.M. No, I don't know. In fact, we assume that the user is good and we will always have something to demonstate – Michael Freimann – 2016-10-02T14:02:59.527

12

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}]];


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


This seems like totally new, but thanx. Is there any way to easily modify my code to get the same result? I wolud appreciate this more. – Michael Freimann – 2016-10-02T17:31:42.177

It actually grew out of your code; note in particular that I use RegionNearest[] to do what Att does in your code. It also seemed much easier to perform all the elliptic curve calculations within the first Dynamic[], so I did that instead. – J. M.'s ennui – 2016-10-03T04:40:42.137

I Have finally made it work, using just Point[Dynamic[ pt12 = First[{X, -Y} /. NSolve[{X, Y} \[Element] InfiniteLine[{pt1, pt2}] && Y^2 - X (X - 1) (X + 1) == 0& {X, Y} != pt1 && {X, Y} != pt2, {X, Y}]]]]. The problem is that there are three solutions for this thing, so pt12 is not always the third point, but sometimes the pt1 or pt2. How can I get the third one? – Michael Freimann – 2016-10-04T18:52:18.190

Have a look at the part where I used DistanceMatrix[]. – J. M.'s ennui – 2016-10-04T18:58:36.027

I am quite new to Wolfram, though I am close to understanding what you have suggested. But is there an easy way like this (one doesn't work): pt12 = First[{X, -Y} /. NSolve[{X, Y} \[Element] InfiniteLine[{pt1, pt2}] && Y^2 - X (X - 1) (X + 1) == 0 && Abs[X - First[pt1]] > 10^(-6) && Abs[X - First[pt2]] > 10^(-6), {X, Y}]] – Michael Freimann – 2016-10-04T19:30:01.463

J.M. It finally works. Thanx! – Michael Freimann – 2016-10-04T20:31:13.860

2

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}]]]]}]]]


Side note, inside the definition of pts, you can add x and y in the declared Block variables. This allows you to use regular x and y all the way instead of \[FormalX] which can't be rendered on stack exchange. – Musang – 2017-10-18T11:46:09.030

Thanks for the presentation suggestion, @Mustang. FYI, I left \[FormalX] and \[FormalY] in my answer to minimize changes to the original post by J.M. -- I both wanted to highlight only the difference, and to help demonstrate those interesting features which I had not used before. – Jskud – 2017-10-18T15:10:36.163