1
$\begingroup$

My needs are shown in the picture is.

**1. Calculate the equation after a straight line and an ellipse are simultaneous (eliminate x)

The desired result is:

(b^2 + a^2 k^2) x^2 + 2 a^2 k m x + (-a^2 b^2 + a^2 m^2) == 0

2.Calculating the discriminant of simultaneous equations

The desired result is:

4 a^2 b^2 (b^2 + a^2 k^2 - m^2)

3.Calculate Veda of simultaneous equations (x1+x2, x1 x2, y1+y2, y1 y2, x1 x2+y1 y2, x1 y2+x2 y1)

The desired result is:

-((2 a^2 k m)/(b^2 + a^2 k^2)), (a^2 (-b^2 + m^2))/(b^2 + a^2 k^2)

4.Calculate the chord AB length where the ellipse intersects the line**

The desired result is:

2 Sqrt[1 + k^2] Sqrt[(a^2 b^2 (b^2 + a^2 k^2 - m^2))/(b^2 + a^2 k^2)^2 ]

My own attempts and tips from enthusiastic friends helped write these codes, and I think it can be optimized.

It is better to use the symbols in the picture to represent the corresponding results.

Such as：

x1+x2=-((2 a^2 k m)/(b^2 + a^2 k^2)) and so on

How can we further optimize it? Thank you!

The code is as follows:

eqns = {x^2/a^2 + y^2/b^2 == 1, y == k x + m};
polyex = Apply[Subtract, eqns, {1}];
polys = Numerator[Together[Apply[Subtract, eqns, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], y], x];
xp1 = Collect[xpoly, x, # &, Defer[+##]~Reverse~2 &];

xp = Collect[
   Coefficient[xpoly, x^2] x^2 + 
    Factor@FactorTerms[Coefficient[xpoly, x], x] x + 
    Select[xpoly, FreeQ[x]], x, # &, Defer[+##]~Reverse~2 &];

eqn = {xp == 0}
discx = Factor[Discriminant[xpoly, x]]
frist = Solve[eqns, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
    second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify

thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], x][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
 x][[1]] ;  (*m*)
    Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)

    area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Clear["`*"]

eqns = {x^2/a^2 + y^2/b^2 == 1, y == k (x - x0) + y0}; 

line = eqns[[2]]

ell = eqns[[1]]

pts = SolveValues[{line, ell}, {x, y}];

normalized = First[ell] - Last[ell]

params = {a -> Sqrt[Denominator[Coefficient[normalized, x^2]]], 
  b -> Sqrt[Denominator[Coefficient[normalized, y^2]]]}

glin = line[[2]] /. params;

gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params;

gpts = pts /. params;

Plot[{{glin, gell}}, {x, -a, a} /. params, 
 Epilog -> {Red, PointSize[0.02], Point[gpts]}]

polyex = Apply[Subtract, eqns, {1}];

polys = Numerator[Together[Apply[Subtract, eqns, {1}]]];

xpoly = Collect[Resultant[polys[[1]], polys[[2]], y], x];

xp1 = Collect[xpoly, x, # &, Defer[+##]~Reverse~2 &];

xp = Collect[
   Coefficient[xpoly, x^2] x^2 + 
    Factor@FactorTerms[Coefficient[xpoly, x], x] x + 
    Select[xpoly, FreeQ[x]], x, # &, Defer[+##]~Reverse~2 &];

eqn = {xp == 0}

discx = Factor[Discriminant[xpoly, x]]   (*discriminant*)

{{x1, y1}, {x2, y2}} = SolveValues[eqns, {x, y}] // FullSimplify;

second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify

thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify

slope = -CoefficientList[polyex[[2]], x][[2]];    (*k*)

intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)

Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)

area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code update1：

Clear["Global`*"]
eqs = {x^2/a^2 + y^2/b^2 == 1, y == k x + m}; 
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ass = ResourceFunction["EllipseProperties"][ell, {x, y}];
params = {a -> ass["SemimajorAxisLength"], 
  b -> ass["SemiminorAxisLength"]}
