How to make the code related to line and ellipse more concise？

Question

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*)

That is a lot of code! – Peter Mortensen Jan 28 '23 at 19:56 — Peter Mortensen, Jan 28 '23 at 19:56
Every code is updating iteration! – csn899 Feb 20 '23 at 07:42 — csn899, Feb 20 '23 at 07:42

Daniel Huber · Accepted Answer · 2023-01-25T08:27:47.873

1

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

edited Jan 25 '23 at 08:27

answered Jan 23 '23 at 10:27

Daniel Huber

51,463
1
23
57

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? – csn899 Jan 24 '23 at 01:51
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 – csn899 Jan 25 '23 at 03:46
Calculation error, the equation should be: gell = b {-1, 1} Sqrt[1 - x^2/a^2] /. params; ：） – csn899 Jan 25 '23 at 04:02
Sorry, but this is also not correct. I fixed it: b {-1, 1} Sqrt[2 - x^2/a^2] /. params – Daniel Huber Jan 25 '23 at 08:27
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; – csn899 Jan 27 '23 at 12:05
{{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) – csn899 Jan 27 '23 at 12:05
The above 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. – csn899 Jan 27 '23 at 12:07

How to make the code related to line and ellipse more concise？

1 Answers1

Linked