1
$\begingroup$

I have two polynomials in k given by f[b,d,k] and g[b,d,k]. I know that there exists a function k[u,v] such that, when we evaluate this function in the system, we get a new equation h[b,d]=0, which defines a curve. I would like to find that solution in k. The problem is that, for instance, we could have that g is a fourth-degree polynomial in k and, if we extract all the roots with

Solve[g[b,d,k]==0,k],

then it could happen that some functions k=k[b,d] don't provide a solvable equation

f[b,d,k[b,d]]==0

Up until now, what I've done is the following thing:

sols = Solve[g[b,d,k] == 0, k];
For[l = 1, l <= Length[sols], l++,
  ktemp = sols[[l]][[1]][[2]];
  tempcurve = f[b,d,k] /. k -> ktemp;
  tempplot = ContourPlot[tempcurve == 0, {b,0,4}, {d,0,6}];
  If[ Length[Cases[Normal@tempplot, Line[x_] :> x, Infinity]] > 0,
   k = ktemp;
   Break;
   ]
  ];

However, as this code is plotting each implicit function for each k, it may take a long time. I was wondering if there is an optimal way to do this.

I'm currently just testing my code so I am not dealing with difficult functions for now but take, for example,

f[b,d,k]=d + k^2 + 0.002025 d k^2 + 0.002025 k^4 + b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) g[b,d,k]=1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2

Of course, in that case, g can be easily solved for k^2, but I am trying to work out the general case as I stated before.

$\endgroup$
1
  • 1
    $\begingroup$ This sounds like a problem that can be solved with a Gröbner basis. Please give a concrete example of your $f(u,v,k)$ and $g(u,v,k)$ so that people can experiment. $\endgroup$
    – Roman
    Jul 21, 2021 at 14:47

3 Answers 3

1
$\begingroup$

Don't kwow if i got your question right.

If you solve with Reduce you see, you get two solution functions k[b,d] depending on variables b and d. (I rationalized for better layout)

ff=f[b_, d_, k_] = 
   d + k^2 + 0.002025 d k^2 + 0.002025 k^4 + 
   b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize[#,0]&;
gg=g[b_, d_, k_] = 
   1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) +  0.00405 k^2 // 
  Rationalize[#,0]&;

red2 = Reduce[Rationalize[{f[b, d, k] == 0, g[b, d, k] == 0}, 0], k, 
               Reals];

TraditionalForm[
 red2 /. Or -> 
 Composition[(Column[#, Right, Background -> {{White, LightGray}}, 
   Frame -> All] &), List]]

enter image description here

Edit

You can extract k[b,d] for instance with

ksol2[b_, d_] = k /. Rule @@ red2[[1, 2, 1, 2, 2]]

but then you get a surface, you can plot with pl = Plot3D[ksol2[b, d], {b, 0, 6}, {d, 0, 8}, PlotPoints -> 200]

Since you need a 3 dimensional curve (in parameter form, both d and k depending on the one parameter b), you better (than red2) solve for d and k directly with sol3 and plot the curve pp

sol3 = Solve[{f[b, d, k] == 0, g[b, d, k] == 0}, {d, k}, Reals] // 
  Simplify

pp = ParametricPlot3D[Evaluate[{b, d, k} /. sol3], {b, 0, 5}, 
  AxesLabel -> {b, d, k}, PlotStyle -> {{Thick, Red}}]

Together with the contour plot for both equations, see the curve as red intersection line (i consider only positive b,d,k)

cpff = ContourPlot3D[ff == 0, {b, 0, 2}, {d, 0, 2}, {k, 0, 12}, 
 PlotPoints -> 20, AxesLabel -> {b, d, k}, 
 ContourStyle -> {Opacity[.5], Green}]

cpgg = ContourPlot3D[gg == 0, {b, 0, 2}, {d, 0, 2}, {k, 0, 12}, 
PlotPoints -> 20, AxesLabel -> {b, d, k}, 
ContourStyle -> {Opacity[.5], Blue}]

Show[cpff, cpgg, pp]

enter image description here

$\endgroup$
0
1
$\begingroup$

Her we provide a way to draw such plot.

f[b_, d_, k_] = 
  d + k^2 + 0.002025 d k^2 + 0.002025 k^4 + 
    b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize;
g[b_, d_, k_] = 
  1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2 // 
   Rationalize;
eq = Exists[k, f[b, d, k] == 0 && g[b, d, k] == 0];
sol = Resolve[eq, Reals, Backsubstitution -> True]
ContourPlot[sol // Last // Evaluate, {b, -5, 5}, {d, -5, 5}, 
 RegionFunction -> Function[{b, d, k}, sol // Most // Evaluate], 
 PlotPoints -> 50, MaxRecursion -> 4]

b^2 + d != 0 && -40000 b^4 + 81 b^6 + 243 b^4 d + 40000 d^2 + 243 b^2 d^2 + 81 d^3 <= 0 && 1600000000 b^4 - 19440000 b^6 + 6561 b^8 - 3200000000 b^2 d - 45360000 b^4 d + 26244 b^6 d + 1600000000 d^2 - 32400000 b^2 d^2 + 39366 b^4 d^2 - 6480000 d^3 + 26244 b^2 d^3 + 6561 d^4 == 0

The same as

Eliminate[{f[b, d, k] == 0 , g[b, d, k] == 0}, k]

enter image description here

$\endgroup$
1
  • $\begingroup$ That's wonderful but how can I get the value of k explicitly? $\endgroup$ Jul 21, 2021 at 16:21
1
$\begingroup$

We can plot the space curve by

f[b_, d_, k_] = 
  d + k^2 + 0.002025 d k^2 + 0.002025 k^4 + 
    b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize;
g[b_, d_, k_] = 
  1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2 // 
   Rationalize;
reg = ImplicitRegion[
   f[b, d, k] == 0 && 
    g[b, d, k] == 0, {{b, -5, 5}, {d, -5, 5}, {k, -25, 25}}];
DiscretizeRegion[reg, MaxCellMeasure -> 10^-5, 
 PlotRange -> {{-5, 5}, {-5, 5}, {-25, 25}}]

enter image description here

And we get the b-d curve again by

RegionPlot[curves, FrameLabel -> {"b", Rotate["d", π/2]}, 
 LabelStyle -> {FontSize -> 15, Brown}]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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