(*params={a->Sqrt[Denominator[Coefficient[normalized,x^2]]],b->Sqrt[\
Denominator[Coefficient[normalized,y^2]]]};*)
glin = line[[2]] /. params;
gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params;
gpts = pts /. params;
Plot[{{glin, gell}}, {x, -a, a} /. params, 
 Epilog -> {Red, PointSize[0.02], Point[gpts]}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update2:

Clear["Global`*"]
eqs = {x^2/a^2 + y^2/b^2 == 1, y == k x + m};  
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
(*normalized=First[ell]-Last[ell];*)
ass = ResourceFunction["EllipseProperties"][ell, {x, y}];
(*https://resources.wolframcloud.com/FunctionRepository/resources/\
EllipseProperties*)
params = {a -> ass["SemimajorAxisLength"], 
  b -> ass["SemiminorAxisLength"]}
(*params={a->Sqrt[Denominator[Coefficient[normalized,x^2]]],b->Sqrt[\
Denominator[Coefficient[normalized,y^2]]]};*)
glin = line[[2]] /. params;
gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params;
gpts = pts /. params;
Plot[{{glin, gell}}, {x, -a, a} /. params, 
 Epilog -> {Red, PointSize[0.02], Point[gpts]}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update 3:

Clear["Global`*"]
eqs = {x^2/9 + y^2/8 == 1, y == 2 x + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
(*ass=ResourceFunction["EllipseProperties"][ell,{x,y}];*)
(*https://resources.wolframcloud.com/FunctionRepository/resources/\
EllipseProperties*)
(*params={a->ass["SemimajorAxisLength"],b->ass["SemiminorAxisLength"]}\
*)
params = {a -> Sqrt[Denominator[Coefficient[normalized, x^2]]], 
   b -> Sqrt[Denominator[Coefficient[normalized, y^2]]]};
glin = line[[2]] /. params;
gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params;
gpts = pts /. params;
Plot[{{glin, gell}}, {x, -a, a} /. params, 
 Epilog -> {Red, PointSize[0.02], Point[gpts]}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]];  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update4:

Clear["Global`*"]
eqs = {x^2/a^2 + y^2/b^2 == 1, y == k  x + m};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
(*ass=ResourceFunction["EllipseProperties"][ell,{x,y}];*)
(*https://resources.wolframcloud.com/FunctionRepository/resources/\
EllipseProperties*)
(*params={a->ass["SemimajorAxisLength"],b->ass["SemiminorAxisLength"]}\
*)
(*params={a->Sqrt[Denominator[Coefficient[normalized,x^2]]],b->Sqrt[\
Denominator[Coefficient[normalized,y^2]]]};*)
(*glin=line[[2]]/. params;
gell=b {-1,1} Sqrt[1-x^2/a^2]/. params;
gpts=pts/. params;
Plot[{{glin,gell}},{x,-a,a}/. \
params,Epilog->{Red,PointSize[0.02],Point[gpts]}]*)
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]];  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update5

Clear["Global`*"]
eqs = {x^2/81 + y^2/9 == 1, y == 2 x + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
(*ass=ResourceFunction["EllipseProperties"][ell,{x,y}];*)
(*https://resources.wolframcloud.com/FunctionRepository/resources/\
EllipseProperties*)
(*params={a->ass["SemimajorAxisLength"],b->ass["SemiminorAxisLength"]}\
*)
(*params={a->Sqrt[Denominator[Coefficient[normalized,x^2]]],b->Sqrt[\
Denominator[Coefficient[normalized,y^2]]]};*)
(*glin=line[[2]]/. params;
gell=b {-1,1} Sqrt[1-x^2/a^2]/. params;
gpts=pts/. params;
Plot[{{glin,gell}},{x,-a,a}/. \
params,Epilog->{Red,PointSize[0.02],Point[gpts]}]*)
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[Coefficient[xpl, x^2] x^2 + 
   Factor@FactorTerms[Coefficient[xpl, x], x] x + 
   Select[xpl, FreeQ[x]], x, # &, Defer[+##]~Reverse~2 &] == 0
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]];  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update6:

