Как построить решения для системы уравнений в Mathematica? - PullRequest
Новая
       34

Как построить решения для системы уравнений в Mathematica?

1 голос
/ 26 июля 2011

Как можно построить решения для системы уравнений в Mathematica?Даже если есть только две переменные, эти уравнения достаточно сложны, так что их нельзя переставить так, чтобы одну из переменных можно было установить равной функции другой (и, таким образом, иметь правильную форму для Plot).

Интересующий меня конкретный пример:

  • Fix a b in (0,1).
  • Let g > = 1 и d > = 1 варьируются.
  • Тогда существует уникальный x (который находится в (0,1))такой, что x = [(bx + 1) / (x + g)] ^ d (доказательство опущено).
  • Мне нужен график пар (d, g), который (1 - bg) xd / [(bx + 1) (x + g)] = 1.

Ответы [ 2 ]

3 голосов
/ 26 июля 2011

Вы хотите использовать ContourPlot.

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

Вы также можете использовать ImplicitPlot, но он устарел:

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

2 голосов
/ 02 августа 2011

Я полагаю, вы ищете какой-то элегантный метод, но сейчас вот как это сделать грубо: 

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

enter image description here

Ужасно уродливый путь, но вот оно.

Обратите внимание, что я просто быстро написал это, поэтому я не даю никаких гарантий, что это правильно!

РЕДАКТИРОВАТЬ: Вот как это сделать, предоставив только 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"}]

1022 * дает *

enter image description here

...