6
$\begingroup$

Consider:

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[gpts]},
 PlotLegends -> Placed[eqs, {0.8, 0.15}], AspectRatio -> Automatic,
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}],
 AxesLabel -> {x, y}]

How can I mark letters (A and B) on the intersection points of lines and curves in the diagram and the coordinate values of the intersection points in the diagram?

Update 1:

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
Legended[
 Show[ContourPlot[
   Evaluate[eqs], {x, -ax - 0.5, ax + 0.75}, {y, -bx - 0.5,
    bx + 0.75},
   PlotLegends ->
    Placed[LineLegend[eqs, LegendLayout -> "Column"], Below],
   AspectRatio -> Automatic, Frame -> False, Axes -> True,
   AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}],
  ListPlot[{{Tooltip[Callout[pts[[1]], "A", Before]]}, {Tooltip[
      Callout[pts[[2]], "B", Above]]}},
   PlotStyle -> {{Red, AbsolutePointSize[4]}, {Purple,
      AbsolutePointSize[4]}}]],
 Placed[PointLegend[{Red, Purple},
   Row /@ Thread[{{"A = ", "B = "}, pts}]], Below]]

Update 2:

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]*)
(*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*)
Legended[
 Show[ContourPlot[
   Evaluate[eqs], {x, -ax - 0.5, ax + 0.75}, {y, -bx - 0.5,
    bx + 0.75},
   PlotLegends ->
    Placed[LineLegend[eqs, LegendLayout -> "Column"], Below],
   AspectRatio -> Automatic, Frame -> False, Axes -> True,
   AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}],
  ListPlot[{{Tooltip[Callout[pts[[1]], "A", Before]]}, {Tooltip[
      Callout[pts[[2]], "B", Above]]}},
   PlotStyle -> {{Red, AbsolutePointSize[4]}, {Purple,
      AbsolutePointSize[4]}}]],
 Placed[PointLegend[{Red, Purple},
   Row /@ Thread[{{"A = ", "B = "}, pts}]], Below]]

Update 3:

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
Legended[
 Show[ContourPlot[
   Evaluate[eqs], {x, -ax - 0.5, ax + 0.75}, {y, -bx - 0.5, 
    bx + 0.75}, 
   PlotLegends -> 
    Placed[LineLegend[eqs, LegendLayout -> "Column"], Below], 
   AspectRatio -> Automatic, Frame -> False, Axes -> True, 
   AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}, 
   ImageSize -> 500], 
  ListPlot[{{Tooltip[Callout[pts[[1]], "A", Before]]}, {Tooltip[
      Callout[pts[[2]], "B", Above]]}}, 
   PlotStyle -> {{Red, AbsolutePointSize[4]}, {Purple, 
      AbsolutePointSize[4]}}]], 
 Placed[PointLegend[{Red, Purple}, 
   Row /@ Thread[{{"A = ", "B = "}, pts}]], Below]]

Update 4:

This method only displays the coordinates of the intersection point, and the adaptive size

ContourPlot[
 Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, 
 Epilog -> {Red, PointSize[0.02], Point[pts], Black, 
   Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], 
     Background -> White], {pts[[1, 1]], pts[[1, 2]]}, {.15, 1.1}], 
   Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], 
     Background -> White], {pts[[2, 1]], 
     pts[[2, 2]]}, {-0.01, -1.4}]}, 
 PlotLegends -> Placed[eqs, {0.13, 0.9}], AspectRatio -> Automatic, 
 Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], 
 AxesLabel -> {x, y}, ImageSize -> Full]
$\endgroup$
1
  • $\begingroup$ Look at "Text" in the help. Eventually you are also interested in "Style $\endgroup$ Commented Feb 21, 2023 at 13:17

4 Answers 4

8
$\begingroup$
Clear["Global`*"]

line = x == 2 y + 1;
ell = x^2/16 + y^2/9 == 1;
eqs = {ell, line};
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]]];
params = {a -> Sqrt[Denominator[Coefficient[normalized, x^2]]], 
   b -> Sqrt[Denominator[Coefficient[normalized, y^2]]]};