Clear["Global`*"]
eqs = {x^2/4 + y^2/3 == 1, y == 2 x + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
p = Plot[y /. Solve[line, y], {x, -ax - 0.5, ax + 0.5}];
pts = SolveValues[{line, ell}, {x, y}]
Graphics[{{First@p}, {Red, Circle[{0, 0}, {ax, bx}], 
   Point[{0, 0}]}, {Blue, PointSize[.03], Point[pts]}}, Axes -> True, 
 AxesLabel -> {x, y}, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AspectRatio -> 1]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[Coefficient[xpl, x^2] x^2 + 
   Factor@FactorTerms[Coefficient[xpl, x], x] x + 
   Select[xpl, FreeQ[x]], x, # &, Defer[+##]~Reverse~2 &] == 0
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]];  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

Code Update7:

Clear["Global`*"]
eqs = {x^2/4 + y^2/3 == 1, y == 2 x + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
p = Plot[y /. Solve[line, y], {x, -ax - 0.5, ax + 0.5}];
pts = SolveValues[{line, ell}, {x, y}]
(*Graphics[{{First@p},{Red,Circle[{0,0},{ax,bx}],Point[{0,0}]},{Blue,\
PointSize[.03],Point[pts]}},Axes->True,AxesLabel->{x,y},AxesStyle->\
Arrowheads[{0.0,0.04}],AspectRatio->1]*)
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
plx = Apply[Subtract, eqs, {1}];
pls = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpl = Collect[Resultant[pls[[1]], pls[[2]], y], x];
Collect[Coefficient[xpl, x^2] x^2 + 
   Factor@FactorTerms[Coefficient[xpl, x], x] x + 
   Select[xpl, FreeQ[x]], x, # &, Defer[+##]~Reverse~2 &] == 0
Collect[xpl, x, Simplify];
pl = {% == 0}
discx = Factor[Discriminant[xpl, x]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2, 
   y1 y2/(x1 x2), (x1 + x2)/2, (y1 + y2)/2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = CoefficientList[line[[2]], x][[2]];    (*k*)
intercept = CoefficientList[line[[2]], x][[1]];  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(x1 + x2)^2 - 4 x1 x2]]    (*AbsAB*)
area = 1/2 Chordlength Sqrt[intercept^2]/Sqrt[slope^2 + 1] // 
  FullSimplify

The follow code shows how to draw the image of straight line and ellipse. The linear equation is in the form of x=ty+n. The linear equation and the elliptic equation are combined to eliminate the parameter x and obtain a univariate quadratic equation about y.

ClearAll[Evaluate[Context[] <> "*"]]
eqns = {x^2/a^2 + y^2/b^2 == 1, x == t y + n}; 
polyex = Apply[Subtract, eqns, {1}];
polys = Numerator[Together[Apply[Subtract, eqns, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y]
discx = Factor[Discriminant[xpoly, y]]   (*discriminant*)
frist = Solve[eqns, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], y][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(y1 + y2)^2 - 4 y1 y2]]    (*AbsAB*)

Code Update1:

ClearAll["`*"]
eqs = {x^2/16 + y^2/9 == 1, x == 2 y + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
(*ass=ResourceFunction["EllipseProperties"][ell,{x,y}];
params={a->ass["SemimajorAxisLength"],b->ass["SemiminorAxisLength"]}\
*)(*params={a->Sqrt[Denominator[Coefficient[normalized,x^2]]],b->Sqrt[\
Denominator[Coefficient[normalized,y^2]]]}
glin=line[[2]]/. params
gell=b {-1,1} Sqrt[1-x^2/a^2]/. params;
gpts=pts/. params;*)
(*Hold@ContourPlot[Evaluate@{eqs},{x,-a-1,a+1},{y,-b-0.5,b+0.5},\
PlotLegends->Placed[eqs,{0.8,0.15}],AspectRatio->Automatic,Frame->\
False,Axes->True,AxesStyle->Arrowheads[{0.0,0.04}],AxesLabel->{x,y}]/. \
params//ReleaseHold*)
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
polyex = Apply[Subtract, eqs, {1}];
polys = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y];
ypl = Collect[xpoly, y, Simplify]
Collect[Coefficient[xpoly, y^2] y^2 + 
   Factor@FactorTerms[Coefficient[xpoly, y], y] y + 
   Select[xpoly, FreeQ[y]], y, # &, Defer[+##]~Reverse~2 &] == 0
discx = Factor[Discriminant[xpoly, y]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], y][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(y1 + y2)^2 - 4 y1 y2]]    (*AbsAB*)

Code Update2:

ClearAll["`*"]
eqs = {x^2/16 + y^2/9 == 1, x == 2 y + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
p = Plot[y /. Solve[line, y], {x, -ax - 0.5, ax + 0.5}];
pts = SolveValues[{line, ell}, {x, y}]
Graphics[{{First@p}, {Red, Circle[{0, 0}, {ax, bx}], 
   Point[{0, 0}]}, {Blue, PointSize[.03], Point[pts]}}, Axes -> True, 
 AxesLabel -> {x, y}, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AspectRatio -> Automatic]
polyex = Apply[Subtract, eqs, {1}];
polys = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y];
ypl = Collect[xpoly, y, Simplify]
Collect[Coefficient[xpoly, y^2] y^2 + 
   Factor@FactorTerms[Coefficient[xpoly, y], y] y + 
   Select[xpoly, FreeQ[y]], y, # &, Defer[+##]~Reverse~2 &] == 0
discx = Factor[Discriminant[xpoly, y]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], y][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(y1 + y2)^2 - 4 y1 y2]]    (*AbsAB*)

