如何在Mathematica中绘制一组方程的解？

Question

如何在Mathematica中绘制一组方程的解？即使只有两个变量，这些方程也足够复杂，不能重新排列，因此其中一个变量可以设置为等于另一个变量的函数（因此Plot的形式正确）。

我感兴趣的具体示例如下：

• 在（0,1）。
中修复 b
• 让 g ＆gt; = 1而 d ＆gt; = 1会有所不同。
• 然后有一个唯一的 x （碰巧在（0,1）中），使得x = [（bx + 1）/（x + g）] ^ d（证明省略）。
• 我想要一对（d，g）的图（1 - b g）x d / [（b x + 1）（x + g）] = 1.

Answer 1

您想使用ContourPlot。

http://reference.wolfram.com/mathematica/ref/ContourPlot.html

您也可以使用ImplicitPlot，但不推荐使用：

http://reference.wolfram.com/legacy/v5_2/Add-onsLinks/StandardPackages/Graphics/ImplicitPlot.html

Answer 2

我想你正在寻找一些优雅的方法，但现在这里是如何蛮力：

Clear[findx];findx[d_,g_,b_]:=x/.First@FindRoot[x\[Equal]((b x+1)/(x+g))^d,{x,0,1},PrecisionGoal\[Rule]3]
ClearAll[plotQ];
plotQ[d_,g_,b_,eps_]:=Module[
    {x=findx[d,g,b]},
    Abs[(1-b g) x d/((b x+1) (x+g))-1.]<eps]

tbl=Table[{d,g,plotQ[d,g,.1,.001]},{d,4,20,.05},{g,1,1.12,.001}];

（这应该是大约10秒）。然后绘制如下点：

Reap[
    Scan[
        If[#[[3]] == True,
            Sow@Point[{#[[1]], #[[2]]}]] &,
            Flatten[tbl, 1]]] // Last // Last // 
 Graphics[#, PlotRange -> {{1, 20}, {1, 1.1}}, Axes -> True,
    AspectRatio -> 1, AxesLabel -> {"d", "g"}] &

痛苦的丑陋方式去做，但确实如此。

请注意，我只是快速写了这个，所以我不保证它是正确的！

编辑：以下是仅提供b以及d的步骤大小的方法：

Clear[findx]; 
findx[d_, g_, b_] := 
 x /. First@
   FindRoot[x \[Equal] ((b x + 1)/(x + g))^d, {x, 0, 1}, 
    PrecisionGoal \[Rule] 3]
ClearAll[plotQ];
plotQ[d_, g_, b_, eps_] := 
 Module[{x = findx[d, g, b]}, 
  Abs[(1 - b g) x d/((b x + 1) (x + g)) - 1.] < eps]

tbl = Table[{d, g, plotQ[d, g, .1, .001]}, {d, 4, 20, .05}, {g, 1, 
    1.12, .001}];

ClearAll[tmpfn];
tmpfn[d_?NumericQ, g_?NumericQ, b_?NumericQ] := 
 With[{x = findx[d, g, b]},
    (1 - b g) x d/((b x + 1) (x + g)) - 1.
  ]

然后

stepsize=.1

(tbl3=Table[
    {d,g/.FindRoot[tmpfn[d,g,.1]\[Equal]0.,
        {g,1,2.},PrecisionGoal\[Rule]2]},
    {d,1.1,20.,stepsize}]);//Quiet//Timing

ListPlot[tbl3,AxesLabel\[Rule]{"d","g"}]

给