Legended[
 Show[
  ContourPlot[
   Evaluate[eqs], {x, -ax - 0.5, ax + 0.75}, {y, -bx - 0.5, 
    bx + 0.75}, PlotLegends -> Placed[
     LineLegend[eqs, LegendLayout -> "Column"],
     Below],
   AspectRatio -> Automatic, Frame -> False, Axes -> True, 
   AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}],
  ListPlot[{
    {Tooltip[Callout[pts[[1]], "A", Before]]},
    {Tooltip[Callout[pts[[2]], "B", Above]]}},
   PlotStyle -> {{Red, AbsolutePointSize[4]}, {Green, 
      AbsolutePointSize[4]}}]],
 Placed[
  PointLegend[{Red, Green}, Row /@ Thread[{{"A = ", "B = "}, N[pts]}]],
  Below]]

enter image description here

$\endgroup$
4
  • $\begingroup$ Can the coordinate value of the intersection point show the exact value? Displays exact values instead of decimal values. With a root sign or something $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:20
  • $\begingroup$ Placed[PointLegend[{Red, Green}, Row /@ Thread[{{"A = ", "B = "}, pts}]], Below]] $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:32
  • $\begingroup$ How to adjust the size of A and B in the figure? $\endgroup$
    – csn899
    Commented Feb 22, 2023 at 11:29
  • $\begingroup$ Use Style (see docs) $\endgroup$
    – Bob Hanlon
    Commented Feb 22, 2023 at 15:52
6
$\begingroup$

Edit: addressing the comment

ContourPlot[
 Evaluate@{eqs},
 {x, -ax - 1, ax + 1},
 {y, -bx - 0.5, bx + 0.5},
 Epilog -> {
   Red,
   PointSize[0.02],
   Point[gpts],
   Black,
   Text[Framed[Column[{gpts[[1, 1]], gpts[[1, 2]]}], 
     Background -> White], {gpts[[1, 1]], gpts[[1, 2]]}, {2.2, -1.1}],
    Text[Framed[Column[{gpts[[1, 1]], gpts[[1, 2]]}], 
     Background -> White], {gpts[[2, 1]], 
     gpts[[2, 2]]}, {-0.5, -2.7}]},
 PlotLegends -> Placed[eqs, {0.13, 0.9}],
 AspectRatio -> 1,
 Frame -> False,
 Axes -> True,
 AxesStyle -> Arrowheads[{0.0, 0.04}],
 AxesLabel -> {x, y},
 ImageSize -> Full]

pb

Original

plot

Code

ContourPlot[
 Evaluate@{eqs},
 {x, -ax - 1, ax + 1},
 {y, -bx - 0.5, bx + 0.5},
 Epilog -> {
   Red, PointSize[0.02], Point[gpts],
   Black,
   Text[Framed[Column[{gpts[[1, 1]], gpts[[1, 2]]}], 
     Background -> White], {gpts[[1, 1]], gpts[[1, 2]]}, {.15, 1.1}], 
   Text[Framed[Column[{gpts[[1, 1]], gpts[[1, 2]]}], 
     Background -> White], {gpts[[2, 1]], 
     gpts[[2, 2]]}, {-0.01, -1.4}]},
 PlotLegends -> Placed[eqs, {0.13, 0.9}],
 AspectRatio -> 1,
 Frame -> False,
 Axes -> True,
 AxesStyle -> Arrowheads[{0.0, 0.04}],
 AxesLabel -> {x, y},
 ImageSize -> 300]
$\endgroup$
7
  • $\begingroup$ ContourPlot[ Evaluate@{eqs}, {x, -ax - 3, ax + 3}, {y, -bx - 3, bx + 3}, Epilog -> {Red, PointSize[0.02], Point[pts], Black, Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], Background -> White], {pts[[1, 1]], pts[[1, 2]]}, {.15, 1.1}], Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], Background -> White], {pts[[2, 1]], pts[[2, 2]]}, {-0.01, -1.4}]}, PlotLegends -> Placed[eqs, {0.13, 0.9}], AspectRatio -> Automatic, Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}, ImageSize -> 300] $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:28
  • $\begingroup$ Can pictures adapt to size? That is to say, the image can be automatically resized so that the coordinate value and image of the point can be displayed completely $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:37
  • $\begingroup$ @csn899 have a look at the edit, please. is this what you meant? $\endgroup$
    – bmf
    Commented Feb 22, 2023 at 1:25
  • $\begingroup$ ContourPlot[ Evaluate@{eqs}, {x, -ax - 1, ax + 1}, {y, -bx - 0.5, bx + 0.5}, Epilog -> {Red, PointSize[0.02], Point[pts], Black, Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], Background -> White], {pts[[1, 1]], pts[[1, 2]]}, {.15, 1.1}], Text[Framed[Column[{pts[[1, 1]], pts[[1, 2]]}], Background -> White], {pts[[2, 1]], pts[[2, 2]]}, {-0.01, -1.4}]}, PlotLegends -> Placed[eqs, {0.13, 0.9}], AspectRatio -> Automatic, Frame -> False, Axes -> True, AxesStyle -> Arrowheads[{0.0, 0.04}], AxesLabel -> {x, y}, ImageSize -> 450] $\endgroup$
    – csn899
    Commented Feb 22, 2023 at 8:08
  • $\begingroup$ @csn899 I am sorry, but you are just showing some code and I don't understand what point you're trying to make $\endgroup$
    – bmf
    Commented Feb 22, 2023 at 8:10
5
$\begingroup$
Clear["Global`*"]
eq1 = x^2/16 + y^2/9 == 1;
eq2 = x == 2 y + 1;
pts = Solve[{eq1, eq2}, {x, y}];
sf = StringForm["(``,``)", NumberForm[x, {4, 2}], 
     NumberForm[y, {4, 2}]] /. pts // N;
valp = {x, y} /. pts;
ofs = {{1.2, 0}, {-1.2, 0}};
ContourPlot[{eq1, eq2} // Evaluate
 , {x, -5, 5}, {y, -4, 4}
 , AspectRatio -> Automatic
 , Frame -> False
 , Axes -> True
 , AxesLabel -> {x, y}
 , Ticks -> {Range[-6, 6], Range[-4, 4]}
 , AxesStyle -> Arrowheads[{-0.04, 0.04}
   , {-0.04, 0.04}]
 , ImageSize -> 500
 , PlotRangePadding -> Scaled[0.1]
 , Epilog -> {Red, AbsolutePointSize[6]
   , Tooltip[Point[#], #] & /@ valp
   , Black, 
   MapThread[
    Text[Style[#1, 12, FontFamily -> "Courier"], #2, #3] &, {sf, valp,
      ofs}]
   , Black, MapThread[Text[#1, #2, {-0.2, -1.5}] &, {{"A", "B"}, valp}]
   }
 ]

enter image description here

$\endgroup$
4
  • $\begingroup$ Can the coordinate value of the intersection point show the exact value? Displays exact values instead of decimal values. With a root sign or something $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:23
  • $\begingroup$ NumberForm[y, {4, 2}]] /. pts $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:33
  • $\begingroup$ Can pictures adapt to size? That is to say, the image can be automatically resized so that the coordinate value and image of the point can be displayed completely $\endgroup$
    – csn899
    Commented Feb 21, 2023 at 23:47
  • $\begingroup$ Text does not scale as far as I understand it. You can drag and scale the image, but the text size will be constant. You could do additional processing and determine the bounding box, but it will change from function to function. $\endgroup$
    – Syed
    Commented Feb 22, 2023 at 3:24
3
$\begingroup$
Clear[f, g, A, B];
g = x - (2 y + 1);
f = x^2/4^2 + y^2/3^2 - 1;
{A, B} = SolveValues[{f == 0, g == 0}, {x, y}, Reals];
Legended[
 ContourPlot[{f == 0, g == 0}, {x, -4, 4}, {y, -4, 4}, 
  Epilog -> {{Red, AbsolutePointSize[8], Point[A]}, 
    Arrow[{A + {-.5, -1}, A}], 
    Text[Style["A", 14], A + {-.5, -1}, {.5, 1}], 
    Arrow[{A + {-.5, -1}, A}], {Green, AbsolutePointSize[8], 
     Point[B]}, Arrow[{B + {.5, 1}, B}], 
    Text[Style["B", 14], B + {.5, 1}, -{.5, 1}]}, 
  PlotRangePadding -> .6, Frame -> False, Axes -> True, 
  AxesStyle -> Arrowheads[{0.04}]], 
 Placed[PointLegend[{Red, Green}, 
   Row /@ {{"A=" Style[A, 10]}, {"B=" Style[B, 10]}}], Below]]

enter image description here

$\endgroup$
1
  • $\begingroup$ g = x - (2 y + 1); f = x^2/4^2 + y^2/3^2 - 1;I want to input the equation in the form of complete straight line equation and curve equation at the beginning $\endgroup$
    – csn899
    Commented Feb 22, 2023 at 8:15

Your Answer

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

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