1
$\begingroup$

I want to write a piece of general code that can simultaneously solve and plot two types of the system of two-variable nonlinear homogeneous equations. The first type of system has numerical solutions, i.e., coordinate points (which may be more than one), while the second type has analytical solutions, i.e., curves. It is also possible that a system of equations has no solution. I want the code to be flexible enough to handle these different types of solutions. I have written Code 1 and Code 2, but each one only works for one type of equation system. Please help me modify and combine these two pieces of code to create a more general-purpose solution. Thank you in advance!

Code 1 (Type 1):

ClearAll["Global`*"]; (*Define the system of equations*) system = {x + y == 0, x^2 - y == 0}; (*Use Reduce to solve the system*) solutions = Reduce[system, {x, y}, Reals]; (*Output the solutions*) Print["Solutions: ", solutions]; (*Initialize lists to store functions and points*) funcs = {}; points = {}; (*Use LogicalExpand to split the solutions*) cases = List @@ LogicalExpand[solutions]; (*Iterate over each solution*) Do[(*Solve each case*)sol = Solve[case, {x, y}, Reals]; If[Length[sol] > 0,(*Extract and store solutions*)Do[xVal = x /. s; yVal = y /. s; AppendTo[points, {xVal, yVal}], {s, sol}]], {case, cases}]; (*Output the extracted solutions*) If[funcs =!= {}, Print["Curve solutions: ", funcs];]; If[points =!= {}, Print["Discrete point solutions: ", points];]; (*Plot the solutions*) Module[{plotFuncs, plotPoints, combinedPlot},(*Plot all function solutions*) If[funcs =!= {}, plotFuncs = Plot[Evaluate[funcs], {x, -5, 5}, PlotStyle -> Blue, PlotRange -> All, AxesLabel -> {"x", "y"}, PlotLabel -> "Solutions of the system"], plotFuncs = Nothing]; (*Plot all discrete point solutions*) If[points =!= {}, plotPoints = ListPlot[points, PlotStyle -> {Red, PointSize[Large]}], plotPoints = Nothing]; (*Combine plots*) combinedPlot = Show[Sequence @@ DeleteCases[{plotFuncs, plotPoints}, Nothing], PlotRange -> All, AxesLabel -> {"x", "y"}, PlotLabel -> "Solutions of the system", ImageSize -> Large]; (*Display the combined plot*)combinedPlot]

Output:

Solutions: (x==-1||x==0)&&y==-x Discrete point solutions: {{-1,1},{0,0}}

Code 2 (Type 2):