Code Update3:

ClearAll["`*"]
eqs = {x^2/16 + y^2/9 == 1, x == 2 y + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
p = Plot[y /. Solve[line, y], {x, -ax - 0.5, ax + 0.5}];
pts = SolveValues[{line, ell}, {x, y}]
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
polyex = Apply[Subtract, eqs, {1}];
polys = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y];
ypl = Collect[xpoly, y, Simplify]
Collect[Coefficient[xpoly, y^2] y^2 + 
   Factor@FactorTerms[Coefficient[xpoly, y], y] y + 
   Select[xpoly, FreeQ[y]], y, # &, Defer[+##]~Reverse~2 &] == 0
discx = Factor[Discriminant[xpoly, y]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], y][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(y1 + y2)^2 - 4 y1 y2]]    (*AbsAB*)

Code Update4:

eqs = {x^2/16 + y^2/9 == 1, x == 2 y + 1};
line = eqs[[2]]
ell = eqs[[1]]
pts = SolveValues[{line, ell}, {x, y}];
normalized = First[ell] - Last[ell];
ax = Sqrt[Denominator[Coefficient[normalized, x^2]]]
bx = Sqrt[Denominator[Coefficient[normalized, y^2]]]
p = Plot[y /. Solve[line, y], {x, -ax - 0.5, ax + 0.5}];
pts = SolveValues[{line, ell}, {x, y}]
(*Graphics[{{First@p},{Red,Circle[{0,0},{ax,bx}],Point[{0,0}]},{Blue,\
PointSize[.03],Point[pts]}},Axes->True,AxesLabel->{x,y},AxesStyle->\
Arrowheads[{0.0,0.04}],AspectRatio->Automatic]*)
ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts]}, 
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}]
polyex = Apply[Subtract, eqs, {1}];
polys = Numerator[Together[Apply[Subtract, eqs, {1}]]];
xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y];
ypl = Collect[xpoly, y, Simplify]
Collect[Coefficient[xpoly, y^2] y^2 + 
   Factor@FactorTerms[Coefficient[xpoly, y], y] y + 
   Select[xpoly, FreeQ[y]], y, # &, Defer[+##]~Reverse~2 &] == 0
discx = Factor[Discriminant[xpoly, y]]   (*discriminant*)
frist = Solve[eqs, {x, y}] // FullSimplify;
{{x1, y1}, {x2, y2}} = {x, y} /. frist;
second = {x1 + x2, x1 x2, y1 + y2, y1 y2} // FullSimplify
thrid = {x1 x2 + y1 y2, x1 y2 + x2 y1} // FullSimplify
slope = -CoefficientList[polyex[[2]], y][[2]];    (*k*)
intercept = -CoefficientList[CoefficientList[polyex[[2]], y][[1]], 
     x][[1]] ;  (*m*)
Chordlength = 
 FullSimplify[
  Sqrt[1 + slope^2] Sqrt[(y1 + y2)^2 - 4 y1 y2]]    (*AbsAB*)
Improve this question
$\endgroup$
2
  • $\begingroup$ That is a lot of code! $\endgroup$
    – Peter Mortensen
    Jan 28 at 19:56
  • $\begingroup$ Every code is updating iteration! $\endgroup$
    – csn899
    Feb 20 at 7:42

1 Answer 1

Reset to default
1
$\begingroup$

This can be written rather shortly:

line = y == k x + m;
ell = x^2/a^2 + y^2/b^2 == 1;
pts = SolveValues[{line, ell}, {x, y}];

To test we choose some parameters and draw a picture:

params = {k -> 1, m -> 1, a -> 2, b -> 1};
glin = line[[2]] /. params;
gell = b {-1, 1} Sqrt[2 - x^2/a^2] /. params;
gpts = pts /. params;
Plot[{{glin, gell}}, {x, -2, 2}, 
 Epilog -> {Red, PointSize[0.02], Point[gpts]}]

enter image description here

Improve this answer
$\endgroup$
7
  • $\begingroup$ thank you! Your code is very concise and clear. Even the pictures of ellipse and straight line are added. This effect is also what I want. I didn't edit the post clearly before, but now I have edited the post again. There are four specific requirements. Can you help me optimize the code according to these requirements? $\endgroup$
    – csn899
    Jan 24 at 1:51
  • $\begingroup$ An error occurred： line = y == k x + m; ell = x^2/a^2 + y^2/b^2 == 1; pts = SolveValues[{line, ell}, {x, y}]; params = {k -> 2, m -> -1, a -> 2, b -> Sqrt[3]}; glin = line[[2]] /. params; gell = b^2 {-1, 1} Sqrt[1 - x^2/a^2] /. params; gpts = pts /. params; Plot[{{glin, gell}}, {x, -2, 2}, Epilog -> {Red, PointSize[0.02], Point[gpts]}]The image drawn after trying this set of code is incorrect $\endgroup$
    – csn899
    Jan 25 at 3:46
  • $\begingroup$ Calculation error, the equation should be: gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params; ：） $\endgroup$
    – csn899
    Jan 25 at 4:02
  • $\begingroup$ Sorry, but this is also not correct. I fixed it: b {-1, 1} Sqrt[2 - x^2/a^2] /. params $\endgroup$
    – Daniel Huber
    Jan 25 at 8:27
  • $\begingroup$ ClearAll[Evaluate[Context[] <> ""]] eqns = {x^2/a^2 + y^2/b^2 == 1, x == t y + n}; polyex = Apply[Subtract, eqns, {1}]; polys = Numerator[Together[Apply[Subtract, eqns, {1}]]]; xpoly = Collect[Resultant[polys[[1]], polys[[2]], x], y] discx = Factor[Discriminant[xpoly, y]] (*discriminant) frist = Solve[eqns, {x, y}] // FullSimplify; $\endgroup$
    – csn899
    Jan 27 at 12:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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