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. is computer-less Oct 2 '16 at 13:49
  • @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 Oct 2 '16 at 13:57
  • 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. is computer-less Oct 2 '16 at 13:59
  • @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 Oct 2 '16 at 14:02
up vote 12 down vote accepted

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

elliptic curve addition demo


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

elliptic curve addition via elliptic functions

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 Oct 2 '16 at 17:31
  • 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. is computer-less Oct 3 '16 at 4:40
  • 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 Oct 4 '16 at 18:52
  • Have a look at the part where I used DistanceMatrix[]. – J. M. is computer-less Oct 4 '16 at 18:58
  • 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 Oct 4 '16 at 19:30

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 Oct 18 '17 at 11:46
  • 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 Oct 18 '17 at 15:10

Your Answer

 
discard

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Not the answer you're looking for? Browse other questions tagged or ask your own question.