ClearAll["Global`*"]; (*Define the system of equations*) system = {x y - x^3 == 0, y^2 - 2 x^2 y + x^4 == 0}; (*Use Reduce to solve the system*) solutions = Reduce[system, {x, y}, Reals]; (*Output the solutions*) Print["Solutions: ", solutions]; (*Initialize lists to store functions and points*) funcs = {}; points = {}; (*Use logical operators to split different solutions*) If[StringContainsQ[ToString[solutions], "||"],(*Split multiple solutions*) cases = ToExpression[ "{" <> StringReplace[ToString[solutions], "||" -> ","] <> "}"];,(*Single solution*)cases = {solutions};]; (*Iterate over each solution*) Do[(*If the solution is y==f(x)*) If[MatchQ[case, y == _],(*Extract the function f(x) and add to funcs list*) AppendTo[funcs, case[[2]]],(*Otherwise, assume it's a discrete point solution*) If[MatchQ[case, And[_, _]],(*Extract x and y values*) xVal = x /. Solve[case, x, Reals]; yVal = y /. Solve[case, y, Reals]; (*If both can be successfully extracted and are unique, add to points list*) If[Length[xVal] == 1 && Length[yVal] == 1, AppendTo[points, {xVal[[1]], yVal[[1]]}]]]], {case, cases}]; (*Output the extracted solutions*) If[funcs =!= {}, Print["Curve solutions: ", funcs];]; If[points =!= {}, Print["Discrete point solutions: ", points];]; (*Plot the solutions*) Module[{plotFuncs, plotPoints, combinedPlot},(*Plot all function solutions*) If[funcs =!= {}, plotFuncs = Plot[Evaluate[funcs], {x, -5, 5}, PlotStyle -> Blue, PlotRange -> All, AxesLabel -> {"x", "y"}, PlotLabel -> "Solutions of the system"];, plotFuncs = Nothing;]; (*Plot all discrete point solutions*) If[points =!= {}, plotPoints = ListPlot[points, PlotStyle -> {Red, PointSize[Large]}];, plotPoints = Nothing;]; (*Combine plots:Only call Show when there are valid graphical \ objects*)combinedPlot = Show[Sequence @@ DeleteCases[{plotFuncs, plotPoints}, Nothing], PlotRange -> All, AxesLabel -> {"x", "y"}, PlotLabel -> "Solutions of the system", ImageSize -> Large]; (*Display the combined plot*)combinedPlot]

Output:

Solutions: y==x^2 Curve solutions: {x^2}

Type 3: No solutions

Updated

I have integrated a piece of code that successfully works for these two systems of equations, but its generality has not yet been tested.

ClearAll["Global`*"]; (*General function:Solve equations and plot*) SolveAndPlot[system_] := Module[{solutions, plot, points, exprs, xRange, yRange, labels, equations},(*Try to find analytical solutions*) solutions = Solve[system, {x, y}, Reals]; (*Check if solutions are empty*) If[solutions === {} || Head[solutions] === Solve,(*If no analytical solutions, use numerical methods*) solutions = NSolve[system, {x, y}, Reals];]; (*Check if solutions are numerical (points)*) If[AllTrue[solutions, Function[sol, And[KeyExistsQ[sol, x], KeyExistsQ[sol, y], NumericQ[x /. sol], NumericQ[y /. sol]]]],(*Extract and plot points*) points = ({x, y} /. #) & /@ solutions; (*Generate coordinate labels for points*) labels = Text[Style[ToString[#], 12], #, {0, 1}] & /@ points; (*Automatically determine plot range*) xRange = MinMax[points[[All, 1]]] + {-1, 1}; yRange = MinMax[points[[All, 2]]] + {-1, 1}; plot = ListPlot[points, PlotStyle -> Red, PlotRange -> {xRange, yRange}, AxesLabel -> {"x", "y"}, PlotMarkers -> {Automatic, 10}, Epilog -> labels],(*Otherwise, assume solutions are functions and plot curves*) exprs = y /. solutions; (*Get equations of analytical solutions*) equations = ToString[TraditionalForm[HoldForm[y == #]]] & /@ exprs; (*Automatically determine plot range*)xRange = {-10, 10}; plot = Plot[Evaluate[exprs], {x, xRange[[1]], xRange[[2]]}, PlotRange -> All, AxesLabel -> {"x", "y"}, PlotLegends -> Placed[equations, Above]]]; (*Return solutions and plot*){solutions, plot}] (*Example:First type of system*) system1 = {x + y == 0, x^2 - y == 0}; {solutions1, plot1} = SolveAndPlot[system1]; (*Output solutions and display plot for the first system*) solutions1 plot1 (*Example:Second type of system*) system2 = {x y - x^3 == 0, y^2 - 2 x^2 y + x^4 == 0}; {solutions2, plot2} = SolveAndPlot[system2]; (*Output solutions and display plot for the second system*) solutions2 plot2
Improve this question
$\endgroup$
2
  • $\begingroup$ There is the command "Solve" or "NSolve". Look it up in the help. $\endgroup$ Commented Nov 15, 2024 at 8:19
  • $\begingroup$ You are right, thank you. @Daniel Huber $\endgroup$ Commented Nov 15, 2024 at 13:45

1 Answer 1

Reset to default
3
$\begingroup$

Using ContourPlot

$Version (* "14.1.0 for Mac OS X ARM (64-bit) (July 16, 2024)" *) Clear[t, w, x, y, plot] plot[system_, variables_ : Automatic, pltRng_ : {{-10, 10}, {-10, 10}}] := Module[{funcs, solutions, vars}, vars = If[variables === Automatic, Variables[Level[system, {-1}]], variables]; solutions = Quiet@Solve[system, vars, Reals, Method -> Reduce]; funcs = Select[solutions, Length@# == 1 &][[All, 1, -1]]; Show[ ContourPlot[system, Evaluate[Sequence @@ (Join @@@ Transpose[{List /@ vars, pltRng}])], FrameLabel -> (Style[#, 14] & /@ vars), PlotLabel -> StringForm["solutions: ``\n", solutions]], ListPlot[Tooltip[vars] /. solutions, PlotStyle -> Red], Plot[Evaluate[Tooltip /@ funcs], Flatten@{vars[[1]], pltRng[[1]]}, PlotStyle -> Directive[Red, DotDashed], PlotRangeClipping -> False]]] plot[{x + y == 0, x^2 - y == 0}]

enter image description here

The default will use the first variable in canonical order as the independent variable (e.g., x comes before y and t comes before w).

plot[{w t - w^3 == 0, t^2 - 2 w^2 t + w^4 == 0}, Automatic, {{-1, 5}, {-3, 3}}]

enter image description here

Reverse the axes by specifying the {independent, dependent) variables

plot[{w t - w^3 == 0, t^2 - 2 w^2 t + w^4 == 0}, {w, t}, {{-3, 3}, {-1, 5}}]

enter image description here

When there are no solutions:

plot[{x + y + 2 == 0, x^2 - y == 0}]

enter image description here

EDIT: Re your comment. If you use ContourStyle -> None there is no need for the ContourPlot; use instead:

plot[system_, variables_ : Automatic, pltRng_ : {{-10, 10}, {-10, 10}}] := Module[{funcs, solutions, vars}, vars = If[variables === Automatic, Variables[Level[system, {-1}]], variables]; solutions = Quiet@Solve[system, vars, Reals, Method -> Reduce]; funcs = Select[solutions, Length@# == 1 &][[All, 1, -1]]; Show[ ListPlot[Tooltip[vars] /. solutions, PlotStyle -> Red, Frame -> True, PlotRange -> pltRng, FrameLabel -> (Style[#, 14] & /@ vars), PlotLabel -> StringForm["solutions: ``\n", solutions]], Plot[Evaluate[Tooltip /@ funcs], Flatten@{vars[[1]], pltRng[[1]]}, PlotRangeClipping -> False]]]
Improve this answer
$\endgroup$
1
  • $\begingroup$ Your code is very concise and efficient. Adding ContourStyle -> None in ContourPlot[] gives me exactly the result I wanted. Thank you very much! $\endgroup$ Commented Nov 16, 2024 at 2:40